Find the best 8 bit palette for an RGB image

General FreeBASIC programming questions.
D.J.Peters
Posts: 8586
Joined: May 28, 2005 3:28
Contact:

Re: Find the best 8 bit palette for an RGB image

Post by D.J.Peters »

@dafhi I added some more palettes 3-12 bit (only for fun)
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
dafhi
Posts: 1641
Joined: Jun 04, 2005 9:51

Re: Find the best 8 bit palette for an RGB image

Post by dafhi »

those are awesome!

I will have to see about FBImage :-) Also, I've updated tFloydStienberg
dafhi
Posts: 1641
Joined: Jun 04, 2005 9:51

Re: Find the best 8 bit palette for an RGB image

Post by dafhi »

Code: Select all

function pal_func4(i as ushort) as ulong
  var r=(i=1)and 1, g=(i=2)and 1, b=(i=3)and 1
  return rgb( 255*(b or g), 255*(r or b), 255*(r or g) )
End Function
D.J.Peters
Posts: 8586
Joined: May 28, 2005 3:28
Contact:

Re: Find the best 8 bit palette for an RGB image

Post by D.J.Peters »

dafhi wrote:

Code: Select all

function pal_func4(i as ushort) as ulong
  var r=(i=1)and 1, g=(i=2)and 1, b=(i=3)and 1
  return rgb( 255*(b or g), 255*(r or b), 255*(r or g) )
End Function
good job I added 2 color palette also it's complete now :-)

Joshy
Image

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
'
' -----------------
' 1-bit
function pal_func2(i as ulong) as ulong
  i = (i and 1)*255
  return rgb(i,i,i)
End Function
' 2-bit
function pal_func4(i as ulong) as ulong
  dim as ulong r=(i=1)and 1, g=(i=2)and 1, b=(i=3)and 1
  return rgb( 255*(b or g), 255*(r or b), 255*(r or g) )
End Function

' 3 bit
function pal_func8(i as ulong) 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  ulong) 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 ulong) 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 ulong) 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  ulong) 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 ulong) 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 ulong) 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 ulong) 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 ulong) 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 ulong) 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 = 2, u = pal_size-1
  dim as ulong a(u)
  for i as long = 0 to u
    select case as const pal_size
    case    2 : a(i) = pal_func2(i)
    case    4 : a(i) = pal_func4(i)
    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
dafhi
Posts: 1641
Joined: Jun 04, 2005 9:51

Re: Find the best 8 bit palette for an RGB image

Post by dafhi »

bugfix:

Code: Select all

sub tFloydSteinberg.drop_it(x as long, y as long, newcol as ulong)
  ..
  elseif y<hm then
    'n offb+cen, 1 'bugfix:  out-of-bounds - 2017 Oct 4
    n offc+cen, 5
    if x>0 then n offd+cen, 3
  endif
End Sub
fatman2021
Posts: 215
Joined: Dec 14, 2013 0:43

Re: Find the best 8 bit palette for an RGB image

Post by fatman2021 »

My I ask why my 8-bit bitmaps are the same size as my 32-bit bitmaps. Shouldn't they be smaller?
dafhi
Posts: 1641
Joined: Jun 04, 2005 9:51

Re: Find the best 8 bit palette for an RGB image

Post by dafhi »

D.J. Peters. my old 16 color palette - 4 grays: 0(i=0) 96(i=7) 192(i=15) 255(i=8) .. I'm making a new one

fatman..

input: 32 bit
output: 32 bit
dafhi
Posts: 1641
Joined: Jun 04, 2005 9:51

Re: Find the best 8 bit palette for an RGB image

Post by dafhi »

D.J. Peters - I have renamed all your functions

Code: Select all

' 12 bit
function pal_func12(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
Post Reply