run length blit 2024

[dafhi]

i wrote one of these in VB
years ago i translated to FB and posted somewhere on this forum.

wrote a new one from scratch, thinking i could make it shorter.
mission accomplished.

Code: Select all

h blit alpha - 2024 Jan 9 - by dafhi

  watching a space-shooter playthrough, i decided to code a run-length
  blit in freebasic

  recommended -gen gcc options from UEZ / DeltaRho comments
  -arch native -Wc -Ofast,-mfpmath=sse,-funroll-loops    
  
    update
  removed a ton of unnecess. code
  reorganized
  
'/


' -- boilerplate - 2023 May 12 - by dafhi
'
#define flo(x)      (((x)*2.0-0.5)shr 1) '' replaces int (and faster) - http://www.freebasic.net/forum/viewtopic.php?p=118633

#undef int

#define int         as integer
#define sng         as single
#define dbl         as double

#define decl    declare
#define oper    operator
#define prop    property
#define csr     constructor

#define min( a, b)        iif( (a)<(b), (a), (b) )
#define max( a, b)        iif( (a)>(b), (a), (b) )

' ------------------- boilerplate


'' A function that creates an image buffer with the same
'' dimensions as a BMP image, and loads a file into it.

Const NULL As Any Ptr = 0

Function bmp_load( ByRef filename As Const String ) As Any Ptr '' https://www.freebasic.net/wiki/KeyPgBload

    Dim As Long filenum, bmpwidth, bmpheight
    Dim As Any Ptr img

    '' open BMP file
    filenum = FreeFile()
    If Open( filename For Binary Access Read As #filenum ) <> 0 Then Return NULL

        '' retrieve BMP dimensions
        Get #filenum, 19, bmpwidth
        Get #filenum, 23, bmpheight

    Close #filenum

    '' create image with BMP dimensions
    img = ImageCreate( bmpwidth, Abs(bmpheight) )

    If img = NULL Then Return NULL

    '' load BMP file into image buffer
    If BLoad( filename, img ) <> 0 Then ImageDestroy( img ): Return NULL

    Return img

End Function


/' -- 2024 Jan 8 - by dafhi

  generic image info w/ zoom (useful for debugs)

'/
type imvars
  declare csr
  declare csr( as any ptr )
  
  declare oper  cast() as any ptr
  declare oper  let( as any ptr )
  
  decl sub      get_info( byref p as any ptr = 0 )
  decl sub      zoom( as long=0, as long=0, as long = -1, as long = -1, as ubyte = 1 ) '2023 May 11
  
  as long       w '' apparently imageinfo no longer likes integer
  as long       h
  as long       pitch,rate
  as long       bypp,bpp
  as any ptr    pixels, im
  as string     driver_name
end type
  
oper imvars.cast as any ptr
  return im
end oper

oper imvars.let( p as any ptr )
  get_info p
end oper

csr imvars
end csr

csr imvars( p as any ptr )
  this = p
end csr

sub imvars.get_info( byref p as any ptr )
  if p = 0 then
    ScreenInfo w,h, bpp, bypp, pitch, rate, driver_name
    pixels = screenptr
  else
    ImageInfo p, w, h, bypp, pitch, pixels
  endif
  im = p
end sub

sub imvars.zoom( xdes as long, ydes as long, wid as long, hgt as long, size as ubyte )
  
  var sizem = size - 1
  
  dim as long wmdes, hmdes
  
  ScreenInfo wmdes, hmdes, bpp, bypp, pitch, rate, driver_name
  wmdes -= 1
  hmdes -= 1
  
  var x1=xdes + (wid-1)*size: x1=min( x1, wmdes )
  var y1=ydes + (hgt-1)*size: y1=min( y1, hmdes )
  
  line (xdes-2, ydes-2) - (x1+size, y1+size), rgb(255,0,255), b
  
  for y as long=ydes to y1 step size
    var ysrc = (y-ydes)\size
    for x as long=xdes to x1 step size
      var xsrc = (x-xdes)\size
      line (x, y)-(x+sizem, y+sizem), _
      point( xsrc, ysrc ), bf
    next
  next
    
End Sub


  namespace rl_blit '  run-length sprites  - 2024 Jan 8 - by dafhi
  
/' -- basic use

  screenres 800,600, 32

  rl_blit.dest_surface 0 '' window


  var mask_col = rgb(0,0,0) '' default imagecreate fill is magenta
    
    dim as any ptr        my_fb_image = imagecreate(50,50, mask_col)    
  for n as long = 1 to 8
    circle my_fb_image, (5+rnd*30, 5+rnd*30), 2+rnd*3, rnd * culng(-1)
  next


  put (0,0), my_fb_image, pset '' pset = copy blit
  ? "generated sprite"
  sleep 1500

  cls

    dim as rl_blit.sprite sprite
  sprite.encode my_fb_image, mask_col

  for n as long = 1 to 30
    sprite.blit rnd * 200, rnd * 200
  next
  screenlock
  screenunlock

  locate 2,2
  ? "run length encoded"

  sleep

-------- '/


dim as imvars       des


type t_cliprect field = 2
  decl          constructor
  decl          constructor( int = -1, int = -1, int = -1, int = -1 )
  decl sub      set( int = -1, int = -1, int = -1, int = -1 )
  decl oper     let( as imvars )
  as short      x0, x1 = -1
  as short      y0, y1 = -1
  decl oper     cast as string
end type

csr t_cliprect '' constructor
end csr

csr t_cliprect( x0 int, y0 int, x1 int, y1 int )
  set x0, y0, x1, y1
end csr

oper t_cliprect.cast as string
    return _
  "x0: " + str(x0) + _
  " x1:" + str(x1) + _
  " y0:" + str(y0) + _
  " y1:" + str(y1)
end oper

oper t_cliprect.let( i as imvars )
  x0 = 0: x1 = i.w-1
  y0 = 0: y1 = i.h-1
end oper

sub t_cliprect.set( xa int, ya int, xb int, yb int )
  x0 = iif(xa < 0, x0, xa)
  x1 = iif(xb < 0, x1, xb)
  y0 = iif(ya < 0, y0, ya)
  y1 = iif(yb < 0, y1, yb)
end sub

  
  dim as t_cliprect   clip_rect

sub dest_surface( p as any ptr = 0 )
  des.get_info p '' old:  grab p '' 2024 Jan 8
  clip_rect = des
end sub


  type _run_length field = 2 '' align
    as ushort   offs ' 
    as ushort   lenm ' length minus 1
  end type

  type _scanline field = 1  '' 
    as _run_length    rl(any)
    as ulong          col(any)
    as ushort         csegs
  end type


type sprite
  declare csr
  declare csr( filename as string, as ulong = rgb( 255,0,255) )
  declare csr( as any ptr, as ulong = rgb( 255,0,255) )
  declare sub     encode( byref as imvars, as ulong )
  declare sub     blit( int=0, int=0 )
  as ushort       w
  as ushort       h
  
  declare sub     _blit__scan(int)
  as _scanline    _sl(any)
  as ulong        _bgcol
end type

csr sprite '' constructor
end csr
  
  ' encode support - namespace globals
  dim as imvars ptr   p_src
  dim as _scanline    sl

  sub _encode__scan( y int, bgcol as ulong )
  
    dim as ulong ptr p32_src = p_src->pixels
    p32_src += y * p_src->pitch \ 4
    
    sl.csegs = 0
    var lenm = -1
    var col_idx = -1
    
    for x int = 0 to p_src->w - 1
      if p32_src[x] <> bgcol then
        
        if lenm = -1 then
          sl.rl(sl.csegs).offs = x
          sl.csegs += 1
        endif
        
        col_idx += 1
        sl.col(col_idx) = p32_src[x]
        
        pset(x,y), p32_src[x]
        
        lenm += 1
        
        if x = p_src->w - 1 then
          sl.rl( sl.csegs - 1 ).lenm = lenm
        end if
        
      elseif lenm > -1 then
        sl.rl(sl.csegs - 1).lenm = lenm
        lenm = -1
      end if
      
    next x

    if sl.csegs > 0 then '' 2023 May 12
      redim preserve sl.col( col_idx )
      redim preserve sl.rl( sl.csegs - 1 )
    else
      redim sl.col(0)
      redim sl.rl(0)
      sl.rl(0).lenm = -1 '' prevent scanline blit
    endif
      
  end sub

sub sprite.encode( byref im_src as imvars, bgcol as ulong )
  
  _bgcol = bgcol
  w = im_src.w
  h = im_src.h

  dim int max_segs = (im_src.w + 2) \ 2
  
  redim _sl(im_src.h - 1)
  
  p_src = @im_src
  
  for y int = 0 to im_src.h - 1
    redim sl.rl(max_segs - 1)
    redim sl.col(im_src.w - 1)
    _encode__scan y, bgcol
    _sl(y) = sl
  next y
  
end sub
  
csr sprite( p as any ptr, bgcol as ulong )
  encode type<imvars>(p), bgcol
end csr

csr sprite( filename as string, bgcol as ulong )
  encode bmp_load(filename), bgcol
end csr


  '' decode support - namespace globals
  dim as ulong ptr      pdLeft
  dim int               y_src
  dim as t_cliprect       cr '' clipper for user-spec vs actual window
  dim as _run_length ptr  rl
  
  
sub sprite._blit__scan( x_des int ) '' 2024 Jan 8

  dim as ulong ptr p32_src = @_sl(y_src).col(0)
  
  for i_seg int = 0 to _sl(y_src).csegs - 1
    
    rl = @_sl(y_src).rl( i_seg )
    var x_des0 = x_des + rl->offs
    var x_des1 = min(x_des0 + rl->lenm, cr.x1)
    var clip0 = iif( x_des0 < cr.x0, cr.x0 - x_des0, 0 )

    dim as long x_src = clip0
    
    for ix_des int = x_des0+clip0 to x_des1
      pdLeft[ix_des] = p32_src[ x_src ]
      x_src += 1
    next
    p32_src += rl->lenm + 1
    
  next

end sub

sub sprite.blit( xx_des int, yy_des int )

  cr.x1 = min(des.w - 1, clip_rect.x1)
  cr.y1 = min(des.h - 1, clip_rect.y1)
  cr.x0 = max(clip_rect.x0, 0)
  cr.y0 = max(clip_rect.y0, 0)
  
    pdLeft = cast( any ptr, des.pixels ) + _
  iif( yy_des < cr.y0, cr.y0, yy_des ) * des.pitch
  
  var y0_src = iif( yy_des < cr.y0, cr.y0 - yy_des, 0 )
  var y1_src = yy_des + h-1
  y1_src = h - 1 - iif( y1_src > cr.y1, y1_src - cr.y1, 0 )
    
  for y_src = y0_src to y1_src
    _blit__scan xx_des
    pdleft += des.pitch \ des.bypp
  next
  
end sub
  
end namespace ' ------ rl_blit


'
' ----  Main
'

function procedural_image( w int = 10, h int = 10, bgcol as ulong = 0, messy as boolean = true ) as any ptr
  dim as any ptr im_temp = imagecreate( w,h, bgcol )
  for i int = 1 to 3*sqr( w + h )
    var col = rgb(rnd*255,rnd*255,rnd*255)
    if messy then pset im_temp, (rnd*w,rnd*h), col
    if messy andalso rnd < .3 then line im_temp, (rnd*w,rnd*h)-(rnd*w,rnd*h), col
  next
  return im_temp
end function

  dim shared as rl_blit.sprite  sprite

sub rand_sprite_and_encode
  var siz = 59
  dim as ulong  bgcol = rgb(0,0,0)
  dim as imvars im_temp = procedural_image( siz, siz, bgcol )
  sprite.encode im_temp, bgcol
end sub

' -------------

var w = 800
var h = 600

screenres w,h, 32 '' gfx init must precede mem buf / load bmp

rand_sprite_and_encode

var win2_x = 10
var win2_y = 80

var zoom = 4

rl_blit.dest_surface 0 '' window

  dim shared sng cenx, ceny, rad
with rl_blit.clip_rect
  rad = sqr( (.x1 - .x0) ^ 2 + (.y1 - .y0) ^ 2 )
end with


locate 1,1
print "generated sprite"

sprite.blit 0,0

rl_blit.des.zoom win2_x, win2_y, sprite.w*4, sprite.h*1.1, zoom
sleep 1500


cls

dim int x = 0
dim int y = 0

dim shared as imvars im_temp


sub manual_clip_adjust
  with rl_blit.clip_rect
    .set 5, 5, 50, 50
    cenx = ((.x0 + .x1) - sprite.w) / 2
    ceny = ((.y0 + .y1) - sprite.h) / 2
    rad = sqr( (.x1 - .x0) ^ 2 + (.y1 - .y0) ^ 2 )
    im_temp = imagecreate( .x1+1 - .x0, .y1+1 - .y0, rgb(32,32,32) )
    draw string im_temp, (6,15), "CLIP"
    draw string im_temp, (6,25), "RECT"
  end with
end sub

manual_clip_adjust


const tau = 8 * atn(1) '' 2 * pi

type angle_and_increment
  decl oper cast as double
  decl oper cast as string
  dbl a = rnd * tau
  sng ia = .03 * (.3 + rnd)
end type

oper angle_and_increment.cast as double
  return a
end oper

oper angle_and_increment.cast as string
  return str(a)
end oper


dim as angle_and_increment  a0, a1


var t_demo_secs = 12
windowtitle "run time " + str(t_demo_secs) + " seconds"
var t_demo_end = timer + t_demo_secs * 1000


var sleep_amount = 1


for t as double = timer to t_demo_end
  
  var dt = .07 * sleep_amount

  var a1sin = .75 * rad
  x = cenx + a1sin * cos(a0)
  y = ceny + .4* a1sin * sin(a1)
  a0.a += a0.ia * dt
  a1.a += a0.ia * dt * 1.414
    
    
    screenlock
    
  with rl_blit.clip_rect '' background
    put (.x0,.y0), im_temp, pset
  end with
  
  sprite.blit x, y

  rl_blit.des.zoom win2_x, win2_y, sprite.w*2, sprite.h*1.0, zoom
  
  screenunlock
  
  
  sleep sleep_amount
  if inkey<>"" then exit for
  
next

imagedestroy im_temp '' "CLIP RECT" background

locate 1,1
? "demo finished."

sleep

another way to "run length" blit - use vectors

Code: Select all

/'
  3d point cloud -- 2023 May 27 - by dafhi
'/

'#include "../util.bas"
#define flo(x)      (((x)*2.0-0.5)shr 1) '' replaces int (and faster) - http://www.freebasic.net/forum/viewtopic.php?p=118633

#undef int

#define int         as integer
#define sng         as single

function min( a as double, b as double ) as double
  return iif( a < b, a, b)
end function

function max( a as double, b as double ) as double
  return iif( a > b, a, b)
end function

const tau = 8 * atn(1)


type v3float as single


type v3 '' dodicat introduced us to this wild nomenclature
  declare function rodrigues( as v3, sng, sng) as v3
  as v3float     x,y,z
  declare property  mag as v3float
  declare property  norm as v3
  declare sub   rand
End Type

sub v3.rand
  y=2*(rnd-.5):  var r=sqr(1-y*y)
  z=rnd*tau: x=r*cos(z): z=r*sin(z)
End Sub

property v3.mag as v3float
  return sqr(x*x+y*y+z*z)
end property

property v3.norm as v3
  var s = 1/ max( mag, .001 )
  return type(x*s,y*s,z*s)
end property

function v3.rodrigues( _norm as v3, sina sng, cosa sng) as v3
  static sng dot:  dot=(1-cosa)*(_norm.x*x+_norm.y*y+_norm.z*z)
  return type(_
    _norm.x*dot + x*cosa + (_norm.y*z - _norm.z*y)*sina, _
    _norm.y*dot + y*cosa + (_norm.z*x - _norm.x*z)*sina, _
    _norm.z*dot + z*cosa + (_norm.x*y - _norm.y*x)*sina)
End function


type tStackInfo
  declare constructor
  declare sub       reset
  declare property  yep_resize as boolean
  dim int           i, u
end type
constructor tStackInfo: reset
end constructor
sub tStackInfo.reset: u = -1: i = -1
end sub
property tStackInfo.yep_resize as boolean
  i += 1:  var ret_val = i > u
  u = iif( ret_val, 1.5*(i), u )
  return ret_val
end property


#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



operator -(r as v3) as v3: return type(-r.x, -r.y, -r.z): end operator
operator -(l as v3,r as v3) as v3: return type(l.x-r.x,l.y-r.y,l.z-r.z): end operator
operator +(l as v3,r as v3) as v3: return type(l.x+r.x, l.y+r.y, l.z+r.z): end operator
operator /(l as v3,r as v3float) as v3: dim as v3float s = 1/r: return type(l.x*s,l.y*s,l.z*s): end operator
operator *(l as v3,r as v3float) as v3: return type(l.x*r,l.y*r,l.z*r): end operator
operator *(l as v3float, r as v3) as v3: return type(l*r.x,l*r.y,l*r.z): end operator
operator *(l as v3,r as v3) as v3: return type(l.x*r.x,l.y*r.y,l.z*r.z): end operator

type axis3
  declare constructor
  declare function rot( as v3 ) as v3

  as v3   vx,vy,vz
  as v3   pos
end type

constructor axis3
  vx = type(1,0,0)
  vy = type(0,1,0)
  vz = type(0,0,1)
end constructor

function axis3.rot( i as v3 ) as v3
  #if 1
  return vx * i.x + vy * i.y + vz * i.z
  #else
    return type( _
  vx.x * i.x + vy.x * i.y + vz.x * i.z, _
  vx.y * i.x + vy.y * i.y + vz.y * i.z, _
  vx.z * i.x + vy.z * i.y + vz.z * i.z)
  #endif
end function

'
' --------- util

'#include "../imvars.bas"
/' -- 2023 May 12 - by dafhi

  generic image info w/ zoom (useful for debugs)

'/
type imvars
  declare constructor
  declare constructor( byref as any ptr = 0 )
  declare sub      get_info( byref p as any ptr = 0 )
  declare sub      zoom( as long=0, as long=0, as long = -1, as long = -1, as ubyte = 1 ) '2023 May 11
  as long           w '' apparently imageinfo no longer likes integer
  as long           h
  as long           pitch,rate
  as long              bypp,bpp
  as any ptr    pixels
  as string     driver_name
end type

constructor imvars
end constructor

constructor imvars( byref p as any ptr )
  get_info p
end constructor

sub imvars.get_info( byref p as any ptr )
  if p = 0 then
    ScreenInfo w,h, bpp, bypp, pitch, rate, driver_name
    pixels = screenptr
  else
    ImageInfo p, w, h, bypp, pitch, pixels
  endif
end sub

sub imvars.zoom( xdes as long, ydes as long, wid as long, hgt as long, size as ubyte )
  
  var sizem = size - 1
  
  dim as long wmdes, hmdes
  
  ScreenInfo wmdes, hmdes, bpp, bypp, pitch, rate, driver_name
  wmdes -= 1
  hmdes -= 1
  
  var x1=xdes + (wid-1)*size: x1=min( x1, wmdes )
  var y1=ydes + (hgt-1)*size: y1=min( y1, hmdes )
  
  line (xdes-2, ydes-2) - (x1+size, y1+size), rgb(255,0,255), b
  
  for y as long=ydes to y1 step size
    var ysrc = (y-ydes)\size
    for x as long=xdes to x1 step size
      var xsrc = (x-xdes)\size
      line (x, y)-(x+sizem, y+sizem), _
      point( xsrc, ysrc ), bf
    next
  next
    
End Sub


type t_cliprect field = 2
  as ushort    x0, x1
  as ushort    y0, y1
  declare operator     cast as string
end type

operator t_cliprect.cast as string
  #if 1
    return _
  "x0: " + str(x0) + _
  " x1:" + str(x1) + _
  " y0:" + str(y0) + _
  " y1:" + str(y1)
  #else
  return "rect (" + str(x0) + "," + str(y0) + _
  ") - "  + str(x1) + "," + str(y1) + ")"
  #endif
end operator
'
' ------------------- imvars.bas


type v3c extends v3
  as ulong    col
end type

function procedural_image( w int = 10, h int = 10, bgcol as ulong = 0, messy as boolean = true ) as any ptr
  dim as any ptr im_temp = imagecreate( w,h, bgcol )
  for i int = 1 to .1*(w*h)
    var col = rgb(rnd*255,rnd*255,rnd*255)
    if messy then pset im_temp, (rnd*w,rnd*h), col
    if messy andalso rnd < .3 then line im_temp, (rnd*w,rnd*h)-(rnd*w,rnd*h), col
  next
  return im_temp
end function


sub encode( im as any ptr, bg as ulong = rgb(255,0,255), des() as v3c )
  dim as long       w,h,pitch, bypp
  dim as ulong ptr  pixels
  dim as tStackInfo si
ImageInfo im, w, h, bypp, pitch, pixels
for y as long = 0 to h-1
dim as ulong ptr row = pixels + pitch*y\bypp
  for x as long = 0 to w-1
if row[x]<> bg then
  if si.yep_resize then redim preserve des(si.u)
  des(si.i).x = (x-(w-1)/2) / max(1,w-1)
  des(si.i).y = (y-(h-1)/2) / max(1,h-1)
  des(si.i).col = row[x]
endif
next
next
redim preserve des(si.i)
end sub



type DotVars          '' 2023 May 30
  union
    Type:  As UByte   b,g,r,a
    End Type
    As ULong          col
  end union
  as v3               o,p
  as single           rad = 1
  as boolean          flag
End Type

type tView3D
  as single           iris_diam = 2
  as single           focus_z = 1
End Type

  
  namespace AaDot     '2023 May 30 - by dafhi
  

dim as imvars ptr  im

sub render_target(byref buf as imvars ptr):  im = buf
end sub


dim as t_cliprect     _clipped        '' namespace globals

dim sng               _slope_by_rad
dim sng               _metaball_alpha_scalar '' March 21
dim sng               draw_dist_from_center '' May 12

dim sng               dx, dy, dx0, dySQ

dim as ulong ptr      px

dim int               _alpha

sub _cliprect_calc( x sng, y sng, rad_multed sng ) '' May 30
  _clipped.x0 = max( flo( x - rad_multed ), 0 )
  _clipped.x1 = min( flo( x + rad_multed ), im->w-1 )
  _clipped.y0 = max( flo( y - rad_multed ), 0 )
  _clipped.y1 = min( flo( y + rad_multed ), im->h-1 )
end sub
  
sub _precalcs( x sng, y sng, col as ulong = -1, rad sng = 10)
  draw_dist_from_center = 1 '' May 30
  _metaball_alpha_scalar = min( rad, .003 ) '' March 21
  _cliprect_calc x, y, rad * draw_dist_from_center
  _slope_by_rad = 1 / max(rad, .001)
  dx0 = (_clipped.x0 - x) * _slope_by_rad
end sub
  
sub _scan( col as ulong, plot_y int )
  px = im->pixels + plot_y * (im->pitch)
  dySQ = dy * dy
  dx = dx0
  for plot_x int = _clipped.x0 to _clipped.x1
    dim int alpha = _alpha * (1 - (dx*dx+dySQ))
    Alpha256( px[plot_x], px[plot_x], col, max(alpha,0) )
    dx += _slope_by_rad
  next
  dy += _slope_by_rad  
end sub

sub _draw( x sng, y sng, col as ulong = -1, rad sng = 10)
  _alpha = 256.499 * (col shr 24) / 255
  dy = (_clipped.y0 - y) * _slope_by_rad
  for plot_y int = _clipped.y0 to _clipped.y1
    _scan col, plot_y
  next
end sub

sub draw( x sng, y sng, col as ulong = -1, rad sng = 10)
  _precalcs x, y, col, rad
  _draw x, y, col, rad
end sub

dim as dotvars ptr    p


  dim int alpha_thresh = 20 ''render-time hack

dim sng               r_expan
dim as dotvars        result

dim as tView3D        vie


sub defocus_draw(byref pdv as dotvars ptr)', rad_scalar sng = 1)

  p = @result '' namespace globals p and result
  
  with *pdv
  
    r_expan = vie.iris_diam * abs(.p.z - vie.focus_z)
    
    result.rad = .rad + r_expan
    result.col = .col
    
    result.a = 255.499 * .rad * .rad / (result.rad * result.rad)
  
    '' Sep 19 - reduce radius if low alpha
      result.rad = iif( result.a > alpha_thresh, result.rad, _
    result.rad * result.a / iif(alpha_thresh=0,1,alpha_thresh) )
    
    draw .p.x, .p.y, result.col, result.rad
  End With

End Sub

end namespace



var w = 800, wh = w/2
var h = 600, hh = h/2

ScreenRes w,h, 32

dim as imvars       buf = 0
aadot.render_target @buf


var         general_scale_2d = (wh+hh)

dim as v3c  points()

var         bg = rgb(0,0,0)
var         messy = true
var         im = procedural_image( 50,50, bg, messy )
encode im, bg, points()
put (0,0),im,pset
sleep 700
imagedestroy im

var         demo_seconds = 4

var         tp = timer, run_time = 0# '' # = double
var         report_next = tp + 1.5


aadot.vie.iris_diam = 18
aadot.vie.focus_z = 2
aadot.alpha_thresh = 15 '' alpha value less than this will reduce dot radius.
                        '' Namespace AaDot for hows and whys

dim as axis3        axis0
dim as double       angl_i
dim as v3           normal = type(1,2,0).norm

axis0.pos.z = 1.5

while run_time < demo_seconds

  var axis = axis0
  axis.vx = axis.vx.rodrigues( normal, cos(angl_i), sin(angl_i) )
  axis.vy = axis.vy.rodrigues( normal, cos(angl_i), sin(angl_i) )
  axis.vz = axis.vz.rodrigues( normal, cos(angl_i), sin(angl_i) )
    
    screenlock
  cls

  for i as long = 0 to ubound(points)
    static as dotvars dotv
    dotv.p = axis.rot( points(i) )
    dotv.p.z += axis.pos.z
    var z_inv = general_scale_2d / max( dotv.p.z, .001 )

    dotv.p.x = (axis.pos.x + dotv.p.x) * z_inv + wh
    dotv.p.y = (axis.pos.y + dotv.p.y) * z_inv + hh
    dotv.rad = min(8, .015*z_inv)
    dotv.col = points(i).col
    aadot.defocus_draw @dotv
  next

  var     t = timer
  dim sng dt = t - tp
  tp = t
  
  axis0.pos.z += dt * .3
  angl_i += .4 * dt
  
  run_time += dt

  static sng  dt2, dt_sum
  
  if run_time < 1.75 then
    locate 2,2
  elseif t > report_next then
    dt_sum = dt + dt2
    var m = str(report_next)
    windowtitle "FPS: " + str( 2 / dt_sum ) '' deltatime avg
    report_next += 1
  endif
  
  dt2 = dt
  screenunlock
  
  sleep 1

wend


locate 2,50
? "done!"

sleep 1500

[neil]

Nice one dafhi.

[paul doe]

Code: Select all

Aborting due to runtime error 1 (illegal function call) at line 414 of rle-blit-dahfi.bas::_ENCODE__SCAN()

[neil]

@dafhi
I am running it on Linux and it works OK no warnings or errors.

[UEZ]

Runs properly on Win11 compiled as x86 / x64.

Nice one dafhi.

[dafhi]

thank you for reporting Mr. Doe!

this might help

Code: Select all

      if sl.csegs > 0 then
        redim preserve sl.col( col_idx )
        redim preserve sl.rl( sl.csegs - 1 )
      else
        redim sl.col(0)
        redim sl.rl(0)
        sl.rl(0).lenm = -1 '' prevent from blitting
      endif

i'll have a think.

neil, great to hear! thanks for the report! one day i hope to make a vertical scrolling space shooter : )

