window fill via pointer

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

window fill via pointer

Post by dafhi »

for those wanting to plot pixels with pointer. [example 2 May 17]

version 1 - absolute beginner

Code: Select all

/'  window fill via pointer - 2024 May 16  by dafhi
'/

type t_image_info
  dim as long     w,h, bypp,bpp, pitch,rate
  dim as any ptr  pixels, im
  dim as string   driver_name
end type

  sub _gfx_release( byref i as t_image_info )
    if imageinfo(i.im) = 0 then imagedestroy i.im
    i.im = 0
  end sub

sub get_screen( byref i as t_image_info )
  _gfx_release i
  ScreenInfo i.w, i.h, i.bpp, i.bypp, i.pitch, i.rate, i.driver_name
  i.pixels = screenptr
end sub
  
sub fill( byref i as t_image_info, c as ulong = rgb(255,255,255) )
    for y as long = 0 to i.h - 1
                                   '' y *  bytes per scanline
  var p = cast( ulong ptr, i.pixels + y * i.pitch )
  for x as long = 0 to i.w - 1
  p[x] = c
  next
  next
end sub


screenres 800,600,32

dim as t_image_info buf

get_screen buf

fill buf, rgb(0,0,255)

sleep


example 2 - intermediate level. clipi rects have insane value, easily guarding against pointer errors during development

Code: Select all

/'  clipped window fill via pointer - 2024 May 17  by dafhi

  if you're a beginner, have a look at the For-Next loops in Fill()
  
    update:
    
  added whitespace to make Fill() stand out more
  dark green is new fill color
  
'/

type t_image_info
  dim as long     w,h, bypp,bpp, pitch,rate
  dim as any ptr  pixels, im
  dim as string   driver_name
end type

  sub _gfx_release( byref i as t_image_info )
    if imageinfo(i.im) = 0 then imagedestroy i.im
    i.im = 0
  end sub

sub get_screen( byref i as t_image_info )
  _gfx_release i
  ScreenInfo i.w, i.h, i.bpp, i.bypp, i.pitch, i.rate, i.driver_name
  i.pixels = screenptr
end sub

  type clip_rect field = 2 '' 2 byte alignment
    as short    x, y
    as short    w, h
  end type
  
  #define min( a, b)    iif( (a)<(b), (a), (b) )
  #define max( a, b)    iif( (a)>(b), (a), (b) )
  
  sub _bounds_from_cliprect( byref cr as clip_rect, i as t_image_info, _
    byref x0 as long, byref y0 as long, byref x1 as long, byref y1 as long )
    
    if cr.w < 1 or cr.h < 1 then  cr = type( 0,0, i.w, i.h )
    
    x0 = max( cr.x, 0 )
    y0 = max( cr.y, 0 )
    x1 = min( x0 + cr.w - 1, i.w - 1 )
    y1 = min( y0 + cr.h - 1, i.h - 1 )
  end sub


sub Fill( byref i as t_image_info, c as ulong = rgb(255,255,255), cr as clip_rect = type(0,0,-1,-1) )

  static as long x0,y0,x1,y1, y, x
  _bounds_from_cliprect cr, i, x0,y0,x1,y1  
  
    for y = y0 to y1              ''  y * bytes per scanline
  var p = cast( ulong ptr, i.pixels + y * i.pitch )
    for x = x0 to x1
  p[x] = c
  next
  next

end sub


screenres 800,600,32

dim as t_image_info buf

get_screen buf

var x = 10
var y = 10
var w = buf.w - x * 2
var h = buf.h - y * 2

fill buf, rgb(0,128,0), type<clip_rect>( x,y, w, h )

sleep



- extra .. my new anti-aliased dot.. will probably post in own thread later

Code: Select all

/'  anti-aliased dots - 2024 May 19  by dafhi

  uses 1 sqr() per dot y
  no if's in the render loop
  
  custom RNG boosts performance 10% on my Linux
  check your system:  comment out lines 183, 184

'/

#define dbl  as double '' reduced text
#define sng  as single

function int2float( i as ulongint) dbl
  return i / (2^64 + 2^12)
end function


  namespace rng '' namespace allows local shared variables

dim as ulongint aa = 1, bb, a,b

sub states( a as ulongint = 1, b as ulongint = 0 )
  aa = a
  bb = b
end sub

function valu dbl
  '' https://stackoverflow.com/questions/34426499/what-is-the-real-definition-of-the-xorshift128-algorithm
  a = aa
  b = bb

  aa = b
  a xor= a shl 23
  a xor= a shr 18
  a xor= b
  a xor= b shr  5
  bb = a

  return int2float( a + b )
