personal project - new image format

General FreeBASIC programming questions.
Post Reply
dafhi
Posts: 1640
Joined: Jun 04, 2005 9:51

personal project - new image format

Post by dafhi »

I'm developing a new image format. It's super-savage. And lossy.

May 3 - think i got all bugs sorted out

Code: Select all

'
'  give this thing a .bmp!
'
var filename = ".bmp"

'#include "version/t.bas"
/' ------ version.bas - 2022 May 3 - by dafhi ---------------
  
  "dot stacked image" lossy format.  version-specific codez

  - development:  saved file compatibility not guaranteed
 
   - ---------
    updates
  -----------
  April
  2 - new hyper params
  
	March
  31 - tossed hyper-parameter radDetailRush
  28 - variable len header text
  27 - Stream and Base128 (namespaces) to boilerplate.bas
  18 - slow hypers for 'extreme' compression. elusive bug somewhere :\
  17 - Base128 Enc/Dec (testing)
  [update]
  renamed .hdr_fcbits_extend -> .hdr_fcbits_varied
  fixed a problem in seed_hdr.f_cseedbits() .. overall quality improved

  ==================================================
  
  --------------------
   algorithm overview
  --------------------
 
  1. anti-aliased dot with properties  x y sRGBA rad slope
  2. hash function init w/ seeds (dot_index, dna), then run once
  3. each property also runs hash.  some are eigenvectors.  see:  props_from
  4. to converge the image, compare all seeds 0 to 2^( c_seedbits: ~ 1 to 3 ) - 1
    A. before and after measurement of dot vs. image under same dot area
    B. save seed most-ish improving the render
    
  important distinctions about FreeBASIC
  1. true = -1
  2. 0.5 to int = 1
  
  some cpu architectures run about 75% slower.
  The bottleneck appears to be sRGBi.Cast.

  ==================================================
   
  ---------------
    inspiration
  ---------------
 
  The Demoscene
  Commodore Amiga
  ray (path) tracing community
  inventor Veljko Milkovic
  Advanced Micro Devices
  the free energy community
   
  ------------------
    acknowledgement
  ------------------
 
  fxm:  documentation, forum help, knowledge
  dodicat, Paul Doe, Stonemonkey:  FB friends
  badidea, dodicat, D.J. Peters:  early project comments
   
     -----------------
       dedication   
   -----------------
   
  United States welfare system
  FreeBASIC community

'/

'#include "../gfx backend.bas"
/' ------ gfx backend.bas - 2022 May 3 - by dafhi ---------------

    classes
  sRGBi - sRGB + iteration component.  weighted sRGB.
  image_downscaler - fb image container with quality downscale capability
  sRGBi_buf - weighted sRGB surface
  proc_view - image_downscaler + sRGBi_buf
  
'/

'#include "boilerplate.bas"
' ------ dsi boilerplate.bas - 2022 May 3 - by dafhi ---------------
'
#define def   #define

'' replaces int()
def flo(x) (((x)*2.0-0.5)shr 1) '' http://www.freebasic.net/forum/viewtopic.php?p=118633
def ceil(x) (-((-(x)*2.0-0.5)shr 1))

#undef int
def int     as Integer
def sng     as single
def dbl     as double
def bool    as boolean

def decl    declare
def virt    virtual
def func    function
def prop    property
def oper    operator
def csr     constructor
def ret     return
def float   single
def ac      as const


def min( a, b)        iif( (a)<(b), (a), (b) )
def max( a, b)        iif( (a)>(b), (a), (b) )

function clamp( in sng, hi sng = 1, lo sng = 0) sng
  return in + (in - hi) * (in > hi) + (in - lo) * (in < lo)
End Function

sub cpy( pdes as any ptr, psrc as any ptr, c int)
  dim as byte ptr _des = pdes, src = psrc
  fb_memcopy *_des, *src, c
End sub

function pos_val0( p as any ptr ) int
  dim as byte ptr a = p
  while *a <> 0
     a += 1
  wend
  return a - cast( byte ptr, p)
end function

const return_key = 13 '' ?
const c10 = chr(10) '' line feed?
const c34 = chr(34) '' double quote


union suspicion_suppressor   ' suspicious ptr tango
  as any ptr          a
  as ubyte ptr        b
  as ushort ptr       sho
  as ulong ptr        l
  as ulongint ptr     li
  As Single Ptr       s
  as double ptr       d
End Union


dim shared as suspicion_suppressor  gp


sub copy_bytes(des() as byte, src() as byte, lo int, hi int)
  'if lo > hi then exit sub
  fb_memcopy des(lo), src(lo), hi + 1 - lo
end sub

function sbin(p as any ptr, cBytes as longint = 1) as string
  var s = ""
  gp.a = p + cbytes - 1 '' "most-significant" first
  for j int = 1 to cBytes
    for i int = 7 to 0 step -1
      s += str((*gp.b shr i) and 1)
    next:  gp.a -= 1
  next
  return s
end function


#undef rnd '' user RNG for procedural debug / testing

function rnd ac single:  static as ulong a=1, b
  a *= a
  a xor= b
  b += 1
  return a / (culngint(1) shl 32)
end function


function round( in ac double) as string
  return str( flo( in * 8 + .5 ) \ 8)
end function

sub adjust_file_ext( byref filename as string, _extension as string = ".txt" )
  filename = left(filename, len(filename) - 4) + _extension
end sub



' --- (1 byte less in fileheader yay)
type RGB24 field = 1
  as ubyte          r,g,b
  decl oper         cast ac ulong
  decl oper         cast ac string '' 2021 Dec 30:  added
end type

oper RGB24.cast ac ulong
  return rgb(r,g,b)
end oper

oper RGB24.cast ac string
  return str(r) + " " + str(g) + " " + str(b)
end oper

 
  namespace ns_fileheader '' 2022 March 13

type infoHeader field = 1 '' byte align
  
  'as string   text '' 2022 Mar 13
  
  as ushort       wm
  as ushort       hm
  as RGB24        avgcol
  
  decl prop       w as short '' 2022 Mar 12
  decl prop       h as short
  decl prop       w( as short)
  decl prop       h( as short)
 
end type

prop infoHeader.w( param as short)
  wm = clamp(param, 65536, 1) - 1
end prop

prop infoHeader.h( param as short)
  hm = clamp(param, 65536, 1) - 1
end prop

prop infoHeader.w as short
  return wm + 1
end prop

prop infoHeader.h as short
  return hm + 1
end prop

end namespace


  namespace stream

dim as long     bitpos, pos_oob
dim as ubyte    bytes()

dim int         b_offset
dim as ulong    mask, user_pos0

function _stream_common(cbits as byte, bitpos_inc int) int '' 2022 Apr 7
  var bypos = bitpos \ 8 '' integer divide
  user_pos0 = bitpos '' record position 
  b_offset = bitpos - bypos * 8
  gp.a = @bytes(bypos)
  mask = (2 ^ cbits - 1)
  bitpos += bitpos_inc
  return bitpos > pos_oob
end function

sub write(valu as short, cbits as byte, bitpos_inc as short)
  'if _stream_common( cbits, bitpos_inc) then exit sub
  _stream_common( cbits, bitpos_inc)
  *gp.l and= -1 xor (mask shl b_offset) '' 4 byte int ptr
  *gp.l or= (valu and mask) shl b_offset
end sub

function read( cbits as byte, bitpos_inc as short) as short
  'if _stream_common( cbits, bitpos_inc) then return -1
  _stream_common( cbits, bitpos_inc)
  return (*gp.l shr b_offset) and mask
end function
  
  const   total_flagbits = 1
  const   pos_advance = 1
  const   cflag_bits = 1
  
  dim int flag_official   '' "official version"

sub flags_write
  write( flag_official, cflag_bits, pos_advance )
end sub

sub flags_read
  flag_official = read( cflag_bits, pos_advance )
end sub

end namespace ' --- stream

  
  namespace Base128

dim as string*32 q0 = "`abcdefghijklmnopqrstuvwxyz{|}~0"
dim as string*32 q1 = "@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_"
dim as string*32 q2 = "àáâãäåæçèéêëìíîïðñòóôõö÷øùúûüýþÿ"
dim as string*32 q3 = "ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖ×ØÙÚÛÜÝÞß"

dim as string * 128 r
dim as byte         ref(255)

sub _fill_ref_array
  r = q0 + q1 + q2 + q3
  for i int = 0 to 127
    ref( r[i] ) = i
  Next
End Sub

