any objections to having full brightness blue arrive in last half of 16 colors?
[edit] - i have an objection. pal size 4 looks amazing but the others, not so much.
Code: Select all
'' can view 2 files at once, but only .bmp
#define file1 ".bmp"
#define file2 ".bmp"
'' you may also want to change this
#define file_dir "photos/"
/' -- About
universal palette conceptualization - 2023 Sep 28 - by dafhi
'/
' ====================
#define sng as single
#define dbl as double
#define min( a, b) iif( (a)<(b), (a), (b) )
#define max( a, b) iif( (a)>(b), (a), (b) )
function bclamp( i sng ) as ubyte '' Feb 23
return min( max( i, 0), 255 )
End Function
function clamp( in sng, hi sng = 1, lo sng = 0) sng
return min( max(in, lo), hi ) '' Mar 8
End Function
union uptrs
as any ptr a
as ubyte ptr b
as ushort ptr sho
as ulong ptr ul
as ulongint ptr uli
As Single Ptr s
as double ptr d
End Union
'
' -------- boilerplate
' ------- util.bas continued ..
'
function triwave( i sng ) sng
return abs( i - int(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
sub grad( a() sng, v0 sng, v1 sng, steps as long = 1, _
idx as long = 0, delta_flag as boolean = true )
if idx + steps - 1 > ubound(a) then redim preserve a(idx+steps-1)
v1 = iif( delta_flag, (v1-v0)/(steps-1), v1 )
for j as long = 0 to steps - 1
a(j+idx) = v0 + j * v1
next
end sub
const h_red = 0/12
const h_orange = 1/12
const h_yellow = 1/6
const h_green = 1/3
const h_blue = 2/3
'
' -------- util.bas
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 long 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 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 destructor
private:
declare sub _release
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.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
dim as ushort w,h
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
' --- floyd steinberg dithering - 2023 Sep 19 - 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 '' 2023 Sept 19
if 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
declare operator cast as string
declare operator let( as ulong)
End Union
operator unionARGB.let( in as ulong )
r = (in shr 16) and 255
g = (in shr 8) and 255
b = in and 255
end operator
operator unionARGB.cast as string
return str(r) + " " + str(g) + " " + str(b)
end operator
#EndIf
function qdr(a as any ptr, b as any ptr) as longint
dim as unionargb ptr uara = a, uarb = b
const pow = 2
dim as longint dr = abs(uara->r - uarb->r)
dim as longint dg = abs(uara->g - uarb->g)
dim as longint db = abs(uara->b - uarb->b)
return _
(dr * 3/3)^pow+_
(dg * (3/3 + .08))^pow+_
(db * (3/3 - .08))^pow
End Function
namespace gp_pal
dim as tFloydSteinberg fs
dim as ulong _pal256(255)
dim as ulong palsrc()
dim as ubyte group_size(7) = {2,2,4,8,16,32,64,128}
dim as ubyte group_start(ubound(group_size))
dim as byte i_group
dim as string str_pal_size
dim as string str_value
type tPicGroup
as imagevars im(any)
end type
dim as tPicGroup pic_group
function f_ubound_from_group as long
dim as long u = group_size(0)-1
for i as long = 1 to i_group
u += group_size(i)
next
return u
end function
sub _set_groups_pos0
static as long initialized: if initialized then exit sub
group_start(0) = 0
for i as long = 1 to ubound(group_size)
group_start(i) = group_start(i-1) + group_size(i-1)
next
initialized = true
end sub
sub visual_palette
const size = 11
const size1 = size + 1
const sizem = size - 1
for y as long = 0 to i_group
for x as long = 0 to group_size(y) - 1
line _
(size1*x, size1*y) - _
(size1*x+ sizem, size1*y + sizem), _
_pal256( group_start(y) + x ), bf
next
next
end sub
sub show
redim palsrc( f_ubound_from_group )
for i as long = 0 to ubound(palsrc)
palsrc(i) = _pal256(i)
dim as unionargb uar: uar = palsrc(i)
next
dim as uptrs upr
dim as long lx
for i as long = 0 to ubound(pic_group.im)
put (lx,1), pic_group.im(i).im, pset
var wm = min(lx + pic_group.im(i).wm, fs.wm)
for y as long = 1 to min( 1 + pic_group.im(i).hm, fs.hm)
upr.a = fs.b0 + y*fs.pitch
for x as long = lx to wm
var i = 0
var s = qdr( @palsrc(i), @upr.ul[x] )
for j as long = 1 to ubound( palsrc )
var d = qdr( @palsrc(j), @upr.ul[x] )
if d<s then s=d: i=j
Next
fs.drop_it(x,y, palsrc(i))
next
next
lx += pic_group.im(i).w + 1
next
#if 1
visual_palette
#endif
screenlock
screenunlock
end sub
sub add_bmp( file as string )
var u = ubound( pic_group.im) + 1
redim preserve pic_group.im( u )
pic_group.im(u).bmp_load file_dir + file
end sub
dim sng hsv_h(255)
dim sng hsv_s(255)
dim sng hsv_v(255)
sub to_pal( i as long )
for j as long = group_start(i) to group_start(i) + group_size(i)-1
_pal256(j) = hsv( hsv_h(j), hsv_s(j), hsv_v(j) )
next
end sub
sub depth_change( amt as long, _show as boolean = true )
if amt < 0 and i_group = 0 orelse _
amt > 0 and i_group = ubound(group_size) then exit sub
i_group += amt
to_pal i_group
if _show then show
str_pal_size = "pal size " + str( 2 shl i_group )
var str_group_start = str( group_start(i_group+0) )
windowtitle str_pal_size '+ ", group_start " + str_group_start
end sub
sub _groups_0to3
const delta_flag = 0
grad hsv_v(), 1, 1, 8, 0 '' 1.0..1.0 for 8 elements
hsv_v(1) = 1/4 '' dark blue when hue becomes 2/3
hsv_v(4) = 0 '' black @ elem 5
'' hue 1/3, incr 1/3
grad hsv_h(), 1/3, 1/3, 4, 0, delta_flag
grad hsv_s(), 1, 1, 15, 1 '' 15 elems of full saturaation
'' C M Y
grad hsv_h(), 1/6, 1/3, 3, 5, delta_flag
'' R c G m B y
grad hsv_h(), 0/3, 1/6, 6, 8, delta_flag
grad hsv_v(), 1/4, 1/4, 8, 8
hsv_v(12) = 1 '' full bright blue
grad hsv_h(), 1/12, 0/6, 2, 14, delta_flag '' 2 orange (1 half-bright)
hsv_v(14) = 1/2 '' half bright orange (brown)
hsv_v(15) = 1/1 '' orange
to_pal 0
to_pal 1
to_pal 2
to_pal 3
end sub
sub pal_init
_set_groups_pos0
_groups_0to3
end sub
end namespace
#include "fbgfx.bi" '' key codes
sub Main
screenres 1400,900, 32
dim as imagevars buf
buf.get_info
using gp_pal
fs.metrics buf.w, buf.h, buf.pitch, buf.pixels
add_bmp file1
add_bmp file2
pal_init
var render_flag = false
for i as long = 1 to iif(1, 0, ubound(group_size)-0)
depth_change 1, render_flag
next
show
locate 2,7
? "keys: left, right"
dim as string*2 kstr
#define extchar chr(255)
do
kstr = inkey
var ctrl_or_shift = multikey(fb.sc_lshift) _
or multikey(fb.sc_control) or multikey(fb.sc_rshift)
select case (kstr)
case extchar + chr(75) '' left
depth_change -1
case extchar + chr(77) '' right
depth_change 1
end select
sleep 15
loop until kstr = chr(27)
end sub
Main