[edit] oops: that was UEZ reporting xD

[paul doe]

thank you for reporting Mr. Doe!
...

No problem

@UEZ and @neil: you need run-time error checking enabled (-exx) to see the errors.

[neil]

@dafhi
Why don't get started on your vertical scrolling space shooter game? You have advanced graphics skills. After I made 2 basic snake games I saw this online. https://games.aarp.org/games/atari-centipede

I would like try to make a centipede game but I don't have your skills to do advanced gaming graphics.

[dodicat]

Pedunculate Oak, (Quercus robur), sometimes called English Oak.
Found throughout Europe and distributed across the computer screen.

Code: Select all

const as string leaf = _
"s1C4278241280BM15,07M+-16,14M+2,9M+-4,10M+-6,8M+1,6"_
&"M+11,11M+-2,13M+-5,12M+-10,9M+-7,11M+-9,11"_
&"M+-3,11M+9,13M+20,5M+13,7M+0,10M+-5,11"_
&"M+-18,22M+-13,21M+-2,16M+2,14M+6,12M+15,16"_
&"M+18,2M+18,-5M+6,4M+3,10M+0,10M+-6,8"_
&"M+-6,13M+-1,12M+6,19M+10,12M+9,5M+17,-1"_
&"M+13,-5M+22,0M+4,10M+0,18M+6,16M+8,11"_
&"M+11,4M+14,0M+11,-4M+7,-4M+6,4M+5,11"_
&"M+7,7M+12,7M+19,0M+18,-6M+10,-15M+-3,-14"_
&"M+-8,-8M+-5,-3M+-1,-3M+3,-7M+15,-1M+7,-3"_
&"M+2,-20M+-3,-15M+-8,-12M+-13,-7M+-6,-9M+0,-10"_
&"M+24,-11M+12,-15M+-2,-14M+-7,-11M+-12,-16M+-10,-9"_
&"M+-11,-2M+-12,-6M+-10,-2M+-4,-13M+10,-9M+18,-8"_
&"M+12,-12M+-2,-14M+-11,-11M+-31,-13M+-35,-12M+-24,-5"_
&"M+-7,-14M+0,-8M+13,-10M+0,-20M+-6,-10M+-14,-2"_
&"M+-31,-7M+-9,-2M+-8,-13M+2,-9M+-5,-5M+-12,-2"_
&"M+-9,-2M+-8,-2M+-6,-8M+-12,-7"_
&"BM+91,210P4278255360,4278241280"_
&"BM+-98,-203"_
&"M+14,30M+14,32M+19,46M+22,55M+20,43M+23,31"_
&"M+40,53M+27,33M+26,34"_
&"BM+-193,-327M+-20,2"_
&"BM+24,5"_
&"M+34,-17"_
&"BM+-25,35M+-35,40"_
&"BM+40,-27M+72,1"_
&"BM+-52,45"_
&"M+-21,47M+-21,39"_
&"BM+55,-57M+46,17M+58,6M+35,-4"_
&""_
&"BM+-112,44M+-18,61M+-28,41"_
&"BM+76,-67M+25,10M+61,19"_
&"M+24,0"_
&"BM+-79,23M+-2,46M+-10,43"_
&"BM+46,-46M+0,44"_
&"M+16,31"_
&"BM+-203,-410M+6,-5M+-24,-32M+-3,-4M+-11,3"_
&"M+8,10M+11,12M+10,11M+4,4"_
&"BM+-19,-29P4286056199,4278241280"
Sub Magnify(mx As Long=40,my As Long=40,offx As Long=100,offy As Long=0,pmw As Long=3)
      Dim As Ulong array(1 To 6561),count
      If pmw<1 Then Exit Sub
      For z As Integer=1 To 2
            For x As Integer=mx-40 To mx+40
                  For y As Integer=my-40 To my+40
                        count+=1
                        If z=1 Then array(count)=Point(x,y)
                        If z=2 Then
                              Var NewX=pmw*(x-mx)+mx:Var NewY=pmw*(y-my)+my
                              Line(offx+newx-pmw/2,offy+newy-pmw/2)-(offx+newx+pmw/2,offy+newy+pmw/2),array(count),bf
                        End If
                  Next y
            Next x
            count=0
      Next z
      Line(offx+mx-pmw*40,offy+my-pmw*40)-(offx+mx+pmw*40,offy+my+pmw*40),rgb(200,200,0),B
