circle stacker

Post your FreeBASIC source, examples, tips and tricks here. Please don’t post code without including an explanation.
Post Reply
dafhi
Posts: 1640
Joined: Jun 04, 2005 9:51

circle stacker

Post by dafhi »

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
Post Reply