Line Benchmark w/o AA

[UEZ]

I put some of the line routines together and let them run against each other. The additional line functions don't have out of bounds check nor draw with alpha channel! Thus, the comparison with built-in line function is not really fair.

My result for 2.000.000 lines compiled as x64 using compile parameter -gen gcc -Wc -Ofast -Wc -march=native -Wc -funroll-loops -Wc -mfpmath=sse -s gui:



The code:

Code: Select all

#Include "fbgfx.bi"
#include "string.bi"

Using FB

Const iW = 1200, iH = 600
Dim Shared As Any Ptr pScrn
Dim Shared As ULong Ptr pScrn2

'#Define PixelSet2Scrn(_x, _y, colour)		*Cptr(Ulong Ptr, pScrn + (_y) * pitch + (_x) * imgData) = (colour)

Sub DrawLine0(x0 As Short, y0 As Short, x1 As Short, y1 As Short, col As Ulong) 'built-in line function
	Line(x0, y0)-(x1, y1), Col
End Sub

Sub DrawLine1(x0 As Short, y0 As Short, x1 As Short, y1 As Short, col As Ulong) 'Bresenham Line Algorithm from Wikipedia
	Dim As Short dx = Abs(x1 - x0), dy = -Abs(y1 - y0)
	Dim As Byte sx = Iif(x0 < x1, 1, -1), sy = Iif(y0 < y1, 1, -1)
	Dim As Short ierr = dx + dy, e2
	Do
		'PixelSet2Scrn(x0, y0, col)
		pScrn2[y0 * iW + x0] = col
		If (x0 = x1) Or (y0 = y1) Then Exit Do
		e2 = ierr Shl 1
		If (e2 >= dy) Then 
			ierr += dy
			x0 += sx
		End If
		If (e2 <= dx) Then
			ierr += dx
			y0 += sy
		End If
	Loop
End Sub

Sub DrawLine2(x1 As Short, y1 As Short, x2 As Short, y2 As Short, col As Ulong) 'Bresenham Line Algorithm
	Dim As Short xinc, yinc, x, y, dx, dy, e
	dx = Abs(x2 - x1)
	dy = Abs(y2 - y1)
	If (x1 < x2) Then
		xinc = 1
	Else
		xinc = -1
	End If
	If (y1 < y2) Then
		yinc = 1
	Else
		yinc = -1
	End If	
	x = x1
	y = y1
	'PixelSet2Scrn(x, y, col)
	pScrn2[y * iW + x] = col
	If (dx >= dy) Then
		e = (dy Shl 1) - dx
		While x <> x2
			If e < 0 Then
				e += dy Shl 1
			Else
				e += (dy - dx) Shl 1
				y += yinc
			End If
			x += xinc
			'PixelSet2Scrn(x, y, col)
			pScrn2[y * iW + x] = col
		Wend
	Else
		e = (dx Shl 1) - dy
		While y <> y2
			If e < 0 Then
				e += dx Shl 1
			Else
				e += (dx - dy) Shl 1
				x += xinc
			End If
			y += yinc
			'PixelSet2Scrn(x, y, col)
			pScrn2[y * iW + x] = col
		Wend
	End If
End Sub

Sub DrawLine3(x0 As Short, y0 As Short, x1 As Short, y1 As Short, col As Ulong) 'Xiaolin Wu
	Dim As Boolean steep = Abs(y1 - y0) > Abs(x1 - x0)
	Dim As Short t, dx, dy, e, ya, ys, x, y
	If steep Then
		t = x0 'swap x0, y0
		x0 = y0
		y0 = t
		t = x1 'swap x1, y1
		x1 = y1
		y1 = t
	End If
	If x0 > x1 Then
		t = x0 'swap x0, x1
		x0 = x1
		x1 = t
		t = y0 'swap y0, y1
		y0 = y1
		y1 = t
	End If
	dx = x1 - x0
	dy = Abs(y1 - y0)
	e = dx Shr 1
	ys = Iif(y0 < y1, 1, -1)
	y = y0
	For x = x0 To x1
		If steep Then
			'PixelSet2Scrn(y, x, col)
			pScrn2[x * iW + y] = col
		Else
			'PixelSet2Scrn(x, y, col)
			pScrn2[y * iW + x] = col
		End If
		e -= dy
		If e < 0 Then
			y += ys
			e += dx
		End If
	Next
End Sub

