Fast polygone and triangle BPP 8,15,16,24,32

Post your FreeBASIC tips and tricks here. Please don’t post your code without including an explanation.
D.J.Peters
Posts: 8023
Joined: May 28, 2005 3:28
Contact:

Fast polygone and triangle BPP 8,15,16,24,32

Postby D.J.Peters » May 01, 2006 9:21

fast polygone and triangle (no assembler)
new RGB macros for 8,15,16 color depth

Joshy

Code: Select all

#define scr_w  640
#define scr_h  480
#define scr_b    8 ' 8,15,16,24 or 32

#define SHIFTS   8 ' 24:8 fixed point format

#if (scr_b=8)
  type pixel as ubyte
  #undef RGB
  #define RGB(r,g,b) ((r and &HE0) or ((g and &HE0) shr 3) or ((b and &HC0) shr 6))
  sub Palette332()
    dim as integer i,r,g,b
    for i = 0 to 255
      r=(((i shr 5) and &H07) * 255) / 7
      g=(((i shr 2) and &H07) * 255) / 7
      b=(((i shr 0) and &H03) * 255) / 3
      palette i,r,g,b
    next
  end sub 
#elseif (scr_b=15) or (scr_b=16)
  type pixel as ushort
  #undef RGB
  #define RGB(r,g,b) (((r shr 3) shl 11) or ((g shr 2) shl 5) or (b shr 3))
#elseif (scr_b=24) or (scr_b=32)
  type pixel as ulong
#else
  #error bits per pixel (scr_b) must be 8,15,16,24 or 32
#endif

type screen2d
  as integer x,y
end type

Sub Polygone(d   As pixel Ptr, _ ' screen ptr
             p() As screen2d , _ ' the coords (x,y)
             n   As Integer  , _ ' how many coords in array
             c   As pixel    , _ ' fillcolor
             b   As pixel  =0, _ ' optional bordercolor
             u   as integer=0)   ' optional use bordercolor
  #define mr 1000000
  Dim As Integer   f  =any,ty =any,by=any,l  =any,r=any
  Dim As Integer   lc =any,nlc=any,rc=any,nrc=any
  Dim As integer   d1 =any,s1 =any,d2=any,s2 =any,cl=any,cr=any
  Dim As pixel ptr row=any,cstart=any,cend=any
  n-=1:If n<2 Then Exit Sub
  ty=mr:by=-mr:l=mr:r=-mr
  For nc as integer=0 To n
    With p(nc)
      If .y<ty Then ty=.y:f=nc
      If .y>by Then by=.y
      If .x<l  Then l=.x
      If .x>r  Then r=.x
    End With
  Next
  ' clip
  If l>=scr_w     Then Exit Sub
  If r<1          Then Exit Sub
  If ty>=scr_h    Then Exit Sub
  If by<0         Then Exit Sub
  If (r-l)<1      Then Exit Sub
  If by>=scr_h    Then by=scr_h-1
  If (by-ty)<1    Then Exit Sub

  lc=f:nlc=lc-1:If nlc<0 Then nlc=n
  rc=f:nrc=rc+1:If nrc>n Then nrc=0
  If p(nlc).x>p(nrc).x Then Exit Sub
 
  row=d+ty*scr_w
  While ty<by
    If ty=p(lc).y Then
      While p(lc).y=p(nlc).y
        lc=nlc:nlc-=1:If nlc<0 Then nlc=n
      Wend
      d1=p(lc).x shl SHIFTS
      s1=((p(nlc).x-p(lc).x) shl SHIFTS)/(p(nlc).y-p(lc).y)
      lc = nlc
    End If
    If ty=p(rc).y Then
      While p(rc).y=p(nrc).y
        rc=nrc:nrc+=1:If nrc>n Then nrc=0
      Wend
      d2=p(rc).x shl SHIFTS
      s2=((p(nrc).x-p(rc).x) shl SHIFTS)/(p(nrc).y-p(rc).y)
      rc=nrc
    End If

    If ty<0     Then Goto next_filled_scanline
    l=d1 shr SHIFTS:r=d2 shr SHIFTS
    if l>r      Then swap l,r
    if l>=scr_w Then Goto next_filled_scanline
    If r<0      Then Goto next_filled_scanline
    cl=0:cr=0 ' reset clipflag
    If l<0      Then l=0      :cl=1
    if r>=scr_w Then r=scr_w-1:cr=1
   
    cstart=row+l ' first pixel
    cend  =row+r ' last pixel
    ' use border
    if u then
      if cl=0 then *cstart=b:cstart+=1
      if cr=0 then *cend  =b
    end if
    while cstart<cend:*cstart=c:cstart+=1:wend
    next_filled_scanline:
    ty+=1:d1+=s1:d2+=s2:row+=scr_w
  Wend
End Sub

