Code: Select all
'give this thing a bmp!
const as string filename = ".bmp"
/' ------ circle stacker 2017 Sep 3 - by dafhi
Seeing videos about Genetic Algorithms adjusting circles
to try and match an image inspired me to try something similar.
I use the uber-simple "hill climbing" approach.
Animated, it looks like other "learning" styles.
-------------- '/
'#include "imagevars.bas"
/' ------- imagevars 2017 Sep 1 - by dafhi -------- '/
function round(in as single, places as ubyte = 2) as string
dim as integer mul = 10 ^ places
return str(csng(int(in * mul + .5) / mul))
End Function
function roun(in as single, places as ubyte = 0) as single
dim as integer mul = 10 ^ places: return int(in * mul + .5) / mul
end function
#ifndef pi
const TwoPi = 8*atn(1)
const Pi = 4*atn(1)
const piBy4 = atn(1)
#EndIf
#Macro Alpha256(ret,back, fore, a256) '2017 Mar 26
ret=((_
(fore And &Hff00ff) * a256 + _
(back And &Hff00ff) * (256-a256) + &H800080) And &Hff00ff00 Or (_
(fore And &H00ff00) * a256 + _
(back And &H00ff00) * (256-a256) + &H008000) And &H00ff0000) Shr 8
#EndMacro
type imagevars '2017 Aug 31 - 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 integer pitchBy, wm = -1, hm = -1, ub = -1, is_screen
as single midx,midy
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 blit(x as integer=0, y as integer=0, byref pdest as imagevars ptr=0, size as ubyte=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 downscale(byref dest as imagevars ptr=0, w as single=0, h as single=0, x as single=0, y as single=0)
declare sub get_info(im as any ptr=0)
declare destructor
declare sub release
private:
declare sub aascan(yDes as long, alp as single)
declare sub destroy
as any ptr hRelease
as imagevars ptr pdes ' aablit
as long yDes1D, ySrc1D '
as single sx, x_step '
as single sy, y_step '
as single sR(any), sG(any), sB(any), a(any)
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) '2017 sep 1
if _w<1 or _h<1 then exit sub
release: get_info imagecreate(_w,_h,col)
End Sub
sub imagevars.bmp_load( ByRef filename As String ) 'modified fb example
Dim As Long filenum = FreeFile(), w,h
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.blit(x as integer, y as integer, byref pdest as imagevars ptr, size as ubyte) '2017 Aug 31
if size>1 then
var sizem=size-1: dim as imagevars dest
if pdest=0 then dest.get_info: pdest=@dest
var x1=x+wm*size: if x1>pdest->wm then x1=pdest->wm
var y1=y+hm*size: if y1>pdest->hm then y1=pdest->hm
for iy as long=y to y1 step size
dim as ulong ptr psrc = p32 + ((iy-y)\size) * pitchBy
if pdest=0 or pdest->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 pdest->im,(ix,iy)-(ix+sizem,iy+sizem),psrc[(ix-x)\size],bf: next
endif: next
else
if pdest=0 then: put (x,y), im, pset
else: put pdest->im, (x,y), im, pset
endif: endif
End Sub
sub imagevars.aascan(yDes as long, alp as single)
if yDes < 0 or yDes > pdes->hm then exit sub
yDes1D = yDes * pdes->pitchBy
#Macro SngAry()
sR(i) += al*((src and &HFF0000)shr 16)
sG(i) += al*((src and &HFF00)shr 8)
sB(i) += al*(src and &HFF)
#endmacro
dim as single al
for xSrc as long = 0 to wm
var xDesL = int(sx): sx += x_step
var xDesR = int(sx)
var i = yDes1D + xDesL
dim as ulong src = p32[ySrc1D + xSrc]
if xDesL < xDesR then
if xDesL >= 0 and xDesL < pdes->w then
al = (xDesR - (sx-x_step)) * alp
a(i) += al
SngAry()
endif
if xDesR >= 0 and xDesR < pdes->w then
al = (sx - xDesR) * alp
i += 1: a(i) += al
SngAry()
endif
elseif xDesL >= 0 and xDesL < pdes->w then
al = x_step * alp
a(i) += al
SngAry()
endif
next
end sub
sub imagevars.downscale(byref dest as imagevars ptr, _w as single, _h as single, x as single, y as single)'2017 Aug 17
dim as imagevars scr
if dest = 0 then: pdes = @scr: scr.get_info: else: pdes = dest: endif
redim sR(pdes->ub): redim sG(pdes->ub): redim sB(pdes->ub): redim a(pdes->ub)
if _w=0 then _w=pdes->w
if _h=0 then _h=pdes->h
x_step = _w / w
y_step = _h / h
for ySrc as long = 0 to hm
sy=y
var yDesT = int(y): y += y_step
var yDesB = int(y): sx = x
ySrc1D = ySrc * pitchBy
if yDesT < yDesB then
aascan yDesT, yDesB - (y-y_step): sx = x
aascan yDesB, y - yDesB
else 'equal
aascan yDesT, y_step
endif
next: y -= y_step * h
var x0 = int(x): if x0 < 0 then x0 = 0
var x1 = int(x + _w): if x1 > pdes->wm then x1 = pdes->wm
var y0 = int(y): if y0 < 0 then y0 = 0
var y1 = int(y + _h): if y1 > pdes->hm then y1 = pdes->hm
for y as long = y0 to y1
var ipitch = y*pdes->pitchBy
for i as long = ipitch + x0 to ipitch + x1
dim as ulong col = rgb(sR(i), sG(i), sB(i))
dim as long al = a(i)*256
alpha256(pdes->p32[i], pdes->p32[i], col, al)
next
next
end sub
#Ifndef UnionARGB
Union UnionARGB
As UInteger col
Type: As UByte B,G,R,A
End Type
End Union
#EndIf
'
' --- imagevars.bas --------
type circle_vars
as unionargb col = type( rgba(rnd*255,rnd*255,rnd*255,128) )
'to store circle data for image compression (a side effect of hill climb journey)
'col - 4 bytes
'x,y,rad ushort - 6 bytes
'slope ubyte - 1 byte
as single x,y, rad=10*(.05+rnd), slope=1.5
End Type
type circle_stack
as long ub = -1
as long w,h
as single r0,g0,b0,dr,dg,db
as single diag
as circle_vars best(any), temp
declare sub new_circ
declare sub mut_col
declare sub mut_pos
declare sub mut_rad
declare sub mut_slope
declare sub nudg_r
declare sub nudg_g
declare sub nudg_b
declare sub nudg_a
declare sub nudg_pos
declare sub nudg_rad
declare sub nudg_slope
end type
sub circle_stack.new_circ: ub+=1: redim preserve best(ub)
temp=best(ub)
temp.col=type(rgba(r0+dr/2,g0+dg/2,b0+db/2,192))
mut_pos: best(ub).x=temp.x: best(ub).y=temp.y
end sub
sub circle_stack.mut_pos: temp.x=rnd*w: temp.y=rnd*h
end sub
sub circle_stack.mut_rad: temp.rad=1.5+rnd*(diag/4-1.5)
end sub
sub circle_stack.nudg_rad: temp.rad=iif(rnd<.5,temp.rad/1.061,temp.rad*1.049)
if temp.rad<.2 then temp.rad=.2
end sub
sub circle_stack.mut_col
temp.col.col = rgba(int(r0+rnd*dr), int(g0+rnd*dg), int(b0+rnd*db), 165+int(rnd*91))
end sub
sub circle_stack.mut_slope
dim as single a=piBy4+rnd*(pi/2.1-piBy4): temp.slope=sin(a)/cos(a)
end sub
sub circle_stack.nudg_r: temp.col.r+=iif(rnd<.5,1+rnd,-1-rnd)
end sub
sub circle_stack.nudg_g: temp.col.g+=iif(rnd<.5,1+rnd,-1-rnd)
end sub
sub circle_stack.nudg_b: temp.col.b+=iif(rnd<.5,1+rnd,-1-rnd)
end sub
sub circle_stack.nudg_a: temp.col.a+=iif(rnd<.5,1+rnd,-1-rnd): if temp.col.a=0 then temp.col.a=1
end sub
sub circle_stack.nudg_pos
dim as single dist=.4+rnd*3, ang=rnd*TwoPi
temp.x+=dist*cos(ang): temp.y+=dist*sin(ang)
end sub
const C_i149 as single = 1.49/255
const C_i161 as single = 1.61/255
sub circle_stack.nudg_slope
'slope range: pi/2.1 .. pi/4
const as single b=pi/2.1, isr=1/(b-piBy4)
'to range: 1 .. 0
dim as single a=(atn(temp.slope)-piBy4)*isr
a+=iif(rnd<.5,C_i149,-C_i161) 'nudge
a=(a-int(a))*(b-piBy4)+piBy4 'modulus and convert back
temp.slope=sin(a)/cos(a)
end sub
type csbuf_vars
as imagevars ptr pim
as single sca=1
as long w,h,wm,hm,c,ub
as single r0,g0,b0,dr,dg,db,avr,avg,avb,r1,g1,b1
as single diag, xsca=1,ysca=1,scale_iters=1
as single er_best, er, er_stream, er_base
as single sr(any), sg(any), sb(any)
as single vr(any), vg(any), vb(any)
as single sr0(any), sg0(any), sb0(any)
as long x0,y0,x1,y1,_wm
declare sub pic_err_v
declare sub show_v(x as short=0, y as short=0, byref des as imagevars ptr=0, w as short=-1, h as short=-1)
declare sub render_v(to_s as boolean=false, rectvars as boolean=false)
declare sub s_revert(full as boolean=false)
declare sub downscale(byref csdes as csbuf_vars ptr, byref des as imagevars ptr, _
byref src as imagevars ptr, scale as single)
declare sub transfer(byref im as imagevars ptr)
declare sub frameI
declare sub frameM(ary_pos_norm as single)
as circle_stack ptr cs
private:
as single x,y,xslo,yslo,slope
as single dy,dxLeft,distSq,cone_h,coneSq,sq,_a
as single er0, erd0, erd
as single r,g,b,a,i255=1/255
as single tr,tg,tb
as single xrad,yrad
as circle_vars ptr pcv
declare sub norm
declare sub circ_common_pre
declare sub circ_common
declare sub full_rect_vars
declare sub circ_err(byref p as circle_vars ptr)
declare sub pure_v(byref p as circle_vars ptr)
declare sub hill_climb
declare sub update_v
end type
sub csbuf_vars.show_v(x as short, y as short, byref des as imagevars ptr, _w as short, _h as short)
dim as imagevars im: if des=0 then im.get_info: des=@im
dim as ulong ptr _dst = des->pixels: _dst -= x*(x>0) + des->pitchBy*y*(y>0)
dim as long _src = x*(x<0) + w*y*(y<0)
if _w<0 then _w=w
if _h<0 then _h=h
_w-=1: _h-=1
_w = (x+_w-des->wm)*((x+_w)>des->wm)+_w-x*(x<0) ' _w and _h repurposed to clipped width and height
_h = (y+_h-des->hm)*((y+_h)>des->hm)+_h-y*(y<0)
for yy as ulong ptr = _dst to @_dst[(_h)*des->pitchBy] step des->pitchBy
dim as ulong i = _src
for xx as ulong ptr = yy to @yy[_w]
*xx=rgb( int((vr(i))*255.999), int((vg(i))*255.999), int((vb(i))*255.999))
i+=1: next: _src += w: next
sleep 1
end sub
sub csbuf_vars.norm
r0=sr(0): g0=sg(0): b0=sb(0): er=0
for i as long = 1 to ub
if sr0(i)<r0 then r0=sr0(i)
if sg0(i)<g0 then g0=sg0(i)
if sb0(i)<b0 then b0=sb0(i)
next: avr=0: avg=0: avb=0: r1=sr(0): g1=sg(0): b1=sb(0)
for i as long = 0 to ub
if sr0(i)>r1 then r1=sr0(i)
if sg0(i)>g1 then g1=sg0(i)
if sb0(i)>b1 then b1=sb0(i)
avr+=sr0(i): avg+=sg0(i): avb+=sb0(i)
next: avr/=c: avg/=c: avb/=c: dr=r1-r0: dg=g1-g0: db=b1-b0
for i as long = 0 to ub: vr(i)=avr: vg(i)=avg: vb(i)=avb
next
end sub
sub csbuf_vars.transfer(byref im as imagevars ptr)
w=im->w: wm=w-1: pim=im
h=im->h: hm=h-1: c=w*h: ub=c-1: diag=sqr(w*w+h*h)
redim sr(ub): redim sg(ub): redim sb(ub)
redim vr(ub): redim vg(ub): redim vb(ub)
redim sr0(ub): redim sg0(ub): redim sb0(ub)
for y as long = 0 to im->hm
dim as ulong ptr psrc=@im->p32[y*im->pitchBy]
dim as long yw=y*w
for i as long = yw to yw+im->wm
dim as ulong src=psrc[i-yw]
sr0(i)=((src and &HFF0000)shr 16)/255
sg0(i)=((src and &HFF00)shr 8)/255
sb0(i)=(src and &HFF)/255
next: next: norm: pic_err_v: er_base=er
end sub
sub csbuf_vars.downscale(byref csdes as csbuf_vars ptr, byref des as imagevars ptr, byref src as imagevars ptr, scale as single)
with *csdes: src->downscale des: .transfer des
.sca=.diag/diag: .xsca=.w/w: .ysca=.h/h
.scale_iters=c/.c: end with
end sub
sub csbuf_vars.pic_err_v: er=0
for iy as long = 0 to hm*w step w
for i as long =iy to iy+wm: r=vr(i)-sr0(i): g=vg(i)-sg0(i): b=vb(i)-sb0(i)
er+=r*r+g*g+b*b: next: next
end sub
#macro csbuf_mac_rectcopy(): _wm=x1-x0
for iy as long = y0*w+x0 to y1*w+x0 step w
for i as long =iy to iy+_wm
#endmacro
sub csbuf_vars.full_rect_vars: x0=0:y0=0:x1=wm:y1=hm
end sub
sub csbuf_vars.s_revert(full as boolean=false)
if full then full_rect_vars
csbuf_mac_rectcopy(): sr(i)=vr(i): sg(i)=vg(i): sb(i)=vb(i): next: next
end sub
sub csbuf_vars.circ_common_pre
x=pcv->x*xsca: xrad=pcv->rad*xsca
y=pcv->y*ysca: yrad=pcv->rad*ysca
x0=x-xrad: if x0<0 then x0=0
y0=y-yrad: if y0<0 then y0=0
x1=x+xrad: if x1>wm then x1=wm
y1=y+yrad: if y1>hm then y1=hm
end sub
sub csbuf_vars.circ_common
r=pcv->col.r*i255: g=pcv->col.g*i255: b=pcv->col.b*i255: a=pcv->col.a*i255
slope=pcv->slope/pcv->rad
cone_h=slope*pcv->rad: coneSq=cone_h*cone_h
sq=(cone_h-1)*(cone_h-1)
xslo=slope/xsca: dxLeft=(x0-x)*xslo
yslo=slope/ysca: dy=(y0-y)*yslo
end sub
sub csbuf_vars.pure_v(byref p as circle_vars ptr)
pcv=p: circ_common_pre: circ_common
for iy as long=y0*w to y1*w step w
dim as single dx=dxleft, dySq=dy*dy
for i as long=iy+x0 to iy+x1
distSq=dx*dx+dySq
if distSq<sq then
vr(i)+=a*(r-vr(i)): vg(i)+=a*(g-vg(i)): vb(i)+=a*(b-vb(i))
elseif distSq<=coneSq then
_a=(cone_h-sqr(distSq))*a
vr(i)+=_a*(r-vr(i)): vg(i)+=_a*(g-vg(i)): vb(i)+=_a*(b-vb(i))
endif: dx+=xslo
next: dy+=yslo
next
end sub
sub csbuf_vars.update_v: pure_v @cs->best(cs->ub)
end sub
sub csbuf_vars.render_v(to_s as boolean, rectvars as boolean)
for i as long=0 to ub: vr(i)=avr: vg(i)=avg: vb(i)=avb
next
for i as long=0 to cs->ub: pure_v @cs->best(i)
next: if to_s then s_revert true
if rectvars then full_rect_vars
end sub
sub csbuf_vars.circ_err(byref p as circle_vars ptr)
dim as single x,y,z
#macro mac_circ_err()
er+=tr*tr+tg*tg+tb*tb
x=vr(i)-sr0(i): y=vg(i)-sg0(i): z=vb(i)-sb0(i)
er0+=x*x+y*y+z*z
#endmacro
pcv=p: circ_common_pre: circ_common: er=0: er0=0
for iy as long=y0*w to y1*w step w
dim as single dx=dxleft, dySq=dy*dy
for i as long=iy+x0 to iy+x1
distSq=dx*dx+dySq
if distSq<sq then
sr(i)=vr(i)+a*(r-vr(i)): sg(i)=vg(i)+a*(g-vg(i)): sb(i)=vb(i)+a*(b-vb(i))
tr=sr(i)-sr0(i): tg=sg(i)-sg0(i): tb=sb(i)-sb0(i)
mac_circ_err()
elseif distSq<=coneSq then
_a=(cone_h-sqr(distSq))*a
sr(i)=vr(i)+_a*(r-vr(i)): sg(i)=vg(i)+_a*(g-vg(i)): sb(i)=vb(i)+_a*(b-vb(i))
tr=sr(i)-sr0(i): tg=sg(i)-sg0(i): tb=sb(i)-sb0(i)
mac_circ_err()
endif: dx+=xslo: next: dy+=yslo: next
end sub
sub csbuf_vars.hill_climb
if cs->temp.col.a=0 then cs->mut_col
circ_err @cs->temp: erd=er-er0
if erd<erd0 then: erd0=erd
cs->best(cs->ub)=cs->temp
else
cs->temp=cs->best(cs->ub)
endif
end sub
sub csbuf_vars.frameI
circ_err @cs->best(cs->ub): erd0=er-er0
hill_climb
'' If too high, render loop in circlestacker.mip_frame() will lag
var loops = 1450*sca
for i as long = 0 to loops
cs->nudg_rad: hill_climb
cs->mut_slope: hill_climb
cs->mut_col: hill_climb
cs->mut_pos: hill_climb
cs->nudg_r: hill_climb
cs->nudg_g: hill_climb
cs->nudg_b: hill_climb
cs->nudg_a: hill_climb
next: update_v: er_stream+=erd0
end sub
sub csbuf_vars.frameM(ary_pos as single)
circ_err @cs->best(cs->ub): erd0=er-er0
'' how often to mutate instead of nudge
const thresh=.07
'' If too high, render loop in circlestacker.mip_frame() will lag
var loops = 35.99*(ary_pos*sca+.01)
for i as long = 0 to loops
if rnd<thresh then
cs->mut_rad: hill_climb
else
cs->nudg_rad: hill_climb
endif
if rnd<thresh then
cs->mut_col: hill_climb
else
cs->nudg_r: hill_climb
cs->nudg_g: hill_climb
cs->nudg_b: hill_climb
cs->nudg_a: hill_climb
endif
if rnd<thresh then
cs->mut_pos: hill_climb
else
cs->nudg_pos: hill_climb
endif
if rnd<thresh then
cs->mut_slope: hill_climb
else
cs->nudg_slope: hill_climb
endif
next: update_v: er_stream+=erd0
end sub
type scale_proc '' borrowed from a weights-adjustment prog
as single mip = .23, mipi = .192
'as single mip = .29, mipi = .178
as long steps
declare constructor
end type
constructor.scale_proc: steps = (1-mip)/mipi
end constructor
type circlestacker
as string kstr
as scale_proc scalei
as imagevars im0,im,buf
as csbuf_vars cbv,cbv0
as circle_stack cs
as double t0
declare sub create(file as string="")
declare sub ren
declare sub mip(byref pcb as csbuf_vars ptr)
declare sub mip_frame(byref pcb as csbuf_vars ptr)
declare sub adjust(byref pcb as csbuf_vars ptr)
declare sub adjustment_frame(byref pcb as csbuf_vars ptr, c as long)
declare sub show_both(byref pcb as csbuf_vars ptr)
declare sub info_delta(byref pcb as csbuf_vars ptr)
declare sub sort_by_radius_descen
end type
Sub circlestacker.sort_by_radius_descen
Dim As Integer gap = cs.ub,i
While gap > 1 '' comb sort
For i As integer = 0 To cs.ub-gap
If cs.best(i).rad < cs.best(i+gap).rad Then Swap cs.best(i), cs.best(i+gap)
Next: gap*=10: gap\=13
wend: dim as integer hi '' insertion sort
for i as integer=1 to cs.ub: if cs.best(i).rad > cs.best(hi).rad then hi=i
next: swap cs.best(0), cs.best(hi)
For i as integer=1 To cs.ub-1
dim as integer j=i+1: if cs.best(i).rad < cs.best(j).rad then
dim as circle_vars sw=cs.best(j): j=i: while sw.rad > cs.best(j).rad
cs.best(j+1)=cs.best(j): j-=1: wend: cs.best(j+1)=sw: endif: Next
end sub
sub CircleStacker.ren: if im0.h<1 then exit sub
t0=timer: buf.get_info
for i as long = 1 to scalei.steps-0
mip @cbv: if kstr=chr(27) then exit for
next: mip @cbv0
windowtitle str((cs.ub+1)*11) & " bytes. time " & round((timer-t0)/60) & " minutes. delta: " & str(cbv0.er_best) & " .... done!"
end sub
sub CircleStacker.create(file as string)
im0.bmp_load file: if im0.h<1 then exit sub
with cbv0: .transfer @im0
cs.w=.w: cs.h=.h: cs.diag=.diag: .cs=@cs
cs.dr=.dr*255+.999: cs.dg=.dg*255+.999: cs.db=.db*255+.999
cs.r0=.r0*255: cs.g0=.g0*255: cs.b0=.b0*255
end with
end sub
sub CircleStacker.info_delta(byref pcb as csbuf_vars ptr)
dim as long x=8,y=4
if cbv0.h<buf.h/2 then: x+=cbv0.w
else: y+=cbv0.h
endif: line (x,y)-(x+200,y+10),rgb(0,0,0),bf
draw string (x,y), "stream delta " & round(pcb->er_stream*pcb->scale_iters,3)
end sub
sub CircleStacker.show_both(byref pcb as csbuf_vars ptr)
pcb->render_v
pcb->show_v
dim as long x=1,y=1
if cbv0.h<buf.h/2 then: y+=pcb->h
else: x+=pcb->w
endif: pcb->pim->blit x,y
screenlock: screenunlock
end sub
sub CircleStacker.adjust(byref pcb as csbuf_vars ptr)
pcb->er_stream=pcb->er_base
var c = cs.ub+1: cs.ub=-1: pcb->render_v
for i as long = 0 to c-1
cs.ub=i: cs.temp=cs.best(i)
pcb->FrameM (i+.5)/c
next
end sub
sub CircleStacker.adjustment_frame(byref pcb as csbuf_vars ptr, c as long)
windowtitle str(c) & " circles = " & str((cs.ub+1)*11) & " bytes. delta " & _
str(pcb->er_best*pcb->scale_iters) & " mip: " & round(pcb->sca,3) & " time: " & round((timer-t0)/60,2) & " min."
while pcb->er_stream >= pcb->er_best
info_delta pcb
adjust pcb
sleep 1
kstr=inkey: if kstr=chr(27) then exit sub
wend: pcb->er_best=pcb->er_stream
cbv0.render_v
cbv0.show_v
screenlock: screenunlock
end sub
sub CircleStacker.mip_frame(byref pcb as csbuf_vars ptr)
const search_scalar = 20
const compression = .02 '> .1 is sloww
show_both @cbv0
with *pcb: .render_v: .pic_err_v: .er_best=.er: .er_stream=.er
var c=compression * cbv0.c * .sca^.6 * 3/11 '3 bytes_pixel / 11 bytes_circle
windowtitle "generating new circles"
for i as long = cs.ub+1 to c-1
cs.new_circ: .FrameI
kstr=inkey: if kstr=chr(27) then exit sub
next: .er_best=.er_stream
cbv0.render_v
cbv0.show_v
screenlock: screenunlock
sort_by_radius_descen
for i as long = 0 to ((1-.sca)^1.5 + .00)*search_scalar
adjustment_frame pcb, c
kstr=inkey: if kstr=chr(27) then exit sub
next
end with
end sub
sub CircleStacker.mip(byref pcb as csbuf_vars ptr)
if kstr=chr(27) then exit sub
im.create roun(im0.w*scalei.mip), roun(im0.h*scalei.mip)
if abs(1-scalei.mip)>.01 then
cbv0.downscale pcb, @im, @im0, scalei.mip: pcb->cs=@cs
endif: mip_frame pcb: scalei.mip+=scalei.mipi
end sub
sub Main
dim as imagevars buf
dim as CircleStacker cs
buf.get_info: var scalar = 1 / 1.2
buf.screen_init buf.w*scalar, buf.h*scalar',,, 8 '' no border
cs.create filename
cs.ren
sleep
end sub
Main