'http://www.edepot.com/linee.html (Extremely Fast Line Algorithm Variation E)
Sub DrawLine4(x1 As Short, y1 As Short, x2 As Short, y2 As Short, col As Ulong) 'Po-Han Lin
	Dim As Boolean yLonger = False
	Dim As Long shortLen = y2 - y1, longLen = x2 - x1, decInc = 0, j, t
	If Abs(shortLen) > Abs(longLen) Then 
		'Swap shortLen, longLen
		
		t = shortLen
		shortLen = longLen
		longLen = t
		
		yLonger = True
	End If
	If longLen <> 0 Then decInc = (shortLen Shl 16) / longLen
	If yLonger Then
		If longLen > 0 Then
			longLen += y1
			j = &h8000 + (x1 Shl 16)
			While y1 <= longLen
				'PixelSet2Scrn(j Shr 16, y1, col)
				pScrn2[y1 * iW + (j Shr 16)] = col
				j += decInc
				y1 += 1
			Wend
			Exit Sub
		End If
		longLen += y1
		j = &h8000 + (x1 Shl 16)
		While y1 >= longLen
			'PixelSet2Scrn(j Shr 16, y1, col)
			pScrn2[y1 * iW + (j Shr 16)] = col
			j -= decInc
			y1 -= 1
		Wend
		Exit Sub
	End If
	If longLen > 0 Then
		longLen += x1
		j = &h8000 + (y1 Shl 16)
		While x1 <= longLen
			'PixelSet2Scrn(x1, j Shr 16, col)
			pScrn2[(j Shr 16) * iW + x1] = col
			j += decInc
			x1 += 1
		Wend
		Exit Sub
	End If
	longLen += x1
	j = &h8000 + (y1 Shl 16)
	While x1 >= longLen
		'PixelSet2Scrn(x1, j Shr 16, col)
		pScrn2[(j Shr 16) * iW + x1] = col
		j -= decInc
		x1 -= 1
	Wend	
End Sub



Sub Benchmark(LineFn As Sub(x0 As Short = 0, y0 As Short = 0, x1 As Short = 0, y1 As Short = 0, col As Ulong = 0), l As Integer)
	Dim As Ushort x1, y1, x2, y2
	Dim As Ulong col
	For i As Integer = 1 To l
		x1 = Rnd() * (iW - 1)
		y1 = Rnd() * (iH - 1)
		x2 = Rnd() * (iW - 1)
		y2 = Rnd() * (iH - 1)
		col = Rnd() * &hFFFFFF
		LineFn(x1, y1, x2, y2, &hFF000000 Or col)
	Next	
End Sub

Screenres iW, iH, 32, 2, GFX_WINDOWED Or GFX_NO_SWITCH Or GFX_ALWAYS_ON_TOP Or GFX_ALPHA_PRIMITIVES
ScreenSet 1, 0

Windowtitle("Line Benchmark")

pScrn = Screenptr()
pScrn2 = Screenptr()

Const iFn = 5
Dim As Integer i, l = 2000000
Dim As Double fTimer
Randomize Timer, 2
Dim As Double aResult(iFn - 1)

For i = 0 To iFn - 1
	Windowtitle("Running function " & Str(i) & " with " & Format(l, "###,###,###,###") & " lines.")
	Cls
	fTimer = Timer
	Select Case i 
		Case 0
			Benchmark(@DrawLine0, l)
		Case 1
			Benchmark(@DrawLine1, l)
		Case 2
			Benchmark(@DrawLine2, l)
		Case 3
			Benchmark(@DrawLine3, l)
		Case 4
			Benchmark(@DrawLine4, l)
		Case 5 
	End Select
	aResult(i) = (Timer - fTimer) * 1000
	Flip
Next

? "Result for " & Format(l, "###,###,###,###") & " lines:" : ?
For i = 0 To iFn - 1
	? "Function " & i & ": " & aResult(i) & " ms"
Next
Flip

Do
	Sleep(10, 1)
Loop Until Len(Inkey())

Feel free to post your line function code here.

[dafhi]

I'm sure you know only FB Line does not crash out of bounds.

I might have a go at this. From my AA I recall having a set of 'virtual' dimension variables which i swap if dx < dy, as seen from drawline4

here's what i have so far

Code: Select all

#undef int
#define def   #define

def int     as Integer
def sng     as single


  namespace myline
  
/' -- usage

  using myline
 
  render_target img ' 0 for screen
  
  draw 0,0,50,10, rgb(255,255,255)
  
'/

type virt_xy
  int   min, max
  int   pitch = 1
  sng   delta