sub triangle(d   as pixel ptr, _
             p() as screen2d , _
             c   as pixel    , _ ' fillcolor
             b   as pixel=0  , _ ' optional bordercolor
             u   as integer=0)   ' optional use bordercolor
  dim as integer   yt =any,yb=any,l=any,r=any
  dim as integer   d1 =any,d2=any,s1=any,s2=any,cl=any,cr=any
  dim as pixel ptr row=any,cstart=any,cend=any
  dim as screen2d  v0 =any,v1=any,v2=any
  v0=p(0):v1=p(1):v2=p(2)
  if (v1.y>v2.y) then swap v1,v2
  if (v0.y>v2.y) then swap v0,v2
  if (v0.y>v1.y) then swap v0,v1
  if (v2.y=v0.y) then return
  s1=((v2.x-v0.x) shl SHIFTS)/(v2.y-v0.y)
  d1=v0.x shl SHIFTS
  for i as integer=0 to 1
    s2=((v1.x-v0.x) shl SHIFTS)/(v1.y-v0.y)
    d2=v0.x shl SHIFTS
    yt=v0.y
    ' begin in first row
    if yt<0 then
      d1-=s1*yt
      d2-=s2*yt
      yt=0
    end if
    yb=v1.y
    ' end in last row
    if yb>=scr_h then yb=scr_h-1
    if yb<=yt    then goto next_triangle
    row=d+yt*scr_w ' first row
    yb-=yt ' how many scanlines
    ' from top to bottom
    while yb
      l=d1 shr SHIFTS:r=d2 shr SHIFTS
      if l>r      then swap l,r
      if l>=scr_w then goto next_scanline
      if r<1      then goto next_scanline
      cl=0:cr=0   ' reset clipflag
      if l<0      then l=0    :cl=1
      if r>=scr_w then r=scr_w:cr=1
      cstart=row+l ' first pixel
      cend  =row+r ' last  pixel
      if u then ' use border
        if cl=0 then *cstart=b:cstart+=1
        if cr=0 then *cend  =b
      end if
      while cstart<cend:*cstart=c:cstart+=1:wend
      next_scanline:
      d1+=s1:d2+=s2:row+=scr_w:yb-=1
    wend
    next_triangle:
    d1= (v0.x shl SHIFTS)+((v1.y-v0.y)*s1)
    v0=v1:v1=v2
  next
end sub
 
'
' main
'
dim as screen2d t(2),p(9)
dim as pixel   fc,bc ' colors
dim as integer fps,frames,mx,my
dim as single  w1,w2
dim as double  t1,t2

screenres scr_w,scr_h,scr_b,,1
#if scr_b=8
  Palette332
#endif

t1=timer
while inkey=""
  if getmouse(mx,my)=0 then
    screenlock:cls
    for i as integer=0 to 2
      with t(i)
        .x=mx+cos(w1+i*2)*100-100
        .y=my+sin(w1+i*2)*100
      end with
    next
    for i as integer=0 to 9
      with p(i)
        .x=mx+cos(w2+i*0.628)*100+100
        .y=my+sin(w2+i*0.628)*100
      end with
    next
    w1+=0.01:w2-=0.02
    frames+=1

    'polygone screenptr,p(),10,rgb(255,0,0)
    'triangle screenptr,t()   ,rgb(0,0,255)
    polygone screenptr,p(),10,rgb(255,0,0) ,rgb(0,255,0),1
    triangle screenptr,t()   ,rgb(0,0,255) ,rgb(255,255,0),1

    print "fps=" & fps & "   "
    screenunlock
    if frames=100 then
      t2 =timer
      fps=frames/(t2-t1)
      t1 =t2:frames=0
      'sleep 1
    end if
  end if
wend
end
Last edited by D.J.Peters on Sep 28, 2017 15:17, edited 10 times in total.
voodooattack
Posts: 605
Joined: Feb 18, 2006 13:30
Location: Alexandria / Egypt
Contact:

Postby voodooattack » May 01, 2006 12:17

good work :)
looks really cool and yet very fast..

but there's some issue with 32bpp mode when using FillPoly (doesn't occur with linepoly)..
only the leftmost quarter of the screen is drawn..
it must have something to do with the width bounds checking..
i'm sorry i didnt bother to check it my self *gazes at ASM code!* :O

i'm using FB .15b here..

other than that, really amazing mate..
keep up the good work :)
D.J.Peters
Posts: 8023
Joined: May 28, 2005 3:28
Contact:

Postby D.J.Peters » Jul 25, 2007 0:05

Triangle added see first post.
Zamaster
Posts: 1024
Joined: Jun 20, 2005 21:40
Contact:

Postby Zamaster » Jul 25, 2007 1:17

Excellent! Is this fast enough to be a reasonable polyfiller for a 3D engine?
D.J.Peters
Posts: 8023
Joined: May 28, 2005 3:28
Contact:

Postby D.J.Peters » Jul 25, 2007 3:02

next update now with optional bg color and no assembler :-)

Zamaster@
why not if you need only solid colors
for other shades with lights and textures OpenGl is an better choice :-)
D.J.Peters
Posts: 8023
Joined: May 28, 2005 3:28
Contact:

Postby D.J.Peters » Jul 25, 2007 5:00

new RGB macros for 8,15 and 16 bit modes
D.J.Peters
Posts: 8023
Joined: May 28, 2005 3:28
Contact:

Postby D.J.Peters » Oct 24, 2007 20:47

short speed test

Code: Select all

type float as double ' single or double

Randomize Timer
#define scr_w  640
#define scr_h  480
#define scr_b   8 ' 8,15,16,24 or 32

#define SHIFTS   8 ' 24:8 fixed point format

