Line Benchmark w/o AA

General FreeBASIC programming questions.
UEZ
Posts: 635
Joined: May 05, 2017 19:59
Location: Germany

Line Benchmark w/o AA

Postby UEZ » Apr 25, 2020 21:10

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:

Image

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.
Last edited by UEZ on Apr 29, 2020 9:14, edited 1 time in total.
dafhi
Posts: 1361
Joined: Jun 04, 2005 9:51

Re: Line Benchmark w/o AA

Postby dafhi » Apr 29, 2020 2:59

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
Posts: 635
Joined: May 05, 2017 19:59
Location: Germany

Re: Line Benchmark w/o AA

Postby UEZ » Apr 29, 2020 9:26

dafhi wrote: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
Posts: 1361
Joined: Jun 04, 2005 9:51

Re: Line Benchmark w/o AA

Postby dafhi » Apr 29, 2020 22:17

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
Posts: 1361
Joined: Jun 04, 2005 9:51

Re: Line Benchmark w/o AA

Postby dafhi » May 10, 2020 21:16

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

'/
Last edited by dafhi on May 12, 2020 1:00, edited 2 times in total.
dodicat
Posts: 6718
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Line Benchmark w/o AA

Postby dodicat » May 10, 2020 23:09

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
Posts: 1361
Joined: Jun 04, 2005 9:51

Re: Line Benchmark w/o AA

Postby dafhi » May 10, 2020 23:16

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

Return to “General”

Who is online

Users browsing this forum: No registered users and 4 guests