End Sub

Sub drawline(x As Long,y As Long,angle As Single,length As Long,col As Ulong)
      Var x2=x+length*Cos(angle)
      Var y2=y-length*Sin(angle)
      Line(x,y)-(x2,y2),rgb(200,200,200)
      Circle(x2,y2),5,rgb(255,100,0),,,,f
End Sub

Function Regulate(Byval MyFps As Long,Byref fps As Long) As Long
      Static As Double timervalue,_lastsleeptime,t3,frames
      Var t=Timer
      frames+=1
      If (t-t3)>=1 Then t3=t:fps=frames:frames=0
      Var sleeptime=_lastsleeptime+((1/myfps)-T+timervalue)*1000
      If sleeptime<1 Then sleeptime=1
      _lastsleeptime=sleeptime
      timervalue=T
      Return sleeptime
End Function

Sub pend(cx As Long,cy As Long)
      Static As Single angle
      Const pi=4*Atn(1)
      draw leaf
      angle+=.1
      drawline(cx,cy,.45*Sin(angle)-pi/2,80,4)
End Sub


Screen 21,32
Color , rgb(0,100,255)

Dim As Long fps
Do
      Screenlock
      Cls
      Locate 5,10
      pend(40,15)
      Draw String(10,80),"fps= " &fps,rgb(255,255,255)
      For n As Long=1 To 8
            Select Case n
            Case 1
                  magnify(40,60,160,40,2)
            Case 2
                  magnify(40,60,450,80,3)
            Case 3
                  magnify(40,60,850,120,4)
            Case 4
                  magnify(40,60,180,450+70,5)
            Case 5
                  magnify(40,60,450+110,400+80,4)
            Case 6
                  magnify(40,60,850,400+40,3)
            Case 7
                  magnify(40,60,1150,400+20,2)
            Case 8
                  magnify(40,60,600,800,1)
            
            End Select
      Next n
      Screenunlock
      Sleep regulate(40,fps)