#if (scr_b=8)
  type pixel as ubyte
  #undef RGB
  #define RGB(r,g,b) ((r and &HE0) or ((g and &HE0) shr 3) or ((b and &HC0) shr 6))
  sub Palette332()
    dim as integer i,r,g,b
    for i = 0 to 255
      r=(((i shr 5) and &H07) * 255) / 7
      g=(((i shr 2) and &H07) * 255) / 7
      b=(((i shr 0) and &H03) * 255) / 3
      palette i,r,g,b
    next
  end sub 
#elseif (scr_b=15) or (scr_b=16)
  type pixel as ushort
  #undef RGB
  #define RGB(r,g,b) (((r shr 3) shl 11) or ((g shr 2) shl 5) or (b shr 3))
#elseif (scr_b=24) or (scr_b=32)
  type pixel as ulong
#else
  #error bits per pixel (scr_b) must be 8,15,16,24 or 32
#endif

type vector2d
  as integer x,y
end type
sub triangle(d   as pixel ptr, _
             p() as vector2d , _
             c   as pixel    , _ ' color
             b   as pixel=0  , _ ' optional bordercolor
             u   as integer=0)   ' optional use bordercolor
  dim as integer   yt =any,yb=any,l=any,r=any
  dim as integer   d1 =any,d2=any,s1=any,s2=any,cl=any,cr=any
  dim as pixel ptr row=any,cstart=any,cend=any
  dim as vector2d  v0 =any,v1=any,v2=any
  v0=p(0):v1=p(1):v2=p(2)
  if (v1.y>v2.y) then swap v1,v2
  if (v0.y>v2.y) then swap v0,v2
  if (v0.y>v1.y) then swap v0,v1
  if (v2.y=v0.y) then return
  s1=((v2.x-v0.x) shl SHIFTS)/(v2.y-v0.y)
  d1=v0.x shl SHIFTS
  for i as integer=0 to 1
    s2=((v1.x-v0.x) shl SHIFTS)/(v1.y-v0.y)
    d2=v0.x shl SHIFTS
    yt=v0.y
    ' begin in first row
    if yt<0 then
      d1-=s1*yt
      d2-=s2*yt
      yt=0
    end if
    yb=v1.y
    ' end in last row
    if yb>=scr_h then yb=scr_h-1
    if yb<=yt    then goto next_triangle
    row=d+yt*scr_w ' first row
    yb-=yt ' how many scanlines
    ' from top to bottom
    while yb
      l=d1 shr SHIFTS:r=d2 shr SHIFTS
      if l>r      then swap l,r
      if l>=scr_w then goto next_scanline
      if r<1      then goto next_scanline
      cl=0:cr=0   ' reset clipflag
      if l<0      then l=0    :cl=1
      if r>=scr_w then r=scr_w:cr=1
      cstart=row+l ' first pixel
      cend  =row+r ' last  pixel
      if u then ' use border
        if cl=0 then *cstart=b:cstart+=1
        if cr=0 then *cend  =b
      end if
      while cstart<cend:*cstart=c:cstart+=1:wend
      next_scanline:
      d1+=s1:d2+=s2:row+=scr_w:yb-=1
    wend
    next_triangle:
    d1= (v0.x shl SHIFTS)+((v1.y-v0.y)*s1)
    v0=v1:v1=v2
  next
end sub

const cells          as Integer = 50
const nTriangles     as integer = cells*cells*2
const stiffnes       as float   = 150
const gravity        as float   = -9.81
const DT             as float   = 1/30
const w              as float   = scr_w/(cells-2)
const h              as float   = scr_h/(cells*2)
const wm             as float   = scr_w/2
const hm             as float   = scr_h/2

Type vector3d
  as float     x,y,z
End Type
Type POINT3D
  as VECTOR3D  p,v,f
  as BOOLEAN   fixed
  as float     mass,e
End Type

Dim Shared As POINT3D  points (cells-1,cells-1)


Sub CreateIt()
  for x as integer=0 to cells-1
    with points(x,0)
      .p.x=-wm+x*w
      .p.y=hm
      .mass=1+rnd
      .fixed=true
    end with
  next

  for y as integer=1 to cells-1
    for x as integer=0 to cells-1
      with points(x,y)
        .p.x=-wm+x*w
        .p.y=hm
        .mass=1+rnd
      end with
    next
  next
End Sub

