and the 16 bit palette is exactly the resistor based palette from my retro computer.
2 pixels per byte and the extra bit are a kind of brightness added to red,green and blue if set.
(if you like)
save parrot.png I posted and convert it as 24-bit *.bmp
or use my FBimage staic lib for reading *.bmp,*.pcx,*.tga,*.jpg,*.png,*.dds ...
Joshy
Code: Select all
const filename = "parrot.bmp"
' --- floyd steinberg dithering - 2017 Oct 2 - by dafhi
'
' Input: truecolor image metrics and target color (per pixel)
' output: truecolor quantized and dithered
' ---------------------
type tFloydSteinberg
as long wm,hm,pitch
as ubyte ptr r0,g0,b0
as long offa,offb,offc,offd
declare sub metrics(w as long, h as long, pitch as long, pixels as ubyte ptr)
declare sub drop_it(x as long, y as long, newcol as ulong)
private:
declare sub n(off as long, amount as long)
as long re,ge,be, r,g,b, cen
End Type
sub tFloydSteinberg.metrics(w as long, h as long, _pitch as long, pixels as ubyte ptr)
wm=w-1: hm=h-1: pitch=_pitch
b0=pixels: g0=pixels+1: r0=pixels+2
offa=4: offb=pitch+4: offc=pitch: offd=pitch-4
End Sub
sub tFloydSteinberg.n(off as long, amount as long)
r=r0[off]+(re*amount)shr 4: r0[off] = r + r*(r<0) + (r-255)*(r>255)
g=g0[off]+(ge*amount)shr 4: g0[off] = g + g*(g<0) + (g-255)*(g>255)
b=b0[off]+(be*amount)shr 4: b0[off] = b + b*(b<0) + (b-255)*(b>255)
End Sub
sub tFloydSteinberg.drop_it(x as long, y as long, newcol as ulong)
r=(newcol shr 16)and 255
g=(newcol shr 8)and 255
b=newcol and 255: cen=x*4 + y*pitch
re=r0[cen]-r: r0[cen]=r
ge=g0[cen]-g: g0[cen]=g
be=b0[cen]-b: b0[cen]=b
if x<wm then
n offa+cen, 7
if y<hm then
n offb+cen, 1
n offc+cen, 5
if x>0 then n offd+cen, 3
EndIf
elseif y<hm then
n offb+cen, 1
n offc+cen, 5
if x>0 then n offd+cen, 3
endif
End Sub
'
' -----------------
' 3 bit
function pal_func8(i as ubyte) as ulong
dim as ulong r=(i and &B001)
dim as ulong g=(i and &B010) shr 1
dim as ulong b=(i and &B100) shr 2
return RGB(r*255,g*255,b*255)
end function
' 4 bit resistor based from my retro computer
' 2 pixels per byte the f-bit is a kind of brighness
function pal_func16(i as ubyte) as ulong
dim as ulong f=(i and &B1000) shr 3
dim as ulong r=(i and (&B001 or (f*&B10)))
dim as ulong g=(i and (&B010 or (f*&B01)))
dim as ulong b=(i and (&B100 or (f*&B10))) shr (2-f)
return RGB(r*255,g*85,b*85)
end function
' 5 bit
function pal_func32(i as ubyte) as ulong
dim as ulong r=(i and &B00001)
dim as ulong g=(i and &B00110) shr 1
dim as ulong b=(i and &B11000) shr 3
return RGB(r*255,g*85,b*85)
end function
' 6 bit
function pal_func64(i as ubyte) as ulong
dim as ulong r=(i and &B000011)
dim as ulong g=(i and &B001100) shr 2
dim as ulong b=(i and &B110000) shr 4
return RGB(r*85,g*85,b*85)
end function
' 7 bit (green priority)
function pal_func128(i as ubyte) as ulong
dim as ulong r=(i and &B0000011)
dim as ulong g=(i and &B0011100) shr 2
dim as ulong b=(i and &B1100000) shr 5
return RGB(r*85,g*36,b*85)
end function
' 8 bit (green blue priority)
function pal_func256(i as ubyte) as ulong
dim as ulong r=(i and &B00000011)
dim as ulong g=(i and &B00011100) shr 2
dim as ulong b=(i and &B11100000) shr 5
return RGB(r*85,g*36,b*36)
end function
' 9 bit
function pal_func512(i as ushort) as ulong
dim as ulong r=(i and &B000000111)
dim as ulong g=(i and &B000111000) shr 3
dim as ulong b=(i and &B111000000) shr 6
return RGB(r*36,g*36,b*36)
end function
' 10 bit (green priority)
function pal_func1024(i as ushort) as ulong
dim as ulong r=(i and &B0000000111)
dim as ulong g=(i and &B0001111000) shr 3
dim as ulong b=(i and &B1110000000) shr 7
return RGB(r*36,g*17,b*36)
end function
' 11 bit (green blue priority)
function pal_func2048(i as ushort) as ulong
dim as ulong r=(i and &B00000000111)
dim as ulong g=(i and &B00001111000) shr 3
dim as ulong b=(i and &B11110000000) shr 7
return RGB(r*36,g*17,b*17)
end function
' 12 bit
function pal_func4096(i as ushort) as ulong
dim as ulong r=(i and &B000000001111)
dim as ulong g=(i and &B000011110000) shr 4
dim as ulong b=(i and &B111100000000) shr 8
return RGB(r*36,g*17,b*17)
end function
#Ifndef UnionARGB
Union UnionARGB
As Ulong col
Type: As UByte B,G,R,A
End Type
End Union
#EndIf
function qdr(a as any ptr, b as any ptr) as ulong
dim as unionargb ptr uara = a, uarb = b
return (uara->r-uarb->r)*(uara->r-uarb->r)+(uara->g-uarb->g)*(uara->g-uarb->g)+(uara->b-uarb->b)*(uara->b-uarb->b)
End Function
type imagevars '2017 Sep 28 - by dafhi
'1. quick reference for ScreenInfo & ImageInfo
'2. encapsulate standard metrics
'3. convenient additional vars, subs and functions
as integer w,h, bpp,bypp,pitch, rate
as string driver_name
as any ptr im
as any ptr pixels 'same address
as ulong ptr p32 '
as single midx,midy
as integer pitchBy, wm = -1, hm = -1, ub = -1, is_screen
declare sub screen_init(w as integer=0, h as integer=0, bpp as integer=32, npages as integer=1, flags as integer=0)
declare sub create(w as integer=0, h as integer=0, col as ulong=&HFF000000)
declare sub bmp_load( ByRef filename As String )
'2017 Aug 17
declare sub get_info(im as any ptr=0)
declare sub release
declare destructor
private:
declare sub destroy
as any ptr hRelease
end type
Destructor.imagevars: release
End Destructor
sub imagevars.release '2016 Aug 30
w=0: h=0: bpp=0: bypp=0: im=0: pixels=0
If ImageInfo(hRelease) = 0 Then ImageDestroy hRelease: hRelease = 0
End Sub
sub imagevars.get_info(im as any ptr)
if im=0 then
ScreenInfo w,h, bpp, bypp, pitch, rate, driver_name: pixels=screenptr
is_screen = -1: im=0
elseif Imageinfo(im)=0 then
ImageInfo im, w, h, bypp, pitch, pixels: bpp = bypp * 8
this.im = im: is_screen = 0
endif: hRelease = im: p32=pixels
wm=w-1: midx=w/2: pitchBy=pitch/bypp '' crashes if \ and bypp = 0
hm=h-1: midy=h/2: ub = h*pitchBy - 1
end sub
sub imagevars.screen_init(w as integer, h as integer, bpp as integer, npages as integer, flags as integer)
release '2017 July 3
if w=0 or h=0 then get_info: w=this.w: h=this.h
screenres w,h,bpp,npages,flags: pixels = screenptr
get_info: if npages > 1 then screenset 0,1
end sub
sub imagevars.create(_w as integer, _h as integer, col as ulong)
if _w<1 or _h<1 then exit sub '2017 sep 1
release: get_info imagecreate(_w,_h,col)
End Sub
sub imagevars.bmp_load( ByRef filename As String ) 'modified fb example
Dim As integer filenum = FreeFile(), w,h '2017 Sep 28 .. long to integer
for i as integer = 1 to 2
If Open( filename For Binary Access Read As #filenum ) = 0 Then
Get #filenum, 19, w
Get #filenum, 23, h
create w, abs(h)
bload filename, im: close #filenum: exit for
endif
Close #filenum
filename = exepath & "\" & filename
next
End sub
sub Main
dim as imagevars buf, im
buf.screen_init 1400,900
var file = filename
im.bmp_load file
var pal_size = 16, u = pal_size-1
dim as ulong a(u)
for i as long = 0 to u
select case as const pal_size
case 8 : a(i) = pal_func8(i)
case 16 : a(i) = pal_func16(i)
case 32 : a(i) = pal_func32(i)
case 64 : a(i) = pal_func64(i)
case 128 : a(i) = pal_func128(i)
case 256 : a(i) = pal_func256(i)
case 512 : a(i) = pal_func512(i)
case 1024 : a(i) = pal_func1024(i)
case 2048 : a(i) = pal_func2048(i)
case 4096 : a(i) = pal_func4096(i)
end select
Next
dim as tFloydSteinberg fs
fs.metrics im.w, im.h, im.pitch, im.pixels
for y as long = 0 to im.hm
dim as ulong ptr p = im.pixels: p += y*im.pitch \ im.bypp
for x as long = 0 to im.wm
var i = 0, s = qdr( @a(i), @p[x] )
for j as long = 1 to ubound(a)
var d = qdr( @a(j), @p[x] )
if d<s then s=d: i=j
Next
fs.drop_it(x,y, a(i))
Next
next
put (0,0), im.im
windowtitle "pal size: " & pal_size & " done!"
sleep
end sub
Main