End Type

dim as virt_xy  vx
dim as virt_xy  vy

'' function call completeness
dim int         bpp, bypp, rate, size_bytes
dim as string   driver_info
dim as any ptr     pixels

dim as ulong ptr   p32


function valid int:  return bypp = 4
End Function

sub render_target(im as any ptr = 0)
  if im=0 then
    screeninfo vx.max, vy.max, bpp, bypp, vy.pitch, rate, driver_info
    pixels = screenptr
  else
    imageinfo im, vx.max, vy.max, bypp, vy.pitch, pixels, size_bytes
    bpp = bypp * 8
  endif:  p32 = pixels
End Sub

sub draw(x0 sng, y0 sng, x1 sng, y1 sng, col as ulong = -1)
  if not valid then exit sub
  
  vx.delta = x1 - x0
  vy.delta = y1 - y0
  if abs(vx.delta) < abs(vy.delta) then swap vx, vy
  
  
End Sub
  
End Namespace

[UEZ]

I'm sure you know only FB Line does not crash out of bounds.

Yes, of course and the comparison is not really fair because the additional draw functions don't have additional boundary check nor alpha channel is not added.

How can I use your code properly?

[dafhi]

I suppose i should shut my trap and wait till i have something complete =)

Clean, efficient bounds checks for me will be the next step. I'm usually playing video games but when I have a-ha moments I can plow through code quickly

[dafhi]

finally got it

Code: Select all

/' -- line-rect clipper 2020 May 11 - by dafhi --

 updates
auto exit @1 min 
unused vars wm hm
moved namespace 'slope' after subs that don't use
simplified clip and clip_hypervisor
renamed loopstart to loop_positive

'/

#undef int
#define def   #define

def int       as Integer
def sng       as single

def ret       return
def func      function

def br        byref


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

def EPS       .001


  namespace myline
 
'' FB Image data
dim int           w, h, bpp, bypp, pitch, rate, size_bytes
dim as string     driver_info
dim as any ptr    pixels

'' helpers
dim as ulong ptr  p32
dim int           pitchBy


type rect
  int             x,y,w,h
End Type

dim as rect       rect


sub render_target(im as any ptr = 0)
  if im=0 then
    screeninfo w, h, bpp, bypp, pitch, rate, driver_info
    pixels = screenptr
  else
    imageinfo im, w, h, bypp, pitch, pixels, size_bytes
    bpp = bypp * 8
  endif
  p32 = pixels
  pitchBy = pitch \ bypp
  rect.x = 0:  rect.w = w
  rect.y = 0:  rect.h = h
End Sub


func valid_surface int
  return bypp = 4
End Func


sub clip( _
    br ret_a sng, br ret_b sng, _
    point_xor_edge0 sng, _
    point_xor_edge1 sng, _
    edge int, _slope sng)
 
    if point_xor_edge0 <= point_xor_edge1 then
     
      static sng a:  a = ret_a
     
      '' if point x or y lands on edge right or top, clip extra
      ret_a = edge + EPS * (point_xor_edge0 = edge)
   
      ret_b += (ret_a - a) * _slope
    EndIf
End Sub


sub clip_hypervisor( _
    br a0 sng, br a1 sng, _
    br b0 sng, br b1 sng, _
    rc_a0 int, rc_a1 int, _
    slope sng, loop_positive_p0 int )
   
  if loop_positive_p0 then
    clip a0, b0, a0, rc_a0, rc_a0, slope
    clip a1, b1, rc_a1, a1, rc_a1, slope
  else
    clip a1, b1, a1, rc_a0, rc_a0, slope
    clip a0, b0, rc_a1, a0, rc_a1, slope
  endif
End Sub


dim sng   slope

func axis_aligned( _
    br a0 sng, br a1 sng, _
    br b0 sng, br b1 sng, _
    rc_a0 int, rc_a1 int, _
    rc_b0 int, rc_b1 int) int
 
  if b0 <> b1 then ret false
 
  slope = 0 '' global
  if b0 < rc_b0 orelse b0 >= rc_b1 then a0 = a1+1: ret true '' no-loop condition
 
  clip_hypervisor a0, a1, b0, b1, rc_a0, rc_a1, slope, a0 <= a1
 
  ret true
 
End Func