Sub CalcForces()
  dim as VECTOR3D Fd,Vd,F
  dim as float force,delta,direction,l2,air
  static as float sw
  air=sin(sw)*(5+rnd*5):sw+=0.1*dt
  For y as integer=0 To cells-1
    For x as integer=0 To cells-1
      points(x,y).f.x=air*rnd
      points(x,y).f.y=gravity*points(x,y).mass
    Next
  next

  For y as integer=0 To cells-1
    For x as integer=0 To cells-2
      with points(x+1,y)
      Fd.x=points(x,y).p.x-.p.x
      Fd.y=points(x,y).p.y-.p.y
      l2=fd.x*fd.x + fd.y*fd.y
      if l2 then
        l2=sqr(l2)
        delta=l2-w
        force=delta*stiffnes
        vd.x = points(x,y).v.x-.v.x
        vd.y = points(x,y).v.y-.v.y
        force+=(vd.x*fd.x + vd.y*fd.y)/l2
        fd.x/=l2:fd.y/=l2
        f.x=fd.x*force
        f.y=fd.y*force
        points(x,y).f.x  -=f.x
        points(x,y).f.y  -=f.y
        .f.x+=f.x
        .f.y+=f.y
      End If
      end with
    Next
  next


  For y as integer=0 To cells-2
    For x as integer=0 To cells-1
      with points(x,y+1)
      Fd.x=points(x,y).p.x-.p.x
      Fd.y=points(x,y).p.y-.p.y
      l2=fd.x*fd.x + fd.y*fd.y
      if l2 then
        l2=sqr(l2)
        delta=l2-h
        force=delta*stiffnes
        vd.x = points(x,y).v.x-.v.x
        vd.y = points(x,y).v.y-.v.y
        force+=(vd.x*fd.x + vd.y*fd.y)/l2
        fd.x/=l2:fd.y/=l2
        f.x=fd.x*force
        f.y=fd.y*force
        points(x,y).f.x-=f.x
        points(x,y).f.y-=f.y
        .f.x+=f.x
        .f.y+=f.y
      End If
      end with
    Next
  next


  For y as integer=0 To cells-1
    For x as integer=0 To cells-1
      with points(x,y)
        if .fixed=false then
          .v.x+= .f.x * DT
          .v.y+= .f.y * DT
          .p.x+= .v.x * DT
          .p.y+= .v.y * DT
          if .p.y<-240 then
            .v.x*=0.5:.v.y*=-1
          else
            .v.x*=0.999:.v.y*=0.999
          end if
        end if
      end with
    Next
  Next
End Sub

Sub DrawFilledTriangles()
  static as vector2d t(2)
  dim    as pixel    c
  dim    as integer  i
  dim    as any ptr  lpScreen=screenptr
  For y as integer=0 To cells-2
    For x as integer=0 To cells-2
      t(0).x=wm+points(x  ,y  ).p.x
      t(0).y=hm-points(x  ,y  ).p.y
      t(1).x=wm+points(x+1,y  ).p.x
      t(1).y=hm-points(x+1,y  ).p.y
      t(2).x=wm+points(x+1,y+1).p.x
      t(2).y=hm-points(x+1,y+1).p.y
     
      if  i and 1 then
         c=rgb(219,219,219)
      else
         c=rgb(32,32,32)
      end if
      i+=1
      Triangle lpScreen,t(),c
      if  i and 1 then
         c=rgb(219,219,219)
      else
         c=rgb(32,32,32)
      end if
      t(1).x=wm+points(x  ,y+1).p.x
      t(1).y=hm-points(x  ,y+1).p.y
      Triangle lpScreen,t(),c
    Next
  Next
 
End Sub


'
'main
'
Dim As Integer frames,fps,mx,my,ox,oy,sc
Dim As Double t1,t2
screenres scr_w,scr_h,scr_b
#if (scr_b=8)
  Palette332
#endif
CreateIt
t1=Timer
While inkey<>chr(27)
  CalcForces
  screenlock
    line (0,0)-(scr_w,scr_h),0,BF
    DrawFilledTriangles
  screenunlock

  frames+=1
  If frames=100 Then
    t2=Timer
    fps=frames/(t2-t1)
    windowtitle "tris:" & nTriangles & " FPS=" & Str(fps)
    t1=t2:frames=0
  End If
  Sleep 1
Wend
Last edited by D.J.Peters on Sep 28, 2017 15:20, edited 2 times in total.
Lachie Dazdarian
Posts: 2338
Joined: May 31, 2005 9:59
Location: Croatia
Contact:

Postby Lachie Dazdarian » Oct 24, 2007 21:35

Didn't know this exists. Really cool curtain effect.

BTW, did you notice this routine of mine:

http://www.freebasic.net/forum/viewtopic.php?t=9603


Do you mind expanding your using some of my ideas?
D.J.Peters
Posts: 8023
Joined: May 28, 2005 3:28
Contact:

Postby D.J.Peters » Sep 14, 2011 1:18

red = force in x direction
green = force in y direction
blue = velocity (x and y)
Image

Code: Select all

#include "fbgfx.bi"

Type float As single ' single or double

'Randomize Timer
#define scr_w  1024
#define scr_h   756
#define scr_b    32 ' 8,15,16,24 or 32



#if (scr_b=8)
  Type pixel As Ubyte
  #undef RGB
  #define RGB(r,g,b) ((r And &HE0) Or ((g And &HE0) Shr 3) Or ((b And &HC0) Shr 6))
  Sub Palette332()
    Dim As Integer i,r,g,b
    For i = 0 To 255
      r=(((i Shr 5) And &H07) * 255) / 7
      g=(((i Shr 2) And &H07) * 255) / 7
      b=(((i Shr 0) And &H03) * 255) / 3
      Palette i,r,g,b
    Next
  End Sub
#elseif (scr_b=15) Or (scr_b=16)
  Type pixel As Ushort
  #undef RGB
  #define RGB(r,g,b) (((r Shr 3) Shl 11) Or ((g Shr 2) Shl 5) Or (b Shr 3))
#elseif (scr_b=24) Or (scr_b=32)
  Type pixel As Ulong