Loop Until Len(Inkey)
Sleep 

[neil]

@dodicat
Nice one.

[neil]

@dafhi
When I redefined a font for my snake game I did the bit mapping on paper. I found this by aurelVZAB. This could help for designing game graphics for your space shooter game. viewtopic.php?t=29409

[neil]

@dodicat
Did you you use a bitmap editor to design the leaf?

[neil]

I need to learn a lot more about graphics. Look what hhr did with minimal code spinning gears.

Code: Select all

open scrn as #1 ' Wait until console is active (Useful in Linux with QTerminal).
close #1

#define pi2 (8*atn(1))
screenres 600, 500, 32, 2
screenset 0, 1
dim as single R, X1, Y1, X2, Y2, X3, Y3, X4, Y4, ao

do
   cls
   draw string (120, 50), "Minute (driven)", rgb(128, 255, 0)
   draw string (120, 70), "Hour (fixed on a tube)", rgb(255, 128, 0)
   draw string (360, 50), "Change gear", rgb(255, 255, 0)
   draw string (360, 70), "Coupled wheels", rgb(255, 255, 0)

   for A as single = 0 to pi2 step .001

      R = 100 + cos(16 * A) * 15     ' Hour, 16 teeth
      X1 = cos(A + ao) * R + 220
      Y1 = sin(A + ao) * R + 240

      R = 30 + sin(-4 * A + 11) * 10 ' Change gear (small), 4 teeth
      X2 = cos(A - 4 * ao) * R + 360
      Y2 = sin(A - 4 * ao) * R + 240

      R = 100 + cos(15 * A) * 15     ' Change gear (large), 15 teeth
      X3 = cos(A - 4 * ao) * R + 360
      Y3 = sin(A - 4 * ao) * R + 240

      R = 30 + sin(-5 * A - 11) * 15 ' Minute, 5 teeth, driven
      X4 = cos(A + 12 * ao) * R + 220
      Y4 = sin(A + 12 * ao) * R + 240

      pset (X1, Y1), rgb(255, 128, 0)
      pset (X2, Y2), rgb(255, 255, 0)
      pset (X3, Y3), rgb(255, 255, 0)
      pset (X4, Y4), rgb(128, 255, 0)
   next A

   ao = ao + 0.01
   flip
   screensync
