May 20 - a return to previous partitioning style
--
demo palette squares
Code: Select all
/' -- demo palette squares
'/
'#include "../palette_generalist.bas"
screenres 800,600,32
for c as long = 2 to 24
'for c as long = 7 to 7 '' debugger
represent c
next
sleep
demo floyd-steinberg [May 20]
Code: Select all
const filename = "../z/a5.bmp" '' give this thing a .bmp!
/' -- palette generalist + floyd-steinberg demo - by dafhi
'/
'#include "../palette_generalist.bas"
function bclamp( i sng ) as ubyte '' Feb 23
return min( max( i, 0), 255 )
End Function
' --- 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] = bclamp(r)
g=g0[off]+(ge*amount)shr 4: g0[off] = bclamp(g)
b=b0[off]+(be*amount)shr 4: b0[off] = bclamp(b)
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
'
' -----------------
#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 _
abs(uara->r-uarb->r)^2+_
abs(uara->g-uarb->g)^2+_
abs(uara->b-uarb->b)^2
End Function
type imagevars '2022 Mar 15 - 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 wh,hh, diagonal
as integer pitchBy, wm = -1, hm = -1, u = -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 blit( as integer=0, as integer=0, size as ubyte=0, byref pdest as any ptr=0)
declare sub bmp_load( ByRef filename As String )
'2017 Aug 17
declare sub get_info(im as any ptr=0)
declare sub scan( as any ptr = 0 ) '' example: scan imagecreate(400, 300)
declare sub release
declare destructor
private:
declare sub destroy
as any ptr hRelease
declare sub _specialized
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._specialized
wm = w - 1: wh = w/2
hm = h - 1: hh = h/2
pitchBy = pitch \ bypp: u = h*pitchBy - 1
p32 = pixels: diagonal = sqr(w*w + h*h)
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: wh=w/2: pitchBy=pitch/bypp '' crashes if \ and bypp = 0
hm=h-1: hh=h/2: u = 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 imagevars.scan( _im as any ptr) '' 2022 Mar 15
if (_im = 0) orelse (_im = screenptr) then
ScreenInfo w,h, bpp, bypp, pitch, rate, driver_name: _
pixels = screenptr: _specialized
elseif Imageinfo(_im) = 0 then
ImageInfo _im, w, h, bypp, pitch, pixels: _
bpp = bypp * 8: _specialized
endif
im = 0 '' avoids imagedestroy
end sub
sub imagevars.blit( x as integer, y as integer, size as ubyte, byref pdest as any ptr) '2022 Mar 16
if size > 1 then
static as imagevars vdes
var sizem=size-1
if pdest=0 then vdes.scan': pdest=@dest
var x1=x+wm*size: if x1>vdes.wm then x1=vdes.wm
var y1=y+hm*size: if y1>vdes.hm then y1=vdes.hm
for iy as long=y to y1 step size
dim as ulong ptr psrc = p32 + ((iy-y)\size) * pitchBy
if pdest=0 or vdes.im=0 then
for ix as long=x to x1 step size
line (ix,iy)-(ix+sizem,iy+sizem),psrc[(ix-x)\size],bf: next
else
for ix as long=x to x1 step size
line vdes.im,(ix,iy)-(ix+sizem,iy+sizem),psrc[(ix-x)\size],bf: next
endif
next
else
if pdest = 0 orelse pdest = screenptr then
put (x,y), im, pset
elseif imageinfo(pdest)=0 then
put pdest, (x,y), im, pset
endif
endif
End Sub
sub Main
dim as imagevars buf, im, im_origin
buf.screen_init 1400,900
var file = filename
im_origin.bmp_load file
im.create im_origin.w, im_origin.h
for pal_size as long = 2 to 16 step 1
var u = pal_size-1
dim as ulong a(u)
for i as long = 0 to u
a(i) = palette_generalist( i, pal_size )
Next
im_origin.blit 0,0,, im.im
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, pset
locate 5,5
print "palette: "; pal_size
sleep 600
if inkey=chr(27) then exit for
next
' represent pal_size
windowtitle " done!"
'windowtitle "pal size: " & pal_size & " done!"
sleep
end sub
Main
rather than make a bunch of files, simply paste below the include
palette_generalist.bas
Code: Select all
/' -- palette generalist - alpha - 2023 May 20 - by dafhi
returned to grays being in the middle
simplified algorithm
some similar palette sizes look better (new floyd-steinberg demo)
project design goal
oldschool goodness, one function
inspired by several things
1. "ufo hsv" color model i imagine (rim = full saturation)
2. floyd-steinberg
'/
#define sng as single
#define flo(x) (((x)*2.0-0.5)shr 1) '' replaces int (and faster) - http://www.freebasic.net/forum/viewtopic.php?p=118633
#define min( a, b) iif( (a)<(b), (a), (b) )
#define max( a, b) iif( (a)>(b), (a), (b) )
function clamp( in sng, hi sng = 1, lo sng = 0) sng
return min( max(in, lo), hi ) '' Mar 8
End Function
function triwave( i sng ) sng
return abs( i - flo(i) - .5 ) - .25 '' triwave by Stonemonkey
end function
function _cchsv(h sng, s sng, v sng) as ubyte
var wave_hgt = s * v
var elevate = v - wave_hgt
return 255.499 * (wave_hgt * clamp(triwave(h)*6 + .5) + elevate)
end function
function hsv( h sng=0, s sng=1, v sng=1 ) as ulong '' 2023 April 8
return rgb( _
_cchsv( h + 0/3, s,v ), _
_cchsv( h + 2/3, s,v ), _
_cchsv( h + 1/3, s,v ) )
end function
function c_partitions( c as short, powa sng ) sng
return max(int( log(c^powa) +.5 ), 1)
end function
function palette_generalist( i as long, c as short = 8 ) as ulong
/' algorithm still being conceptualized
most of this is random attempts at something useful
'/
const sat_c_base = 9
var u = c - 1
dim sng h, s, v, f, mod_, s1, near_int_dist
var powa = 1.1f
mod_ = iif( c<sat_c_base, u, u / c_partitions( c, powa ) )
f = 1/mod_
s = i*f - int(i*f)
'' s1 is a hack to prevent adjacent grays
s1 = (i+1)*f - int((i+1)*f)
s = iif( (abs(s1 - s) < .001 or s < f + .000), _
0, iif(c < sat_c_base, 1, 1-s^4) )
v = iif( s=0, i/max(u,1), 1 )
h = (i-1)/(u-1) + 1/6
return hsv( h, min(s,1), min(v,1) )
end function
/' -- before i got the idea to create a function, i made this
'/
sub create_general_palette( pal() as ulong, c as short = 8 )
var u = c - 1
redim pal(u)
var gray_count = flo( sqr( c ) )
var gray_mod = u / max((gray_count-1), 1)
#if 0
? "mod";gray_mod
? "count"; gray_count
? "u"; u
#endif
' ? 9 mod gray_mod
for i as long = 0 to u
var hue = i / max(u-1,1) - 1/6 '' this can be fudged
var _f = i + .0001
var _s = (_f - gray_mod * flo(_f / gray_mod)) / gray_mod
'? s; " ";
var low_sat_thresh = (1 / gray_mod) - .001
_f = i / max(u,1)
const pure_color_scalar = 6 '' also fudgeable
var val_when_sat_hi = pure_color_scalar * _f
var s = iif( _s < low_sat_thresh, _s, _s ^ ( (1/gray_mod)^1) )
var v = iif( _s < low_sat_thresh, _f, val_when_sat_hi )
pal(i) = hsv( hue, min(s,1), min(v,1) )
next
end sub
/' -- demo / debug
'/
sub represent( count as ubyte = 8 )
static as long y
count = max(count, 1)
dim as ulong pal()
var block_size = 12
create_general_palette pal(), count
for i as long = 0 to count - 1
var col = iif( 0, _
pal(i), _
palette_generalist( i, count ) )
#if 1 '' i switched this off sometimes during debug
line ( i*block_size, y) - ( (i+1)*block_size, y+block_size), col, bf
#endif
next
draw string (block_size * count + 3, y), str(count) '+ iif( y=0, " (count)", "" )
y += block_size + 2
end sub