#else
  #error bits per pixel (scr_b) must be 8,15,16,24 Or 32
#endif



Type vector2d
  As Integer x,y
End Type
#define SHIFTS   8 ' 24:8 fixed point format
Sub triangle(d   As pixel Ptr, _
             p() As vector2d , _
             c   As pixel    , _ ' color
             bc  As pixel=0  , _ ' optional bordercolor
             u   As Integer=0)   ' optional use bordercolor
  dim as integer   t =Any,b=Any,l=Any,r=Any
  dim as integer   d1 =Any,d2=Any,s1=Any,s2=Any,cl=Any,cr=Any
  dim as pixel ptr row=Any,cstart=Any,cend=Any
  dim as vector2d  v0 =Any,v1=Any,v2=Any

  v0=p(0):v1=p(1):v2=p(2)

  If (v1.y>v2.y) then swap v1,v2
  If (v0.y>v2.y) then swap v0,v2
  If (v0.y>v1.y) then swap v0,v1
  If (v2.y=v0.y) then return

  s1=((v2.x-v0.x) Shl SHIFTS)/(v2.y-v0.y)
  d1=v0.x Shl SHIFTS
  For i As Integer=0 To 1
    s2=((v1.x-v0.x) Shl SHIFTS)/(v1.y-v0.y)
    d2=v0.x Shl SHIFTS
    t=v0.y ' top
    ' begin in first row
    If t<0 Then
      d1-=s1*t
      d2-=s2*t
      t=0
    End If
    b=v1.y ' bottom
    ' end in last row
    If b>=scr_h Then b=scr_h-1
    If b<=t    Then Goto next_triangle
    row=d+t*scr_w ' first row
    b-=t ' how many scanlines
    ' from top to bottom
    While b
      l=d1 Shr SHIFTS:r=d2 Shr SHIFTS
      If l>r      Then Swap l,r
      If l>=scr_w Then Goto next_scanline
      If r<1      Then Goto next_scanline
      cl=0:cr=0   ' reset clipflag
      If l<0      Then l=0    :cl=1
      If r>=scr_w Then r=scr_w:cr=1
      cstart=row+l ' first pixel
      cend  =row+r ' last  pixel
      'If u Then ' use border
      '  If cl=0 Then *cstart=bc:cstart+=1
      '  If cr=0 Then *cend  =bc
      'End If
      While cstart<cend:*cstart=c:cstart+=1:Wend
      next_scanline:
      d1+=s1:d2+=s2:row+=scr_w:b-=1
    Wend
    next_triangle:
    d1= (v0.x Shl SHIFTS)+((v1.y-v0.y)*s1)
    v0=v1:v1=v2
  Next
End Sub

const cells      as Integer = 100
const nTriangles as Integer = cells*cells*2
const stiffnes   as float   =  200
const gravity    as float   = -9.81
const DT         as float   = 1/30
const w          as float   = scr_w/(cells-2)
const h          as float   = scr_h/(cells*2)
const wm         as float   = scr_w/2
const hm         as float   = scr_h/2

Type vector3d
  As float     x,y,z
End Type
Type POINT3D
  As VECTOR3D  p,v,f
  As BOOLEAN   fixed
  As float     mass,e
End Type

Dim Shared As POINT3D  points (cells-1,cells-1)


Sub CreateIt()

  ' first row are fixed
  For x As Integer=0 To cells-1
    With points(x,0)
      .p.x=-wm+x*w
      .p.y=hm
      .mass=1+rnd
      .fixed=true
    End With
  Next

  For y As Integer=1 To cells-1
    For x As Integer=0 To cells-1
      With points(x,y)
        .p.x=-wm+x*w
        .p.y=hm
        .mass=1+rnd
      End With
    Next
  Next
End Sub

Sub CalcForces()
  Dim As VECTOR3D Fd,Vd,F
  Dim As float force,delta,direction,l2,air
  Static As float sw
  air=Sin(sw)*(5+Rnd*5)
  sw+=0.1*dt
  ' forces x,y
  For y As Integer=0 To cells-1
    For x As Integer=0 To cells-1
      points(x,y).f.x = air '*Rnd
      points(x,y).f.y = gravity * points(x,y).mass
    Next
  Next

  For y As Integer=0 To cells-1
    For x As Integer=0 To cells-2
      With points(x+1,y)
      Fd.x=points(x,y).p.x-.p.x
      Fd.y=points(x,y).p.y-.p.y
      l2=fd.x*fd.x + fd.y*fd.y
      If l2 Then
        l2=Sqr(l2)
        delta=l2-w
        force=delta*stiffnes
        vd.x = points(x,y).v.x-.v.x
        vd.y = points(x,y).v.y-.v.y
        force+=(vd.x*fd.x + vd.y*fd.y)/l2
        fd.x/=l2:fd.y/=l2
        f.x=fd.x*force
        f.y=fd.y*force
        points(x,y).f.x-=f.x
        points(x,y).f.y-=f.y
        .f.x+=f.x
        .f.y+=f.y
      End If
      End With
    Next
  Next


  For y As Integer=0 To cells-2
    For x As Integer=0 To cells-1
      With points(x,y+1)
      Fd.x=points(x,y).p.x-.p.x
      Fd.y=points(x,y).p.y-.p.y
      l2=fd.x*fd.x + fd.y*fd.y
      If l2 Then
        l2=Sqr(l2)
        delta=l2-h
        force=delta*stiffnes
        vd.x = points(x,y).v.x-.v.x
        vd.y = points(x,y).v.y-.v.y
        force+=(vd.x*fd.x + vd.y*fd.y)/l2
        fd.x/=l2:fd.y/=l2
        f.x=fd.x*force
        f.y=fd.y*force
        points(x,y).f.x-=f.x
        points(x,y).f.y-=f.y
        .f.x+=f.x
        .f.y+=f.y
      End If
      End With
    Next
  Next

  For y As Integer=0 To cells-1
    For x As Integer=0 To cells-1
      With points(x,y)
        If .fixed=false Then
          .v.x+= .f.x * DT ' velocity + force
          .v.y+= .f.y * DT
          .p.x+= .v.x * DT ' position + velocity
          .p.y+= .v.y * DT
          If .p.y<1-(scr_h\2) Then
            .v.x*=0.5:.v.y*=-1
          Else
            .v.x*=0.999:.v.y*=0.999
          End If
        End If
      End With
    Next
  Next