function encode( bytes() as byte ) as string
  r = q0 + q1 + q2 + q3
  
  redim stream.bytes( ubound(bytes))
  cpy @stream.bytes(0), @bytes(0), ubound(bytes)+1
  
  stream.pos_oob = (ubound(bytes)+1) * 8
  var cbits_rescaled = (stream.pos_oob \ 7) * 8
  var cbytes_rescaled = cbits_rescaled \ 8 '' integer divide
  dim as string q = space( cbytes_rescaled )

  const cbits = 7
  const pos_advance = 7
  stream.bitpos = 0
  dim int i
  while stream.bitpos < stream.pos_oob + 1 - cbits '' off by 1's  >.<
    q[i] = r[ stream.read( cbits, pos_advance ) ]
    i += 1
  wend
  return q
end function

function decode( s as string ) as string
  _fill_ref_array
  stream.pos_oob = len(s) * 7 
  redim stream.bytes( stream.pos_oob \ 8) '' integer divide
  
  const stream_cbits = 7
  const pos_advance = 7
  stream.bitpos = 0
  dim int i
  while stream.bitpos < stream.pos_oob + 1 - stream_cbits '' off by 1's  >.<
    stream.write ref( s[i]), stream_cbits, pos_advance
    i += 1
  wend
  
  dim as string q = space( ubound(stream.bytes) + 1 )
  cpy @q[0], @stream.bytes(0), len(q)
  
  return q  
end function
    
End Namespace


type v3
  sng         x, y, z
  decl        csr
  decl        csr( as ulong)
  decl        csr( as v3)
  decl        csr( as RGB24)
  decl        csr( sng, sng, sng)
  decl oper   let( as ulong)
  decl oper   cast as ulong
  decl oper   cast as string
End Type

csr v3
end csr

csr v3( rr sng, gg sng, bb sng):  x = rr: y = gg: z = bb
end csr

csr v3( col as v3)
  this = col
end csr

csr v3( col as RGB24)
  this = type(col.r,col.g,col.b)
end csr

csr v3( col as ulong)
  this = col
end csr

oper v3.let( col as ulong)
  x = (col shr 16)and 255
  y = (col shr 8)and 255
  z = col and 255
end oper

oper v3.cast as ulong
  return rgb(x, y, z)
end oper

oper v3.cast as string
  return str(x) & " " & str(y) & " " & str(z)
end oper


type Rect1 '' used by aadot_nosq.draw but placed here for debug
  int                 x0, y0, x1, y1
  decl oper           cast as string
End Type

oper Rect1.cast as string
  return str(x0) & " " & str(y0) & " " &_
    str(x1) & " " & str(y1) & " "
end oper

dim shared as Rect1          rc

  
  namespace dbg

dim int frame, calorie, cb_enc, cd_enc, cb_dot, dotsper
dim int pos, brk, mode
dim int idot, idot_brk
dim int hdr, dot

  sub p0( mesg as string = "", idbr int = -1, br int = -1, dp int = -1)
? mesg; ":  ";
if idbr> -1 then idot_brk = idbr: ? "  idot break"; idbr; " ";
if br > -1 then brk = br: ? "  break"; br; " ";
if dp > -1 then dotsper = dp: ? "  dots_per"; dp; " ";
?
End Sub

  sub p( id int = -1, po int = -1, be int = -1, de int = -1)
if po > -1 then idot = id: ? "idot"; id; " ";
if po > -1 then pos = po: ? "  pos"; pos; " ";
if be > -1 then cb_enc = be: ? "  bits_enc"; be; " ";
if de > -1 then cd_enc = de: ? "  dots_enc"; de; " ";
?
End Sub

sub q( id int = -1, hdr int = -1, dot int = -1)
if id > -1 then ? "idot"; id; " ";
if hdr > -1 then ? "hdr"; hdr; " ";
if dot > -1 then ? "dot"; dot; " ";
?
end sub

End Namespace
'
' --------  boilerplate.bas

' --- gfx backend.bas continued ..
'



Type sRGBi    '' v3 + iteration component
  as v3           sum
  sng             iter
 
  decl            csr '' constructor
 
  decl            csr( sng=0, sng=0, sng=0, sng=0)
  decl            csr( as v3, sng=1)
  decl            csr( ac ulong, sng=1)
 
  decl oper       cast ac v3        '' as const
  decl oper       Cast ac ULong       
  decl oper       cast ac string
 
  decl prop       delta_col( as ulong) as ulong
End Type

csr sRGBi
end csr

csr sRGBi( rr sng, gg sng, bb sng, i sng)
  sum.x = rr: sum.y = gg: sum.z = bb: iter = i
end csr

csr sRGBi( s ac ulong, i sng)
  this = type( type<v3>(s), i )
end csr

csr sRGBi( s as v3, i sng):  sum = s: iter = i
end csr

operator sRGBi.Cast ac v3               '' as const
  return sum / iter
end operator

operator sRGBi.Cast ac ulong
  Static sng _mul:  _mul = 1 / iter
    
    Return rgb( _
  clamp( sum.x * _mul, 255.999) -.5, _ '' 2022 Mar 3
  clamp( sum.y * _mul, 255.999) -.5, _
  clamp( sum.z * _mul, 255.999) -.5 )
End oper

operator sRGBi.Cast ac string
  return str(sum.x) + " " + str(sum.y) + " " + str(sum.z) + " " + str(iter)
end operator

prop sRGBi.delta_col(c0 as ulong) as ulong
  dim sng smul = 1 / iter
  dim as long         a=(c0 and 255) - (clamp( sum.z * smul, 255.999) -.5) '' 2022 Mar 3
  dim as long b=a*a:  a=((c0 shr 8)and 255) - (clamp( sum.y * smul, 255.999) -.5)
  b += a*a:             a=((c0 shr 16)and 255) - (clamp( sum.x * smul, 255.999) -.5)
  return sqr(b+a*a) '' 2022 Mar 4 [added sqr]
end prop



type image_downscaler
 
'  decl                  csr( as any ptr ) '' constructor
  declare               destructor
'  decl oper             cast as any ptr
  declare sub           acquire( as any ptr )    '' example:  acquire imagecreate(400, 300)
  declare sub           scan( as any ptr = 0 )    '' example:  scan imagecreate(400, 300)
  declare sub           create(w int=0, h int=0, col as ulong=&HFF000000)
  declare sub           bmp_load( ByRef filename As String )
  declare sub           blit(x int=0, y int=0, size as ubyte=0, byref pdest as any ptr=0)
 
  int                   w,h,bpp,bypp,pitch,rate '' fb standard
  as any ptr            im, pixels
  as string             driver_name
 
  sng                   wh, hh, diagonal        '' specialized
  int                   wm, hm, u, pitchBy
  as ulong ptr          p32
  as string             text
  decl sub              release
  declare sub         downscale(byref as image_downscaler ptr, w sng=0, h sng=0, x sng=0, y sng=0, as string = "")
  decl sub            downscale_from(byref as image_downscaler ptr, sng)
  decl prop           avg_col as RGB24
 
 private:

  declare sub         aascan(yDes as long, alp sng)
  as image_downscaler ptr    pdes            ' aablit
  as long             yDes1D, ySrc1D  '
  sng                 sx, x_step      '
  sng                 sy, y_step      '
  as sRGBi            a(any)
  decl sub              _specialized
end type

'csr image_downscaler( im as any ptr):  if imageinfo(im) then exit csr
'  acquire im
'end csr

Destructor.image_downscaler
'  ? "dsr "; text: sleep 100
:  release
End Destructor

sub image_downscaler.release
  if im<>0 then imagedestroy im: im=0 '' 2022 April 2
'  If ImageInfo(im) = 0 Then ImageDestroy im:  im=0
End Sub

'oper image_downscaler.cast as any ptr
'  return im
'end oper

sub image_downscaler._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 image_downscaler.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
    'release
  elseif Imageinfo(_im) = 0 then
    ImageInfo _im, w, h, bypp, pitch, pixels: _
    bpp = bypp * 8:  _specialized
    'im = 0 '' avoids imagedestroy
  endif
end sub

sub image_downscaler.acquire( _im as any ptr) '' 2022 Mar 15
  'if dbg.oob = 1 then ?_im, screenptr; " ": sleep
  if (_im = 0) orelse (_im = screenptr) then
    release:  ScreenInfo w,h, bpp, bypp, pitch, rate, driver_name
    pixels = screenptr:  im = 0:  _specialized
  elseif Imageinfo(_im) = 0 then
    
    #if 0
    'if dbg.oob = 1 then ?im,_im,w,h; " ": sleep
    if dbg.oob = 1 then
      ?_im,im,screenptr,w,h; " "
      imageinfo im, w,h
      ? ImageInfo(im),w,h; " ": imagedestroy im: sleep
    endif
    #endif
    
    release
    'if dbg.oob = 1 then ?ImageInfo(im),w,h; " ": sleep
    im = _im
    ImageInfo im, w, h, bypp, pitch, pixels:
    bpp = bypp * 8:  _specialized
  endif