sub major_axis_hypervisor( br a0 sng, br a1 sng, _
                           br b0 sng, br b1 sng, _
                           rc_a0 int, rc_a1 int, _
                           rc_b0 int, rc_b1 int )
 
  if axis_aligned(a0, a1, b0, b1, rc_a0, rc_a1, rc_b0, rc_b1) then exit sub
 
  slope = (b1 - b0) / (a1 - a0)
 
  dim int loop_positive_p0 = a0 <= a1
 
  clip_hypervisor a0, a1, b0, b1, rc_a0, rc_a1, slope, loop_positive_p0
 
  static sng islope:  islope = (a1 - a0) / (b1 - b0)
  if islope > 0 then
    clip_hypervisor b0, b1, a0, a1, rc_b0, rc_b1, islope, loop_positive_p0
  else
    clip_hypervisor b1, b0, a1, a0, rc_b0, rc_b1, islope, loop_positive_p0
  endif

end sub


sub draw(x0 sng, y0 sng, x1 sng, y1 sng, col as ulong = -1, rec as rect ptr = 0)

  if not valid_surface then exit sub
 
  if rec <> 0 then rect = *rec
 
  static sng dx, dy
 
  dx = x1 - x0
  dy = y1 - y0
 
  if abs(dx) > abs(dy) then
    major_axis_hypervisor x0, x1, y0, y1, rect.x, rect.x+rect.w, rect.y, rect.y+rect.h
    for x sng = x0 to x1 step sgn(dx)
      dim int y = floor(y0 + slope * (x - x0))
      p32[y * pitchBy + floor(x)] = col
    next
  else
    major_axis_hypervisor y0, y1, x0, x1, rect.y, rect.y+rect.h, rect.x, rect.x+rect.w
    for y sng = y0 to y1 step sgn(dy)
      dim int x = floor(x0 + slope * (y - y0))
      p32[floor(y) * pitchBy + x] = col
    next
  EndIf
 
End Sub
 
End Namespace


sub Main
 
  var w = 640
  var h = 480
 
  screenres w,h, 32
 
  var wm = w-1, hm = h-1
  var wh = w/2, hh = h/2
 
  myline.render_target 0
 
  ' Animate
  var r = sqr(w*w+h*h)*.25, a = 3.14159*.76, ia = .005

  var speed = 12
 
  const           tDemoMinutes = 1
 
  var             tp = timer
  var             tProgExit        = tp+tDemoMinutes*60
 
  while inkey=""
      #define showx(x,y) myline.draw (x), (y), (x)+r*cos(a), (y)
      #define showy(x,y) myline.draw (x), (y), (x), (y)+r*sin(a)
      #define show(x,y) myline.draw (x), (y), (x)+r*cos(a), (y)+r*sin(a)
      screenlock
        cls
        var k = 10
        showx(wh, hh)
        showy(wh, hh)
        #if 1
        show( -k,-k )
        show( k,k )
        show( wm-k,k )
        show( wm+k,-k )
        show( -k,hm+k )
        show( +k,hm-k )
        show( wm+k,hm+k )
        show( wm-k,hm-k )
        #endif
      screenunlock
      var t=timer, dt=t-tp
      sleep 50
      var kstr = inkey
      if t>=tProgExit or kstr=chr(27) then
        ? "demo finished .. exiting ..": sleep 650
        exit while
      end if
      a += ia * speed
  wend

end sub

Main


/' ---------- reference -------------------

            i, i, i  , i   , i    , i   , str
ScreenInfo  w, h, bpp, bypp, pitch, rate, driver_info

            any  , i  i, i   , i    , any   , i  .... (any = any ptr)
ImageInfo(  img  , w, h, bypp, pitch, pixels, size_bytes) int

            i, i, ul   , i
ImageCreate(w, h, color, bpp) as any ptr

            i, i, i  , i       , i    , i
ScreenRes(  w, h, bpp, numPages, flags, refresh_rate) int
ScreenSet   work_page, visible_page

'/

[dodicat]

This one isn't very fast.

Code: Select all

Type d2
    As Single x,y 
End Type