End Sub

Sub DrawFilledTriangles()
  static As vector2d t(2)
  dim    As pixel    c
  dim    As Integer  i,j
  dim    As Any Ptr  lpScreen=screenptr
  For y As Integer=0 To cells-2
    i=(y and 1)
    For x As Integer=0 To cells-2
      t(0).x=wm+points(x  ,y  ).p.x
      t(0).y=hm-points(x  ,y  ).p.y
      t(1).x=wm+points(x+1,y  ).p.x
      t(1).y=hm-points(x+1,y  ).p.y
      t(2).x=wm+points(x+1,y+1).p.x
      t(2).y=hm-points(x+1,y+1).p.y
      dim as float rr=points(x,y).f.x + points(x+1,y).f.x + points(x+1,y).f.x + points(x+1,y+1).f.x + points(x,y+1).f.x
      rr=sqr(rr)
      dim as float gg=points(x,y).f.y + points(x+1,y).f.y + points(x+1,y).f.y + points(x+1,y+1).f.y + points(x,y+1).f.y
      gg=sqr(gg)
     
      dim as float bb=points(x,y).v.x*points(x,y).v.y
      bb+=points(x+1,y  ).v.x*points(x+1,y  ).v.y
      bb+=points(x+1,y+1).v.x*points(x+1,y+1).v.y
      bb+=points(x  ,y+1).v.x*points(x  ,y+1).v.y
      bb=sqr(bb)
     
      dim as integer r=rr*8:if r>255 then r=255
      dim as integer g=gg*8:if g>255 then g=255
      dim as integer b=bb*8:if b>255 then b=255
      j=(x and 1)
      If i xor j then
        r\=2:g\=2:b\=2
      End If
      c=rgb(r,g,b)
      Triangle lpScreen,t(),c ',rgb(255,255,0),1
      t(1).x=wm+points(x,y+1).p.x
      t(1).y=hm-points(x,y+1).p.y
      Triangle lpScreen,t(),c ',rgb(255,255,0),1
    Next
  Next
End Sub


'
'main
'
dim as integer frames,fps,mx,my,ox,oy,sc
dim as double t1,t2

ScreenRes scr_w,scr_h,scr_b
#if (scr_b=8)
  Palette332
#endif
CreateIt
t1=Timer
While inkey<>chr(27)
  CalcForces
  ScreenLock
    cls
    'Line (0,0)-(scr_w,scr_h),0,BF
    DrawFilledTriangles
  ScreenUnlock

  frames+=1
  If frames=50 Then
    t2=Timer
    fps=frames/(t2-t1)
    WindowTitle nTriangles & " triangles FPS=" & Str(fps)
    t1=t2:frames=0
  End If
Wend

Wend
Last edited by D.J.Peters on Sep 28, 2017 15:16, edited 2 times in total.
dafhi
Posts: 1335
Joined: Jun 04, 2005 9:51

Postby dafhi » Sep 14, 2011 2:09

really nice
Dr_D
Posts: 2396
Joined: May 27, 2005 4:59
Contact:

Postby Dr_D » Sep 14, 2011 2:24

haha yeah... very cool. :)
D.J.Peters
Posts: 8023
Joined: May 28, 2005 3:28
Contact:

Postby D.J.Peters » Sep 14, 2011 2:43

In near future RGB LED's or Oled's as cloth ;-)

Code: Select all

#include "fbgfx.bi"

Type float As single ' single or double

'Randomize Timer
#define scr_w  1024
#define scr_h  756
#define scr_b   32 ' 8,15,16,24 or 32



#if (scr_b=8)
  Type pixel As Ubyte
  #undef RGB
  #define RGB(r,g,b) ((r And &HE0) Or ((g And &HE0) Shr 3) Or ((b And &HC0) Shr 6))
  Sub Palette332()
    Dim As Integer i,r,g,b
    For i = 0 To 255
      r=(((i Shr 5) And &H07) * 255) / 7
      g=(((i Shr 2) And &H07) * 255) / 7
      b=(((i Shr 0) And &H03) * 255) / 3
      Palette i,r,g,b
    Next
  End Sub 