end sub

sub image_downscaler.create( w int, h int, col as ulong)
  w = abs(w) '' 2022 Apr 2
  h = abs(h)
  if w<1 or h<1 then exit sub
  acquire imagecreate(w,h,col) '' 2022 Mar 15
  'if dbg.oob = 1 then ?w, h; " ": sleep
End Sub

sub image_downscaler.blit( x int, y int, size as ubyte, byref pdest as any ptr) '2022 Mar 16

  if size > 1 then
    
    static as image_downscaler vdes
'    vdes.text = ".blit"
    
    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 image_downscaler.bmp_load( filename As String )  'modified official fb sample
  Dim As Long filenum = FreeFile()
  dim as long _w, _h '' 2021 Dec 19
  for i int = 1 to 2
    If Open( filename For Binary Access Read As #filenum ) = 0 Then
      Get #filenum, 19, _w
      Get #filenum, 23, _h
      close #filenum
      create _w, _h
      bload filename, im
      exit for
    endif
    Close #filenum
    filename = exepath & "\" & filename
  next
End sub

sub image_downscaler.downscale_from( byref src as image_downscaler ptr, scale sng)
  create src->w*scale, src->h*scale
  src->downscale @this
end sub

sub image_downscaler.aascan(yDes as long, alp sng)
  if yDes < 0 or yDes > pdes->hm then exit sub
  yDes1D = yDes * pdes->pitchBy
  #Macro SngAry()
    a(i).sum.x += al*((src and &HFF0000)shr 16)
    a(i).sum.y += al*((src and &HFF00)shr 8)
    a(i).sum.z += al*(src and &HFF)
  #endmacro
  dim sng al
  for xSrc int = 0 to wm
    var xDesL = flo(sx):  sx += x_step
    var xDesR = flo(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).iter += al
        SngAry()
      endif
      if xDesR >= 0 and xDesR < pdes->w then
        al = (sx - xDesR) * alp
        i += 1:  a(i).iter += al
        SngAry()
      endif
    elseif xDesL >= 0 and xDesL < pdes->w then
      al = x_step * alp
      a(i).iter += al
      SngAry()
    endif
  next
end sub

sub image_downscaler.downscale(byref dest as image_downscaler ptr, _w sng, _h sng, x sng, y sng, dbg_text as string)'2017 Aug 17
  
  static as image_downscaler  scr
  
  if dest = 0 then
    pdes = @scr
    scr.scan    '' screen ptr
    ? "screen downscaled?": sleep 1500
  else
    pdes = dest
    'scr.text = "scr"
  endif
  
  'pdes->text = dbg_text + " downscaled"
 
  redim a(pdes->h * pdes->pitchBy - 1)

  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 = flo(y):  y += y_step
    var yDesB = flo(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 = iif( x < 0, 0, flo(x))
  var x1 = flo(x + _w): if x1 > pdes->wm then x1 = pdes->wm
  var y0 = iif( y < 0, 0, flo(y))
  var y1 = flo(y + _h): if y1 > pdes->hm then y1 = pdes->hm
 
  for y int = y0 to y1
    var ipitch = y*pdes->pitchBy
    for i int = ipitch + x0 to ipitch + x1
      pdes->p32[i] = a(i)
    next
  next
  erase a
end sub

prop image_downscaler.avg_col as RGB24
  var r = 0ul, g = 0ul, b = 0ul
  var c = w * h
  for y int = 0 to hm*pitchBy step pitchBy
    for i int = y to y + wm
      r += (p32[i] shr 16) and &HFF
      g += (p32[i] shr 8) and &HFF
      b += p32[i] and &HFF
    next:  next
  return type( r/c, g/c, b/c )
end prop
 


operator -( l ac v3, r ac v3) as v3:  return type( l.x-r.x, l.y-r.y, l.z-r.z):  end oper
operator -( l ac v3, r ac single) as v3:  return type( l.x-r, l.y-r, l.z-r):  end oper '' 2022 April 18
operator +( l ac v3, r ac v3) as v3:  return type( l.x+r.x, l.y+r.y, l.z+r.z):  end oper
operator *( l ac v3, r ac single) as v3:  return type<v3>( r*l.x, r*l.y, r*l.z):  end oper
operator *( l ac single, r ac v3) as v3:  return type<v3>( l*r.x, l*r.y, l*r.z):  end oper
operator /( l ac v3, r sng) as v3:  r=1/r: return type( r*l.x, r*l.y, r*l.z):  end oper
operator -( l ac v3) ac v3:  return type( -l.x, -l.y, -l.z):  end oper


oper +( l ac sRGBi, r ac sRGBi) ac sRGBi:  return type<sRGBi>( l.sum+r.sum,  l.iter+r.iter):  end oper
oper -( l ac sRGBi, r ac sRGBi) ac sRGBi:  return type<sRGBi>( l.sum-r.sum,  l.iter-r.iter):  end oper


enum fill_mode
  solid
  image
  add
end enum


type sRGBi_buf
  decl prop         w int
  decl prop         h int
  decl prop         wm int
  decl prop         hm int
 
  decl sub          resize( int, int)
  decl sub          fill( byval as v3 = type(0,0,0), sng = 1, int = 0,  byref as image_downscaler ptr = 0)
  decl sub          _view( int=0, int=0, byref as image_downscaler ptr)
 
  as sRGBi          mydata(any, any) '' 2022 Jan 2 [old: data(any, any)
 
 private:
  decl sub          clip_calc( as image_downscaler ptr, int, int, byref as Rect1 ptr)
  int               clip_x0
  int               clip_y0
End Type

prop sRGBi_buf.w int:  return ubound(mydata,1)+1
end prop
prop sRGBi_buf.h int:  return ubound(mydata,2)+1
end prop
prop sRGBi_buf.wm int:  return ubound(mydata,1)
end prop
prop sRGBi_buf.hm int:  return ubound(mydata,2)
end prop

sub sRGBi_buf.resize( ww int, hh int)
  redim mydata( ww-1, hh-1)
End Sub

sub sRGBi_buf.clip_calc( p as image_downscaler ptr, x int, y int, byref prc as Rect1 ptr)
  clip_x0 = -x * (x<0): prc->x0 = x + clip_x0
  clip_y0 = -y * (y<0): prc->y0 = y + clip_y0
  prc->x1 = x + wm: prc->x1 += (prc->x1 - p->wm) * (prc->x1 > p->wm)
  prc->y1 = y + hm: prc->y1 += (prc->y1 - p->hm) * (prc->y1 > p->hm)
end sub

sub sRGBi_buf.fill( byval _col as v3, stren sng, mode int,  byref p_imvsrc as image_downscaler ptr )
 
  if hm < 1 then exit sub '' 2022 Mar 4
  
  select case ac mode '' as const
 
  case fill_mode.solid
    var col = type<sRGBi>(_col * stren, stren)
    
    for p as sRGBi ptr = @mydata(0,0) to @mydata(wm, hm)
      *p = col
    next
 
  case fill_mode.add
    for p as sRGBi ptr = @mydata(0,0) to @mydata(wm, hm)
      p->sum += _col
    next
 
  case fill_mode.image
    static as Rect1 rc_src
   
    clip_calc p_imvsrc, 0, 0, @rc_src
   
    for y int = rc_src.y0 to rc_src.y1
      var p32 = p_imvsrc->p32 + y * p_imvsrc->pitchBy
     
      for x int = rc_src.x0 to rc_src.x1
        mydata(x, y).sum = type<v3>( p32[x] ) * stren
        mydata(x, y).iter = stren
        Next:  Next
       
  end select
end sub

sub sRGBi_buf._view( x int, y int, byref des as image_downscaler ptr)' im as any ptr)
'  static as image_downscaler des
'  des.text = "static imvars des: sRGBi_buf.view" '' debugger
 
'  des.scan im '' metrics w/o destroy
  if des->w <> w orelse des->h <> h then des->create w, h
  static as rect1 rc

'  ? des.im, des.wm: sleep 500
  clip_calc des, x, y, @rc '' rc is a global general purpose rect1
  
  clip_x0 -= rc.x0 '' 2022 Mar 15
  clip_y0 -= rc.y0

  for y = rc.y0 to rc.y1
    'if y < 1 or y >= hm then ? y
    for x = rc.x0 to rc.x1
      des->p32[y * des->pitchBy + x] = mydata(x + clip_x0, y + clip_y0)
        next: next
       
end sub


'' helper
dim shared as ubyte                    magnification = 1

type proc_view
  as image_downscaler  src
  as sRGBi_buf      sbuf
  decl prop         w ac integer
  decl prop         h ac integer
  decl prop         cPels ac ulongint
  decl prop         get_err as double
  decl sub          work_scale( as image_downscaler ptr, sng)
End Type

prop proc_view.cPels ac ulongint
  return w * h
end prop

prop proc_view.w ac integer
  return src.w
end prop

prop proc_view.h ac integer
  return src.h
end prop

prop proc_view.get_err as double
  dim as double sum
  for y int = 0 to src.hm
    for x int = 0 to src.wm
      sum += sbuf.mydata(x,y).delta_col( src.p32[x + y*src.pitchBy] )
    next: next:  return sum / cpels
end prop

sub proc_view.work_scale( psrc as image_downscaler ptr, scale sng)
  src.downscale_from psrc, scale
'  src.text = "member src: procview.work_scale"
  'if dbg.oob = 1 then ? rnd; " ": sleep
  sbuf.resize src.w, src.h
End Sub


function hsv(h sng, s sng, v sng) as v3
   h -= 6*flo(h/6)
   var x = clamp(2 - h - 2*(h-3)*(h>3))
   var y = clamp(h +     2*(h-2)*(h>2))
   var z = clamp(h - 2 + 2*(h-4)*(h>4))
   var lo=@x, mi=@y, hi=@z
   if *lo > *hi then swap lo, hi
   if *lo > *mi then swap lo, mi
   if *mi > *hi then swap mi, hi
   s = clamp(s)
   v = clamp(v)
   *lo = v * (*hi - s * (*hi - *lo))
   *mi = v * (*hi - s * (*hi - *mi))
   *hi *= v
   return type( x, y, z )
End Function
'
' ------- gfx backend.bas

 
  namespace dsi_hash '' RNG

type statelit as ulong

dim as statelit a, b

dim as ulongint mulC = &b10000000001000000001000000010000001000001000010001001011

const lenx8 = len(statelit)*8

sub rotr(byref q as statelit, amount as byte)
  q = (q shl (lenx8 - amount)) or (q shr amount)
End Sub

sub reset( val_a as statelit = 0, val_b as statelit = 0)
  a = val_a
  b = val_b
end sub

function valu( i as ulongint = 0) as statelit '' integer
  
  '' 2022 Apr 7 .. note to self:  should match ns_compat._valu
  
  #if 1
  b += ((a+i) * mulc) shr 1
  rotr b, 16
  a xor= 1 + b
  #elseif 1
  b xor= 1 + a + i
  a += (mulC * b)shr 1
  #else
  b += (mulC*a)shr 1
  a xor= 1 + b + i
  #endif
  
  return a
End function

function d( i as ulongint = 0) ac double      '' as const
  return valu(i) / cast(statelit, -1)
end function

function ini( i as ulongint = 0, val_a as statelit = 0, val_b as statelit = 0) as statelit
  reset val_a, val_b
  return valu(i)
End function

End Namespace ' -- dsi_hash --

  
  namespace ns_ECS '' entity component system

type nBitHashFloat
  decl            csr (sng = 1, sng = 0)
  decl oper       cast ac single  '' ac my shorthand for 'as const'
  decl oper       cast ac string
  decl oper       let( ac double)

  decl sub        run(as dsi_hash.statelit = 0)
  sng             _sval
  sng             _sngmax
  sng             _sngmin
end type

csr nBitHashFloat( sngmax sng, sngmin sng)
  _sngmin = sngmin
  _sngmax = sngmax
end csr

sub nBitHashFloat.run(seed as dsi_hash.statelit) '' 2022 Mar 2 - renamed _add to seed
  _sval = _sngmin + dsi_hash.d(seed) * (_sngmax - _sngmin) '' hash range 0.0 .. 1.0 inclusive
end sub

oper nBitHashFloat.cast ac single
  return _sval
end oper

oper nBitHashFloat.cast ac string:  static sng q
  q = this:  return str(q)
end oper

oper nBitHashFloat.let( d ac double)
  _sval = d
end oper


type t
 
  decl oper           cast ac string     '' debug info
 
  decl sub            ini_( int = 0, as dsi_hash.statelit = 0, as dsi_hash.statelit = 0)

  as nBitHashFloat    style = type(0.56, 0)
  as nBitHashFloat    slope = type(1, .501)
  as nBitHashFloat    rad = type(1, 0)
  as nBitHashFloat    x = type(1, 0)
  as nBitHashFloat    y = type(1, 0)
  as nBitHashFloat    r = type(6, 0) '' hue sat val :p
  as nBitHashFloat    g = type(1, 0)
  as nBitHashFloat    b = type(1, 0)
  as nBitHashFloat    a = type(1.6, 0.7) '' 
 
  decl prop           full ac ulong
 
  dbl                 bitpos_s, bitpos_delta
  int                 maxinc_frame
 
End Type

sub t.ini_( idx int = 0, seeda as dsi_hash.statelit = 0, seedb as dsi_hash.statelit = 0)
  dsi_hash.ini idx, seeda, seedb
end sub

oper t.cast ac string:  static as string s
  s = "xy " + str(x) + " " + str(y) + " " + c10 + _
   "rad "+ str(rad) + " " + c10 + _
   "r "+ str(r) + " " + c10 + _
   "g "+ str(g) + " " + c10 + _
   "b "+ str(b) + " " + c10 + _
   "a "+ str(a) + " " + c10 + _
   "sl "+ str(slope) + " "
   return s
end oper
 
end namespace


 /' -- anti-aliased rendering primitive -- '/

  namespace AaDot_noSq '' not using sqr

dim as sRGBi_buf ptr  pTarget
dim sng               clip_sx1, clip_sy1

sub render_target( byref pTarg as sRGBi_buf ptr)
  pTarget = pTarg
end sub

dim sng cone_h, cone_sq, dxLeft, loptop, loptopSq

sub xy01_( byref pdv as ns_ecs.t ptr)
  clip_sx1 = pTarget->w - .5001 '' moved from render_target
  clip_sy1 = pTarget->h - .5001
  pdv->rad *= -(pdv->rad > .7) '' if rad < thresh., proc it zero
  with rc
    .x0 = (pdv->x - pdv->rad):  .X0 = flo(.x0 + .x0 * (.x0 < 0))  '' nicer on cpu than [if x < 0 then x = 0]
    .y0 = (pdv->y - pdv->rad):  .Y0 = flo(.y0 + .y0 * (.y0 < 0))
    .x1 = (pdv->x + pdv->rad):  .X1 = flo(.x1 + (.x1 - clip_sx1) * (.x1 > clip_sx1))
    .y1 = (pdv->y + pdv->rad):  .Y1 = flo(.y1 + (.y1 - clip_sy1) * (.y1 > clip_sy1))
    cone_h = pdv->slope * (pdv->rad + .0)  ''
    cone_Sq = cone_h * cone_h
    loptop = cone_h - 1
    loptopSq = loptop * loptop
    dxLeft = (.X0 + .0 - pdv->x) * pdv->slope
  end with
End Sub

dim sng dx, dy, coneSq_minus_dySq

dim int circ_err_final_cplx

function circ_err( byref pv as proc_view ptr, byref p as ns_ecs.t ptr ) dbl
  dim dbl sum
  dy = (rc.Y0 + .0 - p->y) * p->slope
  var cPels = 0
  for y int = rc.Y0 to rc.Y1
    dx = dxleft
    coneSq_minus_dySq = cone_Sq - dy*dy
    for x int = rc.X0 to rc.X1
      if dx * dx < coneSq_minus_dySq then
        sum += pv->sbuf.mydata(x,y).delta_col( pv->src.p32[x + y*pv->src.pitchBy] )
        cpels += 1
      endif
      dx += p->slope:  next
    dy += p->slope:  next
  
  return iif(circ_err_final_cplx, (sum+.5) / (cPels+.5) ^ .1, sum)
end function

enum dot_style
  gradient
  flat
End Enum


sub _render( byref p as ns_ecs.t ptr, byval col as sRGBi)

  '' xy01_ meant to be called prior
 
  dy = (rc.Y0 + .0 - p->y) * p->slope
 
  static sng reciprocal_alpha: reciprocal_alpha = 1 / (cone_Sq - loptopSq)
  static sng a

  col.sum *= col.iter
  dim int j = p->style

  select case ac j '' ac = as const
  
  case dot_style.gradient
    for y int = rc.Y0 to rc.Y1
      dx = dxleft
      coneSq_minus_dySq = cone_Sq - dy*dy
      for x int = rc.X0 to rc.X1
        a = dx * dx
        a = (coneSq_minus_dySq - a) * reciprocal_alpha * -(a < coneSq_minus_dySq)
        pTarget->mydata(x, y).iter += col.iter * a  '' adjusting properties seperately ..
        pTarget->mydata(x, y).sum += col.sum * a    '' .. my OOP not working as expected
        dx += p->slope:  next
      dy += p->slope:  next
  
  case dot_style.flat
  
    for y int = rc.Y0 to rc.Y1
      dx = dxleft
      coneSq_minus_dySq = cone_Sq - dy*dy
      for x int = rc.X0 to rc.X1
        if dx * dx < coneSq_minus_dySq then
          ptarget->mydata(x, y) += col
        endif
        dx += p->slope:  next
      dy += p->slope:  next
  end select
 
end sub

sub draw( x as single, y as single, col as sRGBi, rad sng = .7071, slope sng = 1)
  static as ns_ecs.t   dv
  dv.x = x
  dv.y = y
  dv.rad = rad
  dv.slope = slope
  xy01_ @dv
  _render @dv, col
end sub

end namespace


/' 
  Hyperparameters are code-specific and not saved to encoded image.
  Only the udt.text (below) is saved.
'/
type t_hyper_parameters field = 1 '' 8 bit align
  sng       radScale0
  sng       radDecay
  sng       radDetailRush
  sng       expon_dotsper
  as byte   min_dotsper
  as byte   hdr_cbits
  as byte   dot_cbits_base
  as byte   dot_cbits_varied
  as string text
End Type

oper = (l as t_hyper_parameters, r as t_hyper_parameters) int
  dim as any ptr pal = @l, par = @r
  dim as byte ptr pbl = pal, pbr = par
  
  static int diff
  for i int = 0 to len(t_hyper_parameters)-1
    diff += abs(pbl[i] - pbr[i])
  next
  
  diff += abs( len(l.text) - len(r.text) )
  for i int = 0 to min(len(l.text), len(r.text)) - 1
    diff += abs( l.text[i] - r.text[i] )
  next
  
  return diff = 0
end oper


  namespace seed_hdr
  
dim as short    _max

sub _setmax( hdr_cbits int)
  _max = 2 ^ hdr_cbits - 1', 3) '' keeps speed reasonable when hyper_parameters dot_fcbits_base > 3
End Sub

end namespace


type tracking_vars
  decl csr      (byref as t_hyper_parameters ptr = 0)
  as short      hdr_val
  as short      dot_dna
  int           idot
  int           bits_encoded
  int           dots_encoded
  dbl           bene
  
  as t_hyper_parameters ptr _
    p_hypers
end type

csr tracking_vars(byref p as t_hyper_parameters ptr)
  p_hypers = p
end csr


  
  namespace ns_compat

/' -- "official" detection --
 
    intent:
  1. group hyperparameters
  2. coder notification
  
  if work_branch & master don't match, "official" flag will be set to 0.

'/

  
  function master as t_hyper_parameters ptr
    static as t_hyper_parameters hypers

/'
  -- Do you mean to adjust work_branch?
  -- You probably do.
 
  saved file generated from work_branch
'/

  hypers.radScale0 = .067 '' these are not nearly ideal.  for testing.
  hypers.radDecay = .99935

  hypers.hdr_cbits = 2
  hypers.dot_cbits_base = 5
  hypers.dot_cbits_varied = hypers.hdr_cbits < 4

  hypers.min_dotsper = 20
  hypers.expon_dotsper = .4

/'
  -- Do you mean to adjust work_branch?
  -- You probably do.
'/

hypers.text = "dsi v00.0 - pygmi - we're live! "

return @hypers

End function

  
  function work_branch() as t_hyper_parameters ptr
    
    static as t_hyper_parameters  hypers

  aadot_nosq.circ_err_final_cplx = 0  '' experimental.
                                      '' may become t_hyper_parameters member


/' -- work_branch is intended for experimentation '/
  
  #if 0
  #else
  
    #if 1
    hypers.radScale0 = 0.11
    hypers.radDecay = .72 ''9987
    hypers.radDetailRush = (hypers.radDecay * .28) ^ .8
    #else
    hypers.radScale0 = 0.046
    hypers.radDecay = .99962
    #endif
    
    hypers.hdr_cbits = 3
    hypers.dot_cbits_base = 0

    hypers.min_dotsper = hypers.hdr_cbits * 1.8
    hypers.expon_dotsper = 1.1
    
  #endif
  
  hypers.dot_cbits_varied = 1'hypers.hdr_cbits < 4 '' 2 ^ hdr_cbits = dot combinations.  greater than 3 for hdr_cbits is too slow
  
  '' for official format release,
  '' master() must match work_branch()

  hypers.text = "dsi v00.0 - testing .."

  return @hypers
  
End function

dim as dsi_hash.statelit a, b /' -- expected hash algorithm -- '/

dim as ulongint mulC = &b10000000001000000001000000010000001000001000010001001011


sub rotr(byref q as dsi_hash.statelit, amount as byte)
  q = (q shl (dsi_hash.lenx8 - amount)) or (q shr amount)
End Sub

function _valu( i as ulongint = 0) as dsi_hash.statelit '' integer
  
  '' 2022 Apr 7 - (note to self:  match dsi_hash.valu algo
  #if 1
    b += ((a+i) * mulc) shr 1
    rotr b, 16
    a xor= 1 + b
  #elseif 1
    b xor= 1 + a + i
    a += (mulC * b)shr 1
  #else
    b += (mulC*a)shr 1
    a xor= 1 + b + i
  #endif
  
  return a

End function

function _ini( i as ulongint = 0, val_a as dsi_hash.statelit = 0, val_b as dsi_hash.statelit = 0) as dsi_hash.statelit
  a = val_a
  b = val_b
  return _valu(i)
End function
' -----------------

function _RNGs_equal int
  for i int = 0 to 1
    var a = rnd * culng(-1)
    var b = rnd * culng(-1)
    if _ini(i, a, b) <> dsi_hash.ini(i, a, b) then return false
  next
  return true
End Function

sub compute__flag_official
  stream.flag_official = _RNGs_equal and (*master = *work_branch)
End Sub

const as string q_flag0 = "stream flag:  0 - unofficial"

end namespace

  
'
'
  namespace dsi_imager

dim as ns_fileheader.infoHeader _
  infoHeader

dim int         c_dotbits
dim int         c_hdrbits '' "virtual" vars allow zero for hdr and dot cbits simultaneously.

dim int         pos_break_absolute, idot_break

dim int         dots_per, frame

dim int         dprint    '' debugger

sub _cbits_min_req( byref p as tracking_vars ptr)
  if p->p_hypers->hdr_cbits = 0 andalso p->p_hypers->dot_cbits_base = 0 then
    c_hdrbits = 1
    c_dotbits = 0
  else
    var varied = p->p_hypers->dot_cbits_varied <> 0 '' FreeBASIC True = -1
    c_dotbits = p->p_hypers->dot_cbits_base - (p->hdr_val and 7)* varied
    c_hdrbits = p->p_hypers->hdr_cbits
  endif
  pos_break_absolute = stream.pos_oob + min(0, 1 - c_dotbits) '' off-by-2 gives _decode_chunk() a chance to proc
end sub

sub _breaks( byref p as tracking_vars ptr)
  
  var a = max( p->p_hypers->min_dotsper, 1)
  var b = frame ^ p->p_hypers->expon_dotsper
  dots_per = max( a, b)
  idot_break = p->idot + dots_per
  _cbits_min_req p
  
End Sub

sub _cdotbits_calcs( byref p as tracking_vars ptr)
  
  var pos_increment = c_hdrbits
  p->hdr_val = stream.read( c_hdrbits, pos_increment )
  
'  if dprint then ? " _cdotbits_calcs: hdr_val"; p->hdr_val; " "
  'if hdr_val < 0 then exit sub '' debugger
  _breaks p
end sub


dim as image_downscaler   imv_source
dim as image_downscaler   imv_mid

dim as proc_view          procview

dim as byte               dna_best()


sub _sbuf_show( message as string = "")
  dim int blit_x, blit_y, pel_size
  
  dim int scr_w, scr_h
  screeninfo scr_w, scr_h
  
  if message = "" then
    'line(0,0)-(scr_w,scr_h),rgb(99,88,77), bf '' cls
    pel_size = 1
  else
    pel_size = 8
    blit_x = (scr_w - pel_size*procview.w) / 2
    blit_y = (scr_h - pel_size*procview.h) / 2
  EndIf

  static as image_downscaler src '' big pixel option
  procview.sbuf._view 0,0, @src
  src.blit blit_x, blit_y, pel_size
  screenlock: screenunlock
'  ? procview.src.w, procview.src.h, pel_size; rnd; " "
end sub



sub _sbuf_solidfill
  var             stren = 1.0
  procview.sbuf.fill infoHeader.avgcol, stren, fill_mode.solid'
end sub
 
dim as ns_ecs.t   hashed_props

dim as v3         sCOL


sub _drawdot(dot_idx int, draw_vs_erase int)
  aadot_nosq._render @hashed_props, _
    type<sRGBi>( _
      sCOL, _
      hashed_props.a * draw_vs_erase )
end sub

dim sng                 gRadMul


sub _props_from( byref p as tracking_vars ptr)
  
  with hashed_props
      
      .style._sngmin = .46 '' flat vs gradient
      .style._sngmax = .99 '' .5 and greater gives flat a chance
    
      .ini_ p->idot, p->hdr_val, p->dot_dna '' seed & 1x hash run
/'  if dprint then '? " props_from: p->idot"; p->idot; " "
    dbg.q p->idot, hdr_val, p->dot_dna
  endif'/
     
      .y.run
      .x.run
              
      '' eigenvectors.  most significant last (?) - 2022 Mar 18
      '
      .style.run p->dot_dna
      .rad.run p->dot_dna
      .b.run p->dot_dna      '' value (hsv)
      .g.run p->dot_dna      '' saturation
      .r.run p->dot_dna      '' hue
      .slope.run p->dot_dna
      .a.run p->dot_dna
      
      '' final adjustments
      #if 0
        .rad = max( _
          .0, _
          gRadMul * (.08 + .92 * .rad) * p->p_hypers->radDecay ^ (p->idot))' ^ p->p_hypers->radDetailRush)
      #else
          .rad = max( .0, _
        gRadMul * (.35 + .65 * .rad) * p->p_hypers->radDecay ^ (p->idot ^ p->p_hypers->radDetailRush) )
      #endif
      
      .x *= procview.src.w
      .y *= procview.src.h
      .slope /= .rad
      
      '.style = 0
     
      sCOL = (hsv(.r, .g, .b) * 1.02 - .01)  * (256 * 1.0) '' 2022 April 18
'      sCOL = hsv(.r, .g, .b) * (256 * 1.6)
  
  end with

  aadot_nosq.xy01_ @hashed_props
  
end sub

dim as tracking_vars    progress


sub _workbuf_size( scalar sng )
  'if dbg.oob = 1 then ? rnd; " ": sleep
  procview.work_scale @imv_mid, scalar
  'procview.src.text = "wbuf size" '' debugger.  message appears at image_downscaler dextructor
  aadot_nosq.render_target @procview.sbuf
  gRadMul = progress.p_hypers->radScale0 * procview.src.diagonal
  'if dbg.oob = 1 then ? rnd; " ": sleep
end sub

dim dbl       t, tTriggerF


sub _bmpload_and_downscale( filename as string, scale_amount sng = 0.4 )
  imv_source.bmp_load filename
  'imv_source.text = "imv_source: _bmpload_and_.."
  static int display_err_message = true

  ' ---- setup -----------
  if imv_source.h < 1 then
    if display_err_message then ? ".bmp load error": sleep 1200: display_err_message = false
    exit sub
  EndIf
  'procview.src.text = "pv src"
  imv_mid.downscale_from @imv_source, scale_amount
  'imv_mid.text = "imv_mid: _bmpload_and.."
  infoHeader.avgcol = imv_mid.avg_col
  infoHeader.wm = imv_source.wm
  infoHeader.hm = imv_source.hm
  progress.p_hypers = ns_compat.work_branch
  ns_compat.compute__flag_official
  if stream.flag_official = false then locate 70,2: ? ns_compat.q_flag0
  t = timer:  tTriggerF = t - 10
end sub

const drawmode_draw = 1
const drawmode_erase = -1

/'
pick best dot group ( before & after measurement )
group loop: 0 to 2^c_hdrbits - 1
dot loop: 0 to 2^c_dotbits - 1
pick best dot ( also a before & after measurement )

'/

sub _decode_dot( byref p as tracking_vars ptr, _erase int = false)
  var advance_amount = c_dotbits
  p->dot_dna = stream.read( c_dotbits, advance_amount)
  'if dprint then ? p->dot_dna;
'  if dprint then ? " _decode_dot: dot_dna"; p->dot_dna; " "
  _props_from p
  _drawdot p->idot, iif( _erase, drawmode_erase, drawmode_draw)
end sub


sub _decode_dot_group( byref p as tracking_vars ptr, bool_erase int = false)
  
  'dprint = (stream.bitpos > 0) and (dbg.mode > 0) '' debugger
  
  _cdotbits_calcs p
  
  '
  if dprint then
    ? " decode dot group: ";
    ? "hdr, c_dbits, frame ", p->hdr_val; c_dotbits; frame
    '? " pos, idot, hdr, dot(s), dot_br"; p->hdr_val; stream.bitpos; p->idot; idot_break; pos_break_absolute
    ? "pos, idot";
  endif
  '/
  
  while stream.bitpos < pos_break_absolute andalso p->idot < idot_break
    p->idot += 1 '' increment ahead b/c initialized to -1
    if dprint then ? stream.bitpos; p->idot; " ";
    _decode_dot p, bool_erase
  wend
  if dprint then ? " "
'  if dprint then sleep
end sub
 

sub _decode(pos0 int = -1, pos1 int = -1, idot int = -1, bool_erase int = false)

  if procview.h < 1 then exit sub
  if pos1 < 0 then frame = 0

  stream.bitpos = max( stream.total_flagbits, pos0 ) '' FreeBASIC true = -1
  pos1 = iif(pos1 > 0, pos1, progress.bits_encoded)
  
  progress.idot = idot '' default: -1.  i think my reasoning was mental visualization
  'if dprint then ? " _decode:"' pos0, pos1"; stream.bitpos, pos1; " "
  while stream.bitpos < pos1
    _decode_dot_group @progress, bool_erase
    'if dprint then ? stream.bitpos, progress.hdr_val
    frame += 1
  wend

end sub

function _pixellate_decode( diagonal sng = 0, message as string = "") int
  if imv_source.h < 1 then exit function
  
  dim sng scale = _
    iif(diagonal > 0, diagonal / imv_source.diagonal, 1)

  _workbuf_size scale

  _sbuf_solidfill
  
  _decode
  
  _sbuf_show message

  if message = "" then
    return false
  else
    ? message
    var s = getkey
    return iif( lcase(chr(s)) = "y" or (s = return_key), true, false )
  EndIf
  
end function

dim int _fresh_from_the_oven


sub decode

  if _fresh_from_the_oven then
  else
    if not _pixellate_decode( 22, "continue?") then exit sub
    if not _pixellate_decode( 28, "how about now?") then exit sub
  EndIf
  
  'sbin @stream.bytes(0), ubound(stream.bytes)+1
  '? rnd
  'sleep
  
  _pixellate_decode
  
end sub

' encode ------------

sub _calc_dot_bene( byref p as tracking_vars ptr)
  _props_from p
  var error_nodot = AaDot_noSq.circ_err( @procview, @hashed_props )
  
  _drawdot p->idot, drawmode_draw
  var error_dot = AaDot_noSq.circ_err( @procview, @hashed_props )
  
  p->bene = error_nodot - error_dot
end sub

function _dot_result(byref p as tracking_vars ptr, dot_dna int) as tracking_vars
  p->dot_dna = dot_dna
  _calc_dot_bene p
  '_sbuf_show:  sleep 300
  _drawdot p->idot, drawmode_erase
  '_sbuf_show:  sleep 150
  '? p->dot_dna, p->idot, p->bene; " "
  'sleep 800
  return *p
end function

sub _find_best_dot( byref p as tracking_vars ptr)
  p->idot += 1
  var dna = 0
  var dot_best = _dot_result(p, dna)
'  if dprint then ? " _fbd: "; c_dotbits; " ": sleep
  for dna = 1 to 2 ^ c_dotbits - 1
    var dot = _dot_result( p, dna )
    if dot.bene > dot_best.bene then dot_best = dot
  next
  *p = dot_best
  '? p->dot_dna, p->idot, p->bene; " "
end sub

sub _encode_dot_group( byref p as tracking_vars ptr)
  
  var pos0 = stream.bitpos
  
  _cdotbits_calcs p
'  if dprint then ? " _edg: "; hdr_val; " ": sleep
  
  dim dbl sum_bene
'  dbg.p0 " enc_chunk", idot_break, pos_break_absolute, dots_per
  while stream.bitpos < pos_break_absolute andalso p->idot < idot_break
    _find_best_dot p
    sum_bene += p->bene
    
    var advance_amount = 0
    stream.write p->dot_dna, c_dotbits, advance_amount
    _decode_dot p
  wend

  p->bits_encoded = stream.bitpos
'  p->dots_encoded += p->idot - idot0
  p->bene = sum_bene / (stream.bitpos - pos0)
  'sbuf_show
 'sleep 
 
End Sub

dim int idot0 '' written by _find_dot_group_best
dim int frame0

dim int bitpos_start, bypos_start, bypos_end '' supports


function _encode_hdr_val( hdr_val as byte) as tracking_vars ptr '' major
  static as tracking_vars return_val
  
  return_val = progress
  return_val.hdr_val = hdr_val
  
  return_val.idot = idot0 '' written by _find_dot_group_best
  frame = frame0
  
  stream.bitpos = progress.bits_encoded
  var advance_amount = 0 '' stream.read advances bitpos in _cdotbits_calcs
  stream.write hdr_val, c_hdrbits, advance_amount
  'var k = stream.read(c_hdrbits, 0)
    'if dprint then ? " _ehv: "; k; " ": sleep

  
'  ? idot
  'if dprint then ? " _encode_hdr_val: pos, idot"; idot; " "
  'dbg.mode = hdr_val = 0
  _encode_dot_group @return_val
'  _sbuf_show
'  sleep 100
'  dbg.mode = 0
'  _sbuf_show
  
  var do_erase = true
  _decode bitpos_start, stream.bitpos, idot0, do_erase
'  ? hdr_val, return_val.bene, bitpos_start, stream.bitpos
' ? " "; return_val.bene; " "
'  sleep 400
  '? sbin( @stream.bytes(0), ubound(stream.bytes)+1 )
  return @return_val
end function

sub _save_pos_start_for_draw_best_result
  bitpos_start = stream.bitpos
  bypos_start = bitpos_start \ 8
  idot0 = progress.idot
  frame0 = frame
end sub

sub _save_best_dna
  copy_bytes stream.bytes(), dna_best(), bypos_start, bypos_end
  'stream.bitpos = progress.bits_encoded
end sub

sub _save_generated_dna
  bypos_end = (stream.bitpos-1) \ 8 '' integer divide
  copy_bytes dna_best(), stream.bytes(), bypos_start, bypos_end '' dest, src, 0, 1
end sub

sub _save_and_draw_best
  _save_best_dna
  frame = frame0
  'dprint = 1
  _decode bitpos_start, progress.bits_encoded, idot0
  'dprint = 0
end sub

dim as tracking_vars      vars_best
dim as tracking_vars ptr  trackvars_result


sub _find_dot_group_best '' major

  _save_pos_start_for_draw_best_result
'  progress.bits_encoded = bitpos_start
  var header_val = 0
  vars_best = *_encode_hdr_val( header_val)
  _save_generated_dna
'  sbuf_show:sleep

  for header_val = 1 to seed_hdr._max
    trackvars_result = _encode_hdr_val( header_val)
    '_decode bitpos_start, , do_erase
    if trackvars_result->bene > vars_best.bene then ' -- copy new dna
      vars_best = *trackvars_result
      _save_generated_dna
    endif
  next

  progress = vars_best
'  progress.dots_encoded += p->idot - idot0
'  ? "bene"; progress.bene; " "
'  sleep
'  ? sbin( @dna_best(0), bypos_end+1 - bypos_start )
  _save_and_draw_best
'  ? sbin( @stream.bytes(0), bypos_end+1 - bypos_start )
'  _sbuf_show
'  sleep 700
  
  frame = frame0 + 1 '' for exponential dot count
  
end sub

dim as string g_key '' user input


sub _scholastic( diagonal sng, small_rad_exit int = true)  
  'if stream.pos_oob < 1 orelse progress.bits_encoded >= stream.pos_oob then exit sub
  
  _workbuf_size diagonal / imv_mid.diagonal
  
  _sbuf_solidfill
  
  _decode
'  ? " _schol: pos_brk_abs"; pos_break_absolute
'  ?

  while stream.bitpos < pos_break_absolute
    
    _find_dot_group_best
    
    if small_rad_exit then
      if hashed_props.rad < 6.7 then exit while
    EndIf
    g_key = inkey
    if g_key <> "" then exit while
    
    #if 1
      t = timer
      if t > tTriggerF + .5 then
        _sbuf_show
        windowtitle "bytes left: "+ str(ubound(stream.bytes)+1 - ((stream.bitpos \ 8))) + " "
        tTriggerF = t
      endif
    #endif
  wend
  '_sbuf_show: sleep 500
  '_sbuf_solidfill
  ''dprint = 1
  '_decode
  '_sbuf_show': sleep 100
end sub


sub encode( byte_len int )
  
  locate 30,1
  _fresh_from_the_oven = true
  if byte_len < 1 then exit sub
    
  var u = byte_len - 1
  redim stream.bytes(u)
  redim dna_best( u)
 
  stream.pos_oob = ( u+1) * 8
  
  stream.bitpos = 0
  stream.flags_write
  
  progress.bits_encoded = stream.bitpos
  
  _cbits_min_req @progress
  seed_hdr._setmax c_hdrbits
  
  /'
  ? pos_break_absolute
  dbg.p0 " fhb", idot_break, pos_break_absolute, dots_per
  dbg.p progress.idot, stream.bitpos, progress.bits_encoded, progress.dots_encoded
  sleep
  '/
  
  var diagonal = 54
  var b_small_rad_exit = false
  
  _scholastic diagonal', b_small_rad_exit
  '
  while (diagonal < imv_source.diagonal - 70) andalso stream.bitpos < pos_break_absolute
    if g_key <> "" then _sbuf_show: exit sub
    diagonal += 35
    _scholastic diagonal
  wend

'  dbg.mode = 1
'  if dbg.mode then ? stream.bitpos, pos_break_absolute: _sbuf_show: sleep
  _scholastic imv_source.diagonal, b_small_rad_exit
  _sbuf_show '1,1
  '/
  'sleep
end sub

end namespace ' -- dsi_imager
'
' ------- dsi version.bas
'#include "saveload.bas"
/' -- saveload.bas - 2022 May 3
'/

'#include once "version/t.bas" '' i put this before #include saveload.bas in Main()


  namespace file_stuff

dim as byte   bytes()
dim int simulate = false '' if True, doesn't write to disk.  (also doesn't load a properly-saved file)

sub _structs_to_bytes
  dsi_imager.progress = type(ns_compat.work_branch)
  var c_text = len(dsi_imager.progress.p_hypers->text) + 1 '' include termination byte
  '? "to "; c_text:sleep
  redim bytes(c_text + sizeof(dsi_imager.infoheader) + ubound(stream.bytes))
  cpy @bytes( 0 ), @dsi_imager.progress.p_hypers->text[0], c_text
  cpy @bytes( c_text ), @dsi_imager.infoheader, sizeof(dsi_imager.infoheader)
  cpy @bytes( c_text + sizeof(dsi_imager.infoheader) ), @stream.bytes(0), ubound(stream.bytes) + 1
End Sub

sub _structs_from_bytes
  dsi_imager.progress = type(ns_compat.work_branch)
  'var c_text = len(dsi_imager.progress.p_hypers->text) + 1
  var c_text = pos_val0( @bytes(0)) + 1
  '? "from "; c_text: sleep
  dsi_imager.progress.p_hypers->text = space(c_text)
  cpy @dsi_imager.progress.p_hypers->text[0], @bytes( 0 ), c_text
  cpy @dsi_imager.infoheader, @bytes( c_text ), sizeof(dsi_imager.infoheader)
  var c_data = ubound(bytes) + 1 - c_text - sizeof(dsi_imager.infoheader)
  redim stream.bytes(c_data - 1)
  cpy @stream.bytes(0), @bytes( c_text + sizeof(dsi_imager.infoheader) ), c_data
End Sub

dim as string s


sub _read_common( forum_friendly int )
  
  var c = len(s)
  if c < 1 then exit sub
  
  if forum_friendly then
    s = base128.decode(s)
    redim bytes(len(s)-1)
    cpy @bytes(0), @s[0], len(s)
  else
    redim bytes(len(s)-1)
    cpy @bytes(0), @s[0], len(s)
  endif
  
  _structs_from_bytes
  #if 1
    ns_compat.compute__flag_official
    if stream.flag_official = false then
      'draw string (50,50), "file version: " + dsi_imager.progress.p_hypers->text
      '?
    end if
  #endif
  
  using dsi_imager
  
  imv_source.create infoHeader.w, infoHeader.h
  if infoheader.w + infoheader.h > 9000 then exit sub '' 
  stream.bitpos = 0
  
  c = ubound(bytes)+1 - len(dsi_imager.progress.p_hypers->text) - len(infoheader)
  stream.pos_oob = c*8
  dsi_imager.progress.bits_encoded = stream.pos_oob
  
  imv_mid.downscale_from @imv_source, 1.0
  _fresh_from_the_oven = false
  
  _cbits_min_req @progress '' lines also used in dsi_imager.encode()
  seed_hdr._setmax c_hdrbits

End Sub

dim as byte savestream()

const data_width = 65


sub dsi_save(byval filename as string, forum_text int = false)
  if dsi_imager.procview.h < 1 then exit sub
  
  adjust_file_ext filename, iif(forum_text, " (forum text).txt", ".dsi")
  
  _structs_to_bytes
  
  redim savestream(ubound(stream.bytes))
  cpy @savestream(0), @stream.bytes(0), ubound(savestream) + 1
  var save_oob = stream.pos_oob
  
  if forum_text then
    s = base128.encode( bytes() )
    var i = 0, q = ""
    while i < len(s)
      'q += mid(s, i+1, data_width)
      q += "Data " + c34 + mid(s, i+1, data_width) + c34 + c10
      i += data_width
    wend
    redim bytes( len(q) - 1 )
    cpy @bytes(0), @q[0], len(q)
  endif

  if simulate then
    s = space(ubound(bytes)+1)
    cpy @s[0], @bytes(0), len(s)
  else
    var k = freefile
    open filename for binary access write as #k
      put #1,, bytes()
    close #k
  endif
    
  redim stream.bytes( ubound(savestream))
  cpy @stream.bytes(0), @savestream(0), ubound(savestream) + 1
  stream.pos_oob = save_oob

end sub


sub dsi_load(byval filename as string, forum_text int = false)
  adjust_file_ext filename, iif(forum_text, " (forum text).txt", ".dsi")
 'var sav_bp = stream.bitpos
  'if simulate then
    '? len(s)
  'sleep  
  'else
    
    var k = freefile
    open filename for binary access read as #k
    s = space(lof(k))
    get #k,, s
    close #k
    
  'endif

  if forum_text then
    var i = 0, q = ""
    while i < len(s)
      q += mid(s, i + 7, data_width)
      i += data_width + 8 '' "data + ", end double quote, return
    wend
    s = left(q, len(q)-2) '' minus the end quote and return
  endif
  
  _read_common forum_text
  'stream.bitpos = sav_bp
end sub

sub dsi_read_data
  dim as string q:  s = ""
    
  do
    read q
    s += q
  loop until q = ""
  
  if len(s) < 1 then ? "Expected:  Data statements after last LOC": sleep 1500: exit sub
  var forum_friendly = true
  _read_common forum_friendly
End Sub

End Namespace ' -- file_stuff

' ----------- saveload.bas


var w = 960
var h = 700

screenres w, h, 32

using dsi_imager

chdir exepath

if 1 then
  
  #if 1
    _bmpload_and_downscale filename, 1.0
    
    var data_size = 480
    encode data_size
  #endif

  #if 0
    var forum_friendly = 1 '' 1 or 0
    file_stuff.dsi_save filename, forum_friendly
    file_stuff.dsi_load filename, forum_friendly
    ? "file load"
  #endif

else

  ? "FB Data test":  sleep 1300
  file_stuff.dsi_read_data '' you can paste data statements from generated text file after last line of code
  ? "Finished reading data.":   sleep 800
endif

line(0,0)-(w,h),rgb(99,88,77), bf ' .. "done." ..

decode

windowtitle "data area: " + str(ubound(stream.bytes)+1) + " bytes .. done!"
sleep
Last edited by dafhi on May 04, 2022 1:43, edited 52 times in total.
badidea
Posts: 2586
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: personal project - new image format

Post by badidea »

I think that the code is missing?
dafhi
Posts: 1640
Joined: Jun 04, 2005 9:51

Re: personal project - new image format

Post by dafhi »

i'm just sharing my excitement. sussing out "whitepaper" as both source and comments. i'll post code as i go, and the whole thing all at once when i'm done.

May 3 - data. might post a pic
Last edited by dafhi on May 04, 2022 1:45, edited 12 times in total.
badidea
Posts: 2586
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: personal project - new image format

Post by badidea »

Well, i that case, I cannot wait. I always wanted a super-savage and lossy image format that not supported by any program yet :-)
dafhi
Posts: 1640
Joined: Jun 04, 2005 9:51

Re: personal project - new image format

Post by dafhi »

couldn't have put it better myself :-)

well a bit more info .. i have a new dot renderer, i have yet to write its final form, but each dot gets, right now i am seeing a maximum of 6 bytes for an 8k by 8k image.

I have a c++ version showcasing the visual quality which is superior to alpha blending in most respects. My freebasic version won't use square root

There's a whole mess of interesting things involved. I'm actually as enthused about the journey as I am about the destination! I think it's a first for me :)
dafhi
Posts: 1640
Joined: Jun 04, 2005 9:51

Re: personal project - new image format

Post by dafhi »

hi guys. just posting some info here to sprinkle some inspiration back into my project. noting the recent codez on merging files with executable, it's like things are getting closer to a new demoscene image format. i've been wondering what to call the new format. I come up with catchy names imo, and i'll try to keep "dafhi's" out of it xD

I think I have my hash function

Code: Select all

type statelit as ulong
  namespace dsi_hash ''

dim as statelit a,b,c,d,e,f

dim as statelit mulC = &b10000000001000000001000000010000001000001000010001001011

sub reset
  a = 0
  b = 0
end sub

function valu( i as ulongint = 0) as statelit
  b += (a xor i)
  a xor= b * mulc shr 1
    
  return a
End function

function ini( i as ulongint = 0) as statelit
  reset
  return valu(i)
End function

End Namespace ' -- dsi_hash --
i achieve 1 bit per graphical primitive:

Code: Select all

for i = 0 to u_dots
  dsi_hash.ini i '' set seeds to 0 and call valu() (the RNG)
  
  rad = dsi_hash.valu(pk.rad) '' pk (short for pack-unpack) contains vari-bit members (vari-bit is seperate udt)
  x = dsi_hash.valu(pk.x) ' x tends to be the Eigenvector so I might
  y = dsi_hash.valu(pk.y) ' have 1 bit of precision there and everything
  r = ..                  ' else makes no difference.
  g = ..                  ' Everything's variable though as option
  b = ..
  slope = ..
the interesting thing is that x and y can have 2^[hash bits] of precision. it is so with every property.
the hash function provides such. Vari-bit hash parameter gives choice of one hash value over another via error measurement.

The error measurement is the tedious part :)
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: personal project - new image format

Post by dodicat »

Hi dafhi
Looks nice graphics in C++
I experiment with C++ a lot these days.
I don't use (or have sdl2).
But it is an amazing language.
Good luck.
dafhi
Posts: 1640
Joined: Jun 04, 2005 9:51

Re: personal project - new image format

Post by dafhi »

that's great! for the longest time i felt ill-equipped for c++ but with involvement with a ray tracing group i now have some experience. i think my c++ dots look better, i'm not sure if my brain is making it up. surprised i got sdl2 working but it worked out rather easily. i've been using Manjaro for about 2 months, my Win7 just had too many quirks
dafhi
Posts: 1640
Joined: Jun 04, 2005 9:51

Re: personal project - new image format

Post by dafhi »

significant update. check it out!
D.J.Peters
Posts: 8586
Joined: May 28, 2005 3:28
Contact:

Re: personal project - new image format

Post by D.J.Peters »

not tested but your code must crash on 64-bit !

if you define int as integer you will read complete wrong image sizes from bmp file.

it must be long 32-bit on both targets 32-bit and 64-bit !

Get #filenum, 19, w ' read 19,20,21,22,23,24,25,26
Get #filenum, 23, h ' read 23,24,25,26,27,28,29,20

by the way ulong is a bad idea also
because height in bmp files are often negative !

Joshy
dafhi
Posts: 1640
Joined: Jun 04, 2005 9:51

Re: personal project - new image format

Post by dafhi »

okay thanks. i've updated imagevars.bmp_load and .create, and added comment about my redefinition of Int()

i'm running 64 bit, never had problems
dafhi
Posts: 1640
Joined: Jun 04, 2005 9:51

Re: personal project - new image format

Post by dafhi »

saves / loads now
dafhi
Posts: 1640
Joined: Jun 04, 2005 9:51

Re: personal project - new image format

Post by dafhi »

a next gen architecture is working. code is in my 2nd post. quality improvement at 30 - 400 bytes.
[edit: well possibly. updated main version with things i learned]


[edit] Aiming for March 10 file format 'review' date. Either by me or community
dafhi
Posts: 1640
Joined: Jun 04, 2005 9:51

Re: personal project - new image format

Post by dafhi »

Base128 encode / decode is working!! saves as formatted data statements
Post Reply