loop until len(inkey)

[dodicat]

Nice.
Miscellaneous gears.

Code: Select all

Screen 20,32
Color ,Rgb(50,50,100)

#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
Sub drawline(x As Long,y As Long,angle As Single,lngth As Double,teeth As Long,delta As Single,Byref x2 As Long=0,Byref y2 As Long=0)
      Const pi=4*Atn(1)
      lngth+=(lngth/teeth)*Sin(angle*teeth)
      x2=x+lngth*Cos(angle+delta)
      y2=y-lngth*Sin(angle+delta)
End Sub

Sub sinecircle(x As Long,y As Long,rad As Double,teeth As Long,col As Ulong,delta As Single=0)
      Const pi=4*Atn(1)
      Dim As Long x2,y2
      For n As Single=0 To 2*pi + .1 Step 2*pi/360
            drawline(x,y,n,rad,teeth,delta,x2,y2)
            If n=0 Then Pset(x2,y2),col Else Line -(x2,y2),col
      Next n
      Paint(x,y),col,col
End Sub

Dim As Single a
Do
      a+=.01
      Screenlock
      Cls
      sinecircle(512,200-1+50,150,16,Rgb(200,100,100),2*a)
      sinecircle(512,400,100,8,Rgb(200,0,0),-a)
      sinecircle(512,200-1+50,50,4,Rgb(100,100,0),2*a)
      sinecircle(512+227,200-2+50,75,8,Rgb(200,100,0),-4*a)
      For n As Long=0 To 1024+20
            Var ypos=map(-1,1,Sin(n/12+a*8),500-10,530-15)
            If n=0 Then Pset(n-17,ypos),Rgb(0,100,255) Else Line-(n-17,ypos),Rgb(0,100,255)
      Next n
      Line(0,550)-(1024,550),Rgb(0,100,255)
      Paint(512,540),Rgb(0,100,255),Rgb(0,100,255)
      Screenunlock
      Sleep 1
Loop Until Len(Inkey)
Sleep
  

Neil, I use an editor for DRAW, I made it up as few years ago.
But I have found a bug in the latest fb distro.

[neil]

@dodicat
Very nice demo.

I have seen bit mapping stored using data statements.
I am trying to figure out how you are doing it. with const as string leaf = _
Whats going on with this?

const as string leaf = _
"s1C4278241280BM15,07M+-16,14M+2,9M+-4,10M+-6,8M+1,6"_
&"M+11,11M+-2,13M+-5,12M+-10,9M+-7,11M+-9,11"_