#elseif (scr_b=15) Or (scr_b=16)
  Type pixel As Ushort
  #undef RGB
  #define RGB(r,g,b) (((r Shr 3) Shl 11) Or ((g Shr 2) Shl 5) Or (b Shr 3))
#elseif (scr_b=24) Or (scr_b=32)
  Type pixel As Ulong
#else
  #error bits per pixel (scr_b) must be 8,15,16,24 Or 32
#endif



Type vector2d
  As Integer x,y
End Type
#define SHIFTS   8 ' 24:8 fixed point format
Sub triangle(d   As pixel Ptr, _
             p() As vector2d , _
             c   As pixel    , _ ' color
             bc  As pixel=0  , _ ' optional bordercolor
             u   As Integer=0)   ' optional use bordercolor
  dim as integer   t =Any,b=Any,l=Any,r=Any
  dim as integer   d1 =Any,d2=Any,s1=Any,s2=Any,cl=Any,cr=Any
  dim as pixel ptr row=Any,cstart=Any,cend=Any
  dim as vector2d  v0 =Any,v1=Any,v2=Any

  v0=p(0):v1=p(1):v2=p(2)

  If (v1.y>v2.y) then swap v1,v2
  If (v0.y>v2.y) then swap v0,v2
  If (v0.y>v1.y) then swap v0,v1
  If (v2.y=v0.y) then return

  s1=((v2.x-v0.x) Shl SHIFTS)/(v2.y-v0.y)
  d1=v0.x Shl SHIFTS
  For i As Integer=0 To 1
    s2=((v1.x-v0.x) Shl SHIFTS)/(v1.y-v0.y)
    d2=v0.x Shl SHIFTS
    t=v0.y ' top
    ' begin in first row
    If t<0 Then
      d1-=s1*t
      d2-=s2*t
      t=0
    End If
    b=v1.y ' bottom
    ' end in last row
    If b>=scr_h Then b=scr_h-1
    If b<=t    Then Goto next_triangle
    row=d+t*scr_w ' first row
    b-=t ' how many scanlines
    ' from top to bottom
    While b
      l=d1 Shr SHIFTS:r=d2 Shr SHIFTS
      If l>r      Then Swap l,r
      If l>=scr_w Then Goto next_scanline
      If r<1      Then Goto next_scanline
      cl=0:cr=0   ' reset clipflag
      If l<0      Then l=0    :cl=1
      If r>=scr_w Then r=scr_w:cr=1
      cstart=row+l ' first pixel
      cend  =row+r ' last  pixel
      'If u Then ' use border
      '  If cl=0 Then *cstart=bc:cstart+=1
      '  If cr=0 Then *cend  =bc
      'End If
      While cstart<cend:*cstart=c:cstart+=1:Wend
      next_scanline:
      d1+=s1:d2+=s2:row+=scr_w:b-=1
    Wend
    next_triangle:
    d1= (v0.x Shl SHIFTS)+((v1.y-v0.y)*s1)
    v0=v1:v1=v2
  Next
End Sub

const cells      as Integer = 100
const nTriangles as Integer = cells*cells*2
const stiffnes   as float   =  200
const gravity    as float   = -9.81
const DT         as float   = 1/30
const w          as float   = scr_w/(cells-2)
const h          as float   = scr_h/(cells*2)
const wm         as float   = scr_w/2
const hm         as float   = scr_h/2

Type vector3d
  As float     x,y,z
End Type
Type POINT3D
  As VECTOR3D  p,v,f
  As BOOLEAN   fixed
  As float     mass,e
End Type

Dim Shared As POINT3D  points (cells-1,cells-1)


Sub CreateIt()
  For x As Integer=0 To cells-1 step (cells-1)\5
    points(x,0).fixed=1
  next

  For y As Integer=0 To cells-1
    For x As Integer=0 To cells-1
      With points(x,y)
        .p.x=-wm+x*w
        .p.y=hm
        .mass=rnd*5
      End With
    Next
  Next
End Sub