Sub fill(p() As d2,c As Ulong,im As Any Ptr=0)
    #define ub Ubound
    Dim As Long Sy=1e6,By=-1e6,i,j,y,k
    Static As Single a(Ub(p)+1,1),dx,dy
    For i =0 To Ub(p)
        a(i,0)=p(i).x
        a(i,1)=p(i).y
        If Sy>p(i).y Then Sy=p(i).y
        If By<p(i).y Then By=p(i).y
    Next i
    Static As Single xi(Ub(a,1)),S(Ub(a,1))
    a(Ub(a,1),0) = a(0,0)
    a(Ub(a,1),1) = a(0,1)
    For i=0 To Ub(a,1)-1
        dy=a(i+1,1)-a(i,1)
        dx=a(i+1,0)-a(i,0)
        If dy=0 Then S(i)=1
        If dx=0 Then S(i)=0
        If dy<>0 Andalso dx<>0 Then S(i)=dx/dy
    Next i
    For y=Sy-1 To By+1
        k=0
        For i=0 To Ub(a,1)-1
            If (a(i,1)<=y Andalso a(i+1,1)>y) Orelse _
            (a(i,1)>y Andalso a(i+1,1)<=y) Then
            xi(k)=(a(i,0)+S(i)*(y-a(i,1)))
            k+=1
        End If
    Next i
    For j=0 To k-2
        For i=0 To k-2
            If xi(i)>xi(i+1) Then Swap xi(i),xi(i+1)
        Next i
    Next j
    For i = 0 To k - 2 Step 2
        Line im,(xi(i),y)-(xi(i+1)+1,y),c
    Next i
Next y
End Sub

Sub tessilate(r As Single,xp as long,yp as long,col As ULong,im as any ptr=0)
    Dim As Integer xres,yres
    Screeninfo xres,yres
    ReDim As d2 pts()
    'Dim As Single f=r/xres
    For y As Long=-2*r To yres+2*r
    Next y
    #macro _hex(p,r)
    Scope
        Dim flag As Byte
        Dim As Single lastx,lasty ,ctr =-1
        For z As Single=0 To 360 Step 360/6
            Var x=p.x+r*Cos(z*.0174533)
            Var y=p.y+r*Sin(z*.0174533)
            ctr+=1    
            If ctr>6 Then Exit for
             ReDim Preserve pts(0 To ctr)
         pts(ctr)=Type(x,y)
        Next z
        fill(pts(),RGB(Rnd*255,Rnd*255,Rnd*255),im)
    End Scope
    #endmacro
    Dim As d2 pt
    Dim As Single x,y,z
    Dim As Long k=1
    For x =-2*r To xres+2*r Step r+r/2
        var h=.86603*r/2
        z=h*k
        For y =z To yres+2*r Step Sqr(3)*r
            pt=Type<d2>(x,y)
            _hex(pt,r)
        Next y
        k=-k
    Next x
End Sub

#define putpixel(_x,_y,colour)    *cptr(ulong ptr,row+ (_y)*pitch+ (_x) shl 2)  =(colour)
#define getpixel(_x,_y)           *cptr(ulong ptr,row + (_y)*pitch + (_x) shl 2)

Dim Shared As Any Ptr row
Dim Shared As Integer pitch
dim shared as integer w,h

Sub putpixelalpha(x As Long,y As Long,col As Ulong)
    Dim As Ubyte r=Cast(Ubyte Ptr,@col)[0],g=Cast(Ubyte Ptr,@col)[1],b=Cast(Ubyte Ptr,@col)[2],al=Cast(Ubyte Ptr,@col)[3]
    Dim As Ulong bck=getpixel(x,y)
    Dim As Ubyte br=Cast(Ubyte Ptr,@bck)[0],bg=Cast(Ubyte Ptr,@bck)[1],bb=Cast(Ubyte Ptr,@bck)[2]
    Dim As Single a=al/255
    r=a*r +(1-a)*br
    g=a*g +(1-a)*bg
    b=a*b +(1-a)*bb
    putpixel(x,y,Rgb(b,g,r))
End Sub

 Sub plot(x As Long,y As Long,c As Single,col As Ulong)
        dim as ubyte ptr u=cptr(ubyte ptr,@col)
        u[3]=u[3]*c
        if x>=0 andalso x<w andalso y>=0 andalso y<h then
            putpixelalpha(x,y,col)
     end if
        
    End Sub