end function

end namespace '' rng

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


  namespace my_drawspace '' 2024 May 19

type t_image_info
  dim as long     w,h, bypp, pitch,rate
  dim as any ptr  pixels, im
  dim as string   driver_name
end type

  sub _gfx_release( byref i as t_image_info )
    if imageinfo(i.im) = 0 then imagedestroy i.im
    i.im = 0
  end sub

  sub _get_screen( byref i as t_image_info )
    _gfx_release i
    ScreenInfo i.w, i.h, , i.bypp, i.pitch, i.rate, i.driver_name
    i.pixels = screenptr
  end sub

  sub _get_image( byref i as t_image_info, im as any ptr )
    _gfx_release i
    ImageInfo im, i.w, i.h, i.bypp, i.pitch, i.pixels
    i.im = im
  end sub

  dim as t_image_info _im
  
  dim as long             wm, hm


sub render_target( im as any ptr ) '' a main sub
  if im = 0 then
    _get_screen _im
  else
    _get_image _im, im
  endif
  wm = _im.w - 1
  hm = _im.h - 1
end sub

type t_draw_area field = 2 ' 2 byte elems
  dim as short    x0, y0
  dim as short    x1, y1
end type

  sub _calc_cliprect( byref rc as t_draw_area, x as single, y as single, _
    x1 as single, y1 as single )
    rc.x0 = max( 0, x )
    rc.y0 = max( 0, y )
    rc.x1 = min( wm, x1 )
    rc.y1 = min( hm, y1 )
  end sub
  
  function _window_initialized as boolean
    return _im.h > 0
  end function
  
end namespace '' my_drawspace
  
  #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


  namespace my_aadot '' 2024 May 19

dim as long         a, x0, x1
dim as single       sa, x, y, r, rSq, pel_y5, dySq, dx
  
sub _x_intercepts
  dim as single q = sqr( rSq - (y-pel_y5)^2 )
  x0 = max( int(x - q + .5), 0 )
  x1 = min( int(x + q - .5), my_drawspace.wm )
  dySq = (pel_y5 - y)^2
  pel_y5 += 1
end sub

  
  dim as my_drawspace.t_draw_area  rc

sub draw( _x as single = 0, _y as single = 0, _r as single = 50, c as ulong = -1 )

  using my_drawspace
  
  if not _window_initialized then exit sub
  
  x = _x
  y = _y
  r = _r
  
  '' extras to y to prevent oob x0 x1 where radius nearly = y0 or y1
  my_drawspace._calc_cliprect rc,  x-r, y-r+.0001, x+r-1, y+r-1.0001
  
  pel_y5 = rc.y0 + .5
  rSq = r * r
  
  sa = 256.4999 * (255-(c shr 24)) / 255 / rSq
  
    for iy as long = rc.y0 to rc.y1
  _x_intercepts
  var p = cast( ulong ptr, _im.pixels + iy * _im.pitch ) '' pitch = bytes per scanline
    for ix as long = x0 to x1
  dx = (ix+.5 - x)
  a = 256 - sa * (dx*dx + dySq)
  alpha256( p[ix], p[ix], c, a )
  next
  next
  
end sub

end namespace '' my_aadot

  function round(in dbl, places as ubyte = 2) as string
    dim as integer mul = 10 ^ places
    return str(csng( int(in * mul + .5) / mul) )
  End Function



var w = 800
var h = 600

screenres w,h, 32

my_drawspace.render_target 0

dim dbl fps_update_interval = 1
dim dbl fps0,fps1, t,t0=timer,tp
dim dbl t_report_next = t + fps_update_interval

#undef rnd
#define rnd rng.valu

  do
tp = t
t = timer-t0

rng.states 1,0
randomize 0

  
  screenlock
  
line(0,0)-(w,h), rgb(19,19,19), bf
  for i as long = 1 to 9999
var offs = 1.5 + rnd * rnd* 95
var a = rnd*6.28 + t * 1 * (rnd - .5)
#define q rnd*255.4999
  my_aadot.draw _
rnd * w + offs*cos(a), _
rnd * h + offs*sin(a), _
rnd*rnd*rnd*9, rgba(q,q,q,rnd*40)
next

screenunlock


fps0 = fps1
fps1 = 1 / (t - tp)

if t >= t_report_next then
  t_report_next += fps_update_interval
  windowtitle "fps " + round( (fps0 + fps1) / 2, 1 )
endif

if inkey<>"" then end

sleep 5
loop while t < 40


? "fin!"
sleep

Post Reply