Sub CalcForces()
  Dim As VECTOR3D Fd,Vd,F
  Dim As float force,delta,direction,l2,air
  Static As float sw
  air=Sin(sw)*(5+Rnd*5)
  sw+=0.1*dt
  ' forces x,y
  For y As Integer=0 To cells-1
    For x As Integer=0 To cells-1
      points(x,y).f.x = air'*Rnd
      points(x,y).f.y = gravity * points(x,y).mass
    Next
  Next

  For y As Integer=0 To cells-1
    For x As Integer=0 To cells-2
      With points(x+1,y)
      Fd.x=points(x,y).p.x-.p.x
      Fd.y=points(x,y).p.y-.p.y
      l2=fd.x*fd.x + fd.y*fd.y
      If l2 Then
        l2=Sqr(l2)
        delta=l2-w
        force=delta*stiffnes
        vd.x = points(x,y).v.x-.v.x
        vd.y = points(x,y).v.y-.v.y
        force+=(vd.x*fd.x + vd.y*fd.y)/l2
        fd.x/=l2:fd.y/=l2
        f.x=fd.x*force
        f.y=fd.y*force
        points(x,y).f.x-=f.x
        points(x,y).f.y-=f.y
        .f.x+=f.x
        .f.y+=f.y
      End If
      End With
    Next
  Next


  For y As Integer=0 To cells-2
    For x As Integer=0 To cells-1
      With points(x,y+1)
      Fd.x=points(x,y).p.x-.p.x
      Fd.y=points(x,y).p.y-.p.y
      l2=fd.x*fd.x + fd.y*fd.y
      If l2 Then
        l2=Sqr(l2)
        delta=l2-h
        force=delta*stiffnes
        vd.x = points(x,y).v.x-.v.x
        vd.y = points(x,y).v.y-.v.y
        force+=(vd.x*fd.x + vd.y*fd.y)/l2
        fd.x/=l2:fd.y/=l2
        f.x=fd.x*force
        f.y=fd.y*force
        points(x,y).f.x-=f.x
        points(x,y).f.y-=f.y
        .f.x+=f.x
        .f.y+=f.y
      End If
      End With
    Next
  Next

  For y As Integer=0 To cells-1
    For x As Integer=0 To cells-1
      With points(x,y)
        If .fixed=0 Then
          .v.x+= .f.x * DT ' velocity + force
          .v.y+= .f.y * DT
          .p.x+= .v.x * DT ' position + velocity
          .p.y+= .v.y * DT
          If .p.y<1-(scr_h\2) Then
            .v.x*=0.5:.v.y*=-0.999
          Else
            .v.x*=0.999:.v.y*=0.999
          End If
        End If
      End With
    Next
  Next
End Sub

Sub DrawFilledTriangles()
  static As vector2d t(2)
  dim    As pixel    c
  dim    As Integer  i,j
  dim    As Any Ptr  lpScreen=screenptr
  For y As Integer=0 To cells-2
    i=(y and 1)
    For x As Integer=0 To cells-2
      t(0).x=wm+points(x  ,y  ).p.x
      t(0).y=hm-points(x  ,y  ).p.y
      t(1).x=wm+points(x+1,y  ).p.x
      t(1).y=hm-points(x+1,y  ).p.y
      t(2).x=wm+points(x+1,y+1).p.x
      t(2).y=hm-points(x+1,y+1).p.y
      dim as float rr=points(x,y).f.x + points(x+1,y).f.x + points(x+1,y).f.x + points(x+1,y+1).f.x + points(x,y+1).f.x
      rr=sqr(rr)
      dim as float gg=points(x,y).f.y + points(x+1,y).f.y + points(x+1,y).f.y + points(x+1,y+1).f.y + points(x,y+1).f.y
      gg=sqr(gg)
     
      dim as float bb=points(x,y).v.x*points(x,y).v.y
      bb+=points(x+1,y  ).v.x*points(x+1,y  ).v.y
      bb+=points(x+1,y+1).v.x*points(x+1,y+1).v.y
      bb+=points(x  ,y+1).v.x*points(x  ,y+1).v.y
      bb=sqr(bb)
     
      dim as integer r=rr*8:if r>255 then r=255
      dim as integer g=gg*8:if g>255 then g=255
      dim as integer b=bb*8:if b>255 then b=255
      j=(x and 1)
      If i xor j then
        r\=2:g\=2:b\=2
      End If
      c=rgb(r,g,b)
      Triangle lpScreen,t(),c ',rgb(255,255,0),1
      t(1).x=wm+points(x,y+1).p.x
      t(1).y=hm-points(x,y+1).p.y
      Triangle lpScreen,t(),c ',rgb(255,255,0),1
    Next
  Next
End Sub


'
'main
'
dim as integer frames,fps,key,f=1
dim as double t1,t2

ScreenRes scr_w,scr_h,scr_b
#if (scr_b=8)
  Palette332
#endif
CreateIt
t1=Timer
While key<>27 ' [ESC] = quit
  CalcForces
  ScreenLock
    cls
    'Line (0,0)-(scr_w,scr_h),0,BF
    DrawFilledTriangles
  ScreenUnlock

  frames+=1
  If frames=50 Then
    t2=Timer
    fps=frames/(t2-t1)
    WindowTitle nTriangles & " triangles FPS=" & Str(fps) & " [ESC] = quit"
    t1=t2:frames=0
    key=asc(inkey)
  End If
Wend
Last edited by D.J.Peters on Sep 28, 2017 15:21, edited 2 times in total.
badidea
Posts: 2007
Joined: May 24, 2007 22:10
Location: The Netherlands

Postby badidea » Sep 14, 2011 22:32

Good stuff.

Do you also know an algorithm for drawing circle sectors fast?
I tried some time ago, but things got too complicated.
dafhi
Posts: 1335
Joined: Jun 04, 2005 9:51

Postby dafhi » Sep 15, 2011 1:14

@badidea

check out Richard's post at the bottom
http://www.freebasic.net/forum/viewtopic.php?t=17111
TJF
Posts: 3546
Joined: Dec 06, 2009 22:27
Location: N47°, E15°
Contact:

Postby TJF » Sep 15, 2011 7:42

badidea wrote:Do you also know an algorithm for drawing circle sectors fast?

Check out CAIRO (hardware accelerated).

Return to “Tips and Tricks”

Who is online

Users browsing this forum: No registered users and 3 guests