sub drawLine(x0 As long,y0 As long,x1 As long,y1 As long,col As Ulong)
    #define ipart(x) Int((x))
    #define round(x) ipart((x) + 0.5)
    #define fpart(x) Frac((x))
    #define rfpart(x) 1-fpart((x))
   Dim As boolean steep = Abs(y1 - y0) > Abs(x1 - x0)
    
    If steep Then
        Swap x0, y0
        Swap x1, y1
    End If
    If x0 > x1 Then
        Swap x0, x1
        Swap y0, y1
    End If
    
   Dim As long dx = x1 - x0
   Dim As long dy = y1 - y0
   Var gradient = dy / dx
    If dx = 0 Then
        gradient = 1
    End If

    '// handle first endpoint
   Dim As long xend = round(x0)
   Dim As long  yend = y0 + gradient * (xend - x0)
   Dim As Single xgap = rfpart(x0 + 0.5)
   Dim As long  xpxl1 = xend '// this will be used in the main loop
   Dim As long ypxl1 = ipart(yend)
    If steep Then
        plot(ypxl1,   xpxl1, rfpart(yend) * xgap,col)
        plot(ypxl1+1, xpxl1,  fpart(yend) * xgap,col)
    Else
        plot(xpxl1, ypxl1  , rfpart(yend) * xgap,col)
        plot(xpxl1, ypxl1+1,  fpart(yend) * xgap,col)
    End If
   
    Dim As Single intery = yend + gradient '// first y-intersection for the main loop
    
    '// handle second endpoint
    xend = round(x1)
    yend = y1 + gradient * (xend - x1)
    xgap = fpart(x1 + 0.5)
    Dim As long xpxl2 = xend '//this will be used in the main loop
    Dim As long ypxl2 = ipart(yend)
    If steep Then
        plot(ypxl2  , xpxl2, rfpart(yend) * xgap,col)
        plot(ypxl2+1, xpxl2,  fpart(yend) * xgap,col)
    Else
        plot(xpxl2, ypxl2,  rfpart(yend) * xgap,col)
        plot(xpxl2, ypxl2+1, fpart(yend) * xgap,col)
    End If
   
    '// main loop
    If steep Then
        For x As long = xpxl1 + 1 To xpxl2 - 1 
                plot(ipart(intery)  , x, rfpart(intery),col)
                plot(ipart(intery)+1, x,  fpart(intery),col)
                intery = intery + gradient
           Next
    Else
        For x As long = xpxl1 + 1 To xpxl2 - 1 
                plot(x, ipart(intery),  rfpart(intery),col)
                plot(x, ipart(intery)+1, fpart(intery),col)
                intery = intery + gradient
           Next
    End If
End sub

Sub LineByAngle(x As Long,y As Long,angle As Single,length As Single,col As Ulong,Byref x2 As Long=0,Byref y2 As Long=0,f As Long=0)
    x2=x+length*Cos(angle)
    y2=y-length*Sin(angle)
    drawline(x,y,x2,y2,col)
End Sub

screen 20,32
Dim As Any Ptr i=ImageCreate(1024,768)
Randomize 1
tessilate(100,1024/2+10,768/2+25,RGB(0,200,0),i)

row=Screenptr
Screeninfo w,h,,,pitch
dim as single a
const pi=4*atn(1)
Do
	Randomize 1
  a+=.002
ScreenLock
Cls
Put(0,0),i,pset
for n as single=0 to 2*pi step 2*pi/60
  linebyangle 1024\2,768\2,a+n,360,rgb(50+rnd*205,50+rnd*205,50+rnd*205)
  next
ScreenUnLock
sleep 1,1
loop until inkey=chr(27)
sleep
 

[dafhi]

it's gorgeous =) i must do some tests

75% improvement w/ Alpha256 [update 2]

Code: Select all

#define def #define

#undef int

def int as integer
def sng as single
def dbl as double

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


Type d2
    As Single x,y
End Type

Sub fill(p() As d2,c As Ulong,im As Any Ptr=0)
    #define ub Ubound
    Dim As Long Sy=1e6,By=-1e6,i,j,y,k
    Static As Single a(Ub(p)+1,1),dx,dy
    For i =0 To Ub(p)
        a(i,0)=p(i).x
        a(i,1)=p(i).y
        If Sy>p(i).y Then Sy=p(i).y
        If By<p(i).y Then By=p(i).y
    Next i
    Static As Single xi(Ub(a,1)),S(Ub(a,1))
    a(Ub(a,1),0) = a(0,0)
    a(Ub(a,1),1) = a(0,1)
    For i=0 To Ub(a,1)-1
        dy=a(i+1,1)-a(i,1)
        dx=a(i+1,0)-a(i,0)
        If dy=0 Then S(i)=1
        If dx=0 Then S(i)=0
        If dy<>0 Andalso dx<>0 Then S(i)=dx/dy
    Next i
    For y=Sy-1 To By+1
        k=0
        For i=0 To Ub(a,1)-1
            If (a(i,1)<=y Andalso a(i+1,1)>y) Orelse _
            (a(i,1)>y Andalso a(i+1,1)<=y) Then
            xi(k)=(a(i,0)+S(i)*(y-a(i,1)))
            k+=1
        End If
    Next i
    For j=0 To k-2
        For i=0 To k-2
            If xi(i)>xi(i+1) Then Swap xi(i),xi(i+1)
        Next i
    Next j
    For i = 0 To k - 2 Step 2
        Line im,(xi(i),y)-(xi(i+1)+1,y),c
    Next i
Next y
End Sub

Sub tessilate(r As Single,xp as long,yp as long,col As ULong,im as any ptr=0)
    Dim As Integer xres,yres
    Screeninfo xres,yres
    ReDim As d2 pts()
    'Dim As Single f=r/xres
    For y As Long=-2*r To yres+2*r
    Next y
    #macro _hex(p,r)
    Scope
        Dim flag As Byte
        Dim As Single lastx,lasty ,ctr =-1
        For z As Single=0 To 360 Step 360/6
            Var x=p.x+r*Cos(z*.0174533)
            Var y=p.y+r*Sin(z*.0174533)
            ctr+=1   
            If ctr>6 Then Exit for
             ReDim Preserve pts(0 To ctr)
         pts(ctr)=Type(x,y)
        Next z
        fill(pts(),RGB(Rnd*255,Rnd*255,Rnd*255),im)
    End Scope
    #endmacro
    Dim As d2 pt
    Dim As Single x,y,z
    Dim As Long k=1
    For x =-2*r To xres+2*r Step r+r/2
        var h=.86603*r/2
        z=h*k
        For y =z To yres+2*r Step Sqr(3)*r
            pt=Type<d2>(x,y)
            _hex(pt,r)
        Next y
        k=-k
    Next x
End Sub

#define putpixel(_x,_y,colour)    *cptr(ulong ptr,row+ (_y)*pitch+ (_x) shl 2)  =(colour)
#define getpixel(_x,_y)           *cptr(ulong ptr,row + (_y)*pitch + (_x) shl 2)

Dim Shared As Any Ptr row
Dim Shared As Integer pitch
dim shared as integer w,h

Sub putpixelalpha(x As Long,y As Long,col As Ulong)
    Dim As Ubyte r=Cast(Ubyte Ptr,@col)[0],g=Cast(Ubyte Ptr,@col)[1],b=Cast(Ubyte Ptr,@col)[2],al=Cast(Ubyte Ptr,@col)[3]
    Dim As Ulong bck=getpixel(x,y)
    Dim As Ubyte br=Cast(Ubyte Ptr,@bck)[0],bg=Cast(Ubyte Ptr,@bck)[1],bb=Cast(Ubyte Ptr,@bck)[2]
    Dim As Single a=al/255
    r=a*r +(1-a)*br
    g=a*g +(1-a)*bg
    b=a*b +(1-a)*bb
    putpixel(x,y,Rgb(b,g,r))
End Sub

#Macro Alpha256(ret, back, fore, a256) '2020 Jan 27
  scope
    static int aaa: aaa = (a256)
    ret=((_
    (fore And &Hff00ff) * aaa + _
    (back And &Hff00ff) * ( 256 - aaa ) + &H800080) And &Hff00ff00 Or (_
    (fore And &H00ff00) * aaa + _
    (back And &H00ff00) * ( 256 - aaa ) + &H008000) And &H00ff0000) Shr 8
  end scope
#EndMacro
 
 Sub plot(x As Long,y As Long,c As Single,col As Ulong)
        'dim as ubyte ptr u=cptr(ubyte ptr,@col)
        'u[3]=u[3]*c
        static as ulong ptr pixel
        static as integer   alp
        const sng   a_scalar = 256.999 / 255
        if x>=0 andalso x<w andalso y>=0 andalso y<h then
            pixel = cptr(ulong ptr,row + (y)*pitch + (x) shl 2)
            'alp = (256 * (col shr 24) + &H80) \ 255
            alp = floor(a_scalar * c * (col shr 24))
            'putpixelalpha(x,y,col)
            Alpha256(*pixel,*pixel,col,alp)
            
     end if
       
    End Sub

sub drawLine(x0 As long,y0 As long,x1 As long,y1 As long,col As Ulong)
    ''#define ipart(x) Int((x))
    def ipart(x)  floor(x)
    
    #define round(x) ipart((x) + 0.5)
    #define fpart(x) Frac((x))
    #define rfpart(x) 1-fpart((x))
   Dim As boolean steep = Abs(y1 - y0) > Abs(x1 - x0)
   
    If steep Then
        Swap x0, y0
        Swap x1, y1
    End If
    If x0 > x1 Then
        Swap x0, x1
        Swap y0, y1
    End If
   
   Dim As long dx = x1 - x0
   Dim As long dy = y1 - y0
   Var gradient = dy / dx
    If dx = 0 Then
        gradient = 1
    End If

    '// handle first endpoint
   Dim As long xend = round(x0)
   Dim As long  yend = y0 + gradient * (xend - x0)
   Dim As Single xgap = rfpart(x0 + 0.5)
   Dim As long  xpxl1 = xend '// this will be used in the main loop
   Dim As long ypxl1 = ipart(yend)
    If steep Then
        plot(ypxl1,   xpxl1, rfpart(yend) * xgap,col)
        plot(ypxl1+1, xpxl1,  fpart(yend) * xgap,col)
    Else
        plot(xpxl1, ypxl1  , rfpart(yend) * xgap,col)
        plot(xpxl1, ypxl1+1,  fpart(yend) * xgap,col)
    End If
   
    Dim As Single intery = yend + gradient '// first y-intersection for the main loop
   
    '// handle second endpoint
    xend = round(x1)
    yend = y1 + gradient * (xend - x1)
    xgap = fpart(x1 + 0.5)
    Dim As long xpxl2 = xend '//this will be used in the main loop
    Dim As long ypxl2 = ipart(yend)
    If steep Then
        plot(ypxl2  , xpxl2, rfpart(yend) * xgap,col)
        plot(ypxl2+1, xpxl2,  fpart(yend) * xgap,col)
    Else
        plot(xpxl2, ypxl2,  rfpart(yend) * xgap,col)
        plot(xpxl2, ypxl2+1, fpart(yend) * xgap,col)
    End If
   
    '// main loop
    If steep Then
        For x As long = xpxl1 + 1 To xpxl2 - 1
                plot(ipart(intery)  , x, rfpart(intery),col)
                plot(ipart(intery)+1, x,  fpart(intery),col)
                intery = intery + gradient
           Next
    Else
        For x As long = xpxl1 + 1 To xpxl2 - 1
                plot(x, ipart(intery),  rfpart(intery),col)
                plot(x, ipart(intery)+1, fpart(intery),col)
                intery = intery + gradient
           Next
    End If
End sub

Sub LineByAngle(x As Long,y As Long,angle As Single,length As Single,col As Ulong,Byref x2 As Long=0,Byref y2 As Long=0,f As Long=0)
    x2=x+length*Cos(angle)
    y2=y-length*Sin(angle)
    drawline(x,y,x2,y2,col)
End Sub

screen 20,32
Dim As Any Ptr i=ImageCreate(1024,768)
Randomize 1
tessilate(100,1024/2+10,768/2+25,RGB(0,200,0),i)

row=Screenptr
Screeninfo w,h,,,pitch
dim as single a
const pi=4*atn(1)

  var   iphys_fps = 1/89, phys_t = 0f
  var   ianim_fps = 1/24, anim_t = 0f
  
  const           tDemoMinutes = 1
  
  var             tp = timer
  var             tProgExit        = tp+tDemoMinutes*60
  
  dim             sng fps, fps_update_interval = 1
  
  dim as integer  frame


Do
   Randomize 1
  a+=.002
    if anim_t<=0 then
        ScreenLock
      Cls
      Put(0,0),i,pset
      var t0 = timer
      for n as single=0 to 2*pi step 2*pi/60
        linebyangle 1024\2,768\2,a+n,360,rgb(50+rnd*205,50+rnd*205,50+rnd*205)
        next
      frame+=1
      static sng render_ms
      if fps_update_interval <= 0 then
         fps = frame
         frame=0
         fps_update_interval = 1
         render_ms = timer-t0
      EndIf
      ? "fps "; fps
      ? "render speed "; 1/render_ms
      ScreenUnLock
      while anim_t<0:  anim_t+=ianim_fps:  wend
    endif
    
    var t=timer, dt=t-tp
    tp=t
  
    fps_update_interval -= dt
   
    anim_t -= dt
    phys_t += dt

    var rate = pi*iphys_fps*.6
    while phys_t>0
       a += .002 * rate
      phys_t -= iphys_fps
    wend
    
    var kstr = inkey
       
    if t>=tProgExit or kstr=chr(27) then
      ? "demo finished .. exiting ..": sleep 650
      exit do
    end if
    
sleep 1,1
loop until inkey=chr(27)
'sleep