## Endless loop.

dodicat
Posts: 6687
Joined: Jan 10, 2006 20:30
Location: Scotland

### Endless loop.

Somewhere out there.

Code: Select all

`Type v3    As Single x,y,z    As Ulong col    flag As Long    Declare Function length As Single    Declare Function unit As v3End TypeType Line    As v3 v1,v2End Type#define cross ^#define dot *Operator + (Byref v1 As v3,Byref v2 As v3) As v3Return Type(v1.x+v2.x,v1.y+v2.y,v1.z+v2.z)End OperatorOperator -(Byref v1 As v3,Byref v2 As v3) As v3Return Type(v1.x-v2.x,v1.y-v2.y,v1.z-v2.z)End OperatorOperator * (Byval f As Single,Byref v1 As v3) As v3Return Type(f*v1.x,f*v1.y,f*v1.z)End OperatorOperator * (Byref v1 As v3,Byref v2 As v3) As Single Return v1.x*v2.x+v1.y*v2.y+v1.z*v2.zEnd OperatorOperator ^ (Byref v1 As v3,Byref v2 As v3) As v3 Return Type(v1.y*v2.z-v2.y*v1.z,-(v1.x*v2.z-v2.x*v1.z),v1.x*v2.y-v2.x*v1.y)End OperatorOperator <>(Byref v1 As V3,Byref v2 As V3) As IntegerReturn (v1.x<>v2.x) Or (v1.y<>v2.y)End OperatorFunction v3.length As Single    Return Sqr(x*x+y*y+z*z)End FunctionFunction v3.unit As v3    Dim n As Single=length    If n=0 Then n=1e-20    Return Type(x/n,y/n,z/n)End FunctionType _float As V3Dim Shared As Const v3 eyepoint=Type(512,768\2,500)#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)#define incircle(cx,cy,radius,x,y) (cx-x)*(cx-x) +(cy-y)*(cy-y)<= radius*radius'<><><><><><><><><><><> Quick SORT <><><><><><><><><><>#define up <,>#define down >,<#macro SetQsort(datatype,fname,b1,b2,dot)Sub fname(array() As datatype,begin As Long,Finish As Ulong)    Dim As Long i=begin,j=finish     Dim As datatype x =array(((I+J)\2))    While  I <= J        While array(I)dot b1 X dot:I+=1:Wend            While array(J)dot b2 X dot:J-=1:Wend                If I<=J Then Swap array(I),array(J): I+=1:J-=1            Wend            If J > begin Then fname(array(),begin,J)            If I < Finish Then fname(array(),I,Finish)        End Sub        #endmacro                    Sub GetCircle(xm As Single, ym As Single,zm As Single, r As Integer,p() As v3)            #define CIRC(r)  ( ( Int( (r)*(1 + Sqr(2)) ) - (r) ) Shl 2 )            Dim As Long x = -r, y = 0, e = 2 - r Shl 1,count            Redim p(1 To CIRC(r)+4 )            Do                count+=1:p(count)=Type<v3>(xm-x, ym+y,zm)                count+=1:p(count)=Type<v3>(xm-y, ym-x,zm)                count+=1:p(count)=Type<v3>(xm+x, ym-y,zm)                count+=1:p(count)=Type<v3>(xm+y, ym+x,zm)                r = e                If r<=y Then                    y+=1                    e+=y Shl 1+1                End If                If r>x Or e>y Then                    x+=1                    e+=x Shl 1+1                End If            Loop While x<0            Redim Preserve p(1 To count-1)        End Sub                                Sub RotateArray(wa() As V3,result() As V3,angle As _float,centre As V3,flag As Long=0)            Dim As Single dx,dy,dz,w            Dim As Single SinAX=Sin(angle.x)            Dim As Single SinAY=Sin(angle.y)            Dim As Single SinAZ=Sin(angle.z)            Dim As Single CosAX=Cos(angle.x)            Dim As Single CosAY=Cos(angle.y)            Dim As Single CosAZ=Cos(angle.z)            Redim result(Lbound(wa) To Ubound(wa))            For z As Long=Lbound(wa) To Ubound(wa)                dx=wa(z).x-centre.x                dy=wa(z).y-centre.y                dz=wa(z).z-centre.z                Result(z).x=((Cosay*Cosaz)*dx+(-Cosax*Sinaz+Sinax*Sinay*Cosaz)*dy+(Sinax*Sinaz+Cosax*Sinay*Cosaz)*dz)+centre.x                result(z).y=((Cosay*Sinaz)*dx+(Cosax*Cosaz+Sinax*Sinay*Sinaz)*dy+(-Sinax*Cosaz+Cosax*Sinay*Sinaz)*dz)+centre.y                result(z).z=((-Sinay)*dx+(Sinax*Cosay)*dy+(Cosax*Cosay)*dz)+centre.z                #macro perspective()                w = 1 + (result(z).z/eyepoint.z)                result(z).x = (result(z).x-eyepoint.x)/w+eyepoint.x                 result(z).y = (result(z).y-eyepoint.y)/w+eyepoint.y                result(z).z = (result(z).z-eyepoint.z)/w+eyepoint.z                #endmacro                If flag Then: perspective():End If                result(z).col=wa(z).col                result(z).flag=wa(z).flag            Next z        End Sub                Sub inc(a() As v3,b() As v3,clr As Ulong) 'increment an array            Var u=Ubound(a)            Redim Preserve a(1 To u+ Ubound(b))             For n As Long=1 To Ubound(b)                b(n).col=clr                a(u+n)= b(n)            Next n        End Sub                Sub createdisc(xc As Single,yc As Single,zc As Single,rad As Long,d() As v3)'ends            Redim d(1 To 4*rad^2)            Dim As Long ctr            For x As Long=xc-rad To xc+rad                For y As Long=yc-rad To yc+rad                      If incircle(xc,yc,rad,x,y) Then                        ctr+=1                        d(ctr)=Type(x,y,zc,0,1)                    End If                Next y            Next x            Redim Preserve d(1 To ctr)             End Sub                Sub createplate(xc As Single,yc As Single,zc As Single,lngth As Long,bth As Long,d() As v3,flag As Long)            Dim As Long ctr            Redim d(1 To lngth*bth*5)            For x As Long=xc-lngth To xc+lngth                For y As Long=yc-bth To yc+bth                    ctr+=1                    d(ctr)=Type(x,y,zc,0,flag)                Next y            Next x            Redim Preserve d(1 To ctr)        End Sub                Function segment_distance( l As Line, p As v3, ip As v3=Type(0,0,0)) As Single            Var s=l.v1,f=l.v2            Dim As Single linelength=(s-f).length            Dim As Single dist= ((1/linelength)*((s-f) cross (p-s))).length            Dim As Single lpf=(p-f).length,lps=(p-s).length            If lps >= lpf Then                Var temp=Sqr(lps*lps-dist*dist)/linelength                If temp>=1 Then temp=1:dist=lpf                ip=s+(temp)*(f-s)                Return dist            Else                Var temp=Sqr(lpf*lpf-dist*dist)/linelength                If temp>=1 Then temp=1:dist=lps                ip=f+(temp)*(s-f)                Return dist            End If            Return dist        End Function                Function Regulate(Byval MyFps As Long,Byref fps As Long=0) As Long            Static As Double timervalue,_lastsleeptime,t3,frames            Var t=Timer            frames+=1            If (t-t3)>=1 Then t3=t:fps=frames:frames=0            Var sleeptime=_lastsleeptime+((1/myfps)-T+timervalue)*1000            If sleeptime<1 Then sleeptime=1            _lastsleeptime=sleeptime            timervalue=T            Return sleeptime        End Function                Sub star(starX As Single,starY As Single,size As Single,col As Ulong,num As Long=5,rot As Single=0,cut As Single=.4,i As Any Ptr=0)            Var count=0,rad=0.0,_px=0.0,_py=0.0,pi=4*Atn(1),prime=Rgb(255,254,253)            For x As Long=1 To 2                For z As Single=0+.28 +rot To 2*pi+.1+.28 +rot Step 2*pi/(2*num)                    count=count+1                    If count Mod 2=0 Then rad=size Else rad=cut*size                    _px=starx+rad*Cos(z)                    _py=stary+rad*Sin(z)                    If count=1 Then Pset i,(_px,_py)Else Line i, -(_px,_py),prime                Next z                Paint i,(starx,stary),prime,prime                count=0:prime=col            Next x        End Sub                Function perspective(p As v3,eyepoint As v3) As v3            Dim As Single   w=1+(p.z/eyepoint.z)            Return Type((p.x-eyepoint.x)/w+eyepoint.x,_            (p.y-eyepoint.y)/w+eyepoint.y,_            (p.z-eyepoint.z)/w+eyepoint.z)        End Function                Function onsphere(S As v3,P As V3) As Long            Return (S.x-P.x)*(S.x-P.x)+(S.y-P.y)*(S.y-P.y)+(S.z-P.z)*(S.z-P.z) <= S.col*S.col Andalso _            (S.x-P.x)*(S.x-P.x)+(S.y-P.y)*(S.y-P.y)+(S.z-P.z)*(S.z-P.z) > (S.col-1)*(S.col-1)        End Function                Sub getsphere(a() As V3,pt As V3,rad As Long,col As Ulong=0,flag As Integer=0)            Dim As Any Ptr i=Imagecreate (500,500,0)            Dim As Long rd=10,gr=150,bl=250,kr=3,kg=3,kb=3,x=3            For n As Long=1 To 500                rd+=kr                gr+=kg                bl+=kb                If rd<x Or rd>255-x Then kr=-kr                If gr<x Or gr>255-x Then kg=-kg                If bl<x Or bl>255-x Then kb=-kb                Line i,(0,n)-(500,n),Rgb(rd,gr,bl)            Next n            Var g=750            Redim a(1 To 172060)            Dim As Long xx=Pt.x,yy=Pt.y,zz=Pt.z,r=rad,counter            Dim As v3 sp=Type(xx,yy,zz,r)            For x As Long= xx+r+1 -g To xx+r+1 Step 1                For y As Long=yy-r+1  To yy-r+1+g Step 1                    For z As Long= zz+r+1-1000 To zz+r+1 Step 2                        If onsphere(sp,Type<V3>(x,y,z)) Then                            counter+=1                            Var xp=map((xx+r+1 -g),(xx+r+1),x,0,500)                            Var yp=map((yy-r+1),(yy-r+1+g),y,0,500)                            a(counter)=Type<V3>(x,y,z,Point(xp,yp,i))                        End If                    Next z                Next y            Next x            Imagedestroy i            Redim Preserve a(1 To counter)        End Sub                Sub filter(i As Any Ptr,n As Long)            Dim As Integer ix,iy            Imageinfo i,ix,iy            Dim As Long p(0 To 4)            For k As Long=1 To n                For x As Long=1 To ix-2                    For y As Long=1 To iy-2                        Var r=0                        Var g=0                        Var b=0                        p(0)=Point(x,y,i)                        p(1)=Point(x,y-1,i)                        p(2)=Point(x+1,y,i)                        p(3)=Point(x,y+1,i)                        p(4)=Point(x-1,y,i)                        For n As Long=0 To 4                            r+=Cast(Ubyte Ptr,@p(n))[2]                            g+=Cast(Ubyte Ptr,@p(n))[1]                            b+=Cast(Ubyte Ptr,@p(n))[0]                        Next                        r/=5                        g/=5                        b/=5                        Pset i,(x,y),Rgb(r,g,b)                    Next y                Next x            Next k        End Sub                Function fade(fore As Ulong,f As Single) As Ulong            Dim As Ubyte fr=Cast(Ubyte Ptr,@fore)[2],fg=Cast(Ubyte Ptr,@fore)[1],fb=Cast(Ubyte Ptr,@fore)[0]            Return Rgb(f*fr,f*fg,f*fb)        End Function                '======================== set up =============                 Screen 20,32,,64        locate 20,20        print "Please wait . . ."        '==== background ====        Dim As Any Ptr i=Imagecreate(1024,768,0)        Dim As v3 pt(1 To 100)        Dim As Single xx,yy        For n As Long=1 To 100            Do                xx=Rnd*1024:yy=Rnd*768            Loop Until incircle((-1000),(768+1000),1600,xx,yy)=0            pt(n)=Type(xx,yy)            star(xx,yy,2+Rnd,Rgb(200,200,200+Rnd*55),5,Rnd,.4,i)        Next                For kk As Long=1 To 30            Var r=map(0,30,kk,0,200)            Var g=map(0,30,kk,0,200)            Var b=map(0,30,kk,0,255)            Circle i,((-650),1418),1110-kk,Rgb(r,g,b),,,,f        Next kk                        Redim As V3 sphere()        getsphere(sphere(),Type<v3>(-1000,1768,0),2000-400-20)        For n As Long=Lbound(sphere) To Ubound(sphere)            Var p=perspective(sphere(n),Type(-1000,1768,900))            Circle i,(p.x+70+40+370,p.y-70-40-370),3,fade(sphere(n).col,.75)        Next n        Redim sphere(0)        filter(i,1)                ' === build the craft ===        Redim As v3 e1(),e2() 'ends        Redim As v3 c(),a(0)  'cylinder        Dim As Long tail=40,wing=100        For z As Long=-200 To 200 'fill cylinder            getcircle(512,768\2,z,20,c())            inc(a(),c(),Rgb(0,200,0))        Next        Dim As Single pi=4*Atn(1)        createdisc(512,768\2,-201,18,e1()) 'ends        createdisc(512,768\2, 201,18,e2())        inc(a(),e1(),Rgb(155,50,0))  'add them to the array        inc(a(),e2(),Rgb(0,50,155))                        Redim As v3 p(),p2()        createplate(412+20,768\2-wing,0,30,wing,p(),2)        RotateArray(p(),p2(),Type<_float>(0,pi/2,0),Type(512,768/2,0),0)'main stbd        For n As Long=Lbound(p) To Ubound(p)            p(n)=p2(n)        Next n        inc(a(),p(),Rgb(0,100,200))                createplate(412+20,768\2-wing,1,30,wing,p(),3)        RotateArray(p(),p2(),Type<_float>(0,pi/2,0),Type(512,768/2,0),0)'main stbd        For n As Long=Lbound(p) To Ubound(p)            p(n)=p2(n)        Next n        inc(a(),p(),Rgb(0,100,200))                createplate(412+20,768\2+wing,0,30,wing,p(),3)        RotateArray(p(),p2(),Type<_float>(0,pi/2,0),Type(512,768/2,0),0)'main port        For n As Long=Lbound(p) To Ubound(p)            p(n)=p2(n)        Next n        inc(a(),p(),Rgb(0,100,200))                createplate(412+20,768\2+wing,1,30,wing,p(),2)        RotateArray(p(),p2(),Type<_float>(0,pi/2,0),Type(512,768/2,0),0)'main port        For n As Long=Lbound(p) To Ubound(p)            p(n)=p2(n)        Next n        inc(a(),p(),Rgb(0,100,200))                createplate(412+235,768\2+tail,0,20,tail,p(),3)        RotateArray(p(),p2(),Type<_float>(0,pi/2,0),Type(512,768/2,0),0)'tail port        For n As Long=Lbound(p) To Ubound(p)            p(n)=p2(n)        Next n        inc(a(),p(),Rgb(0,100,200))                createplate(412+235,768\2+tail,1,20,tail,p(),2)        RotateArray(p(),p2(),Type<_float>(0,pi/2,0),Type(512,768/2,0),0)'tail port        For n As Long=Lbound(p) To Ubound(p)            p(n)=p2(n)        Next n        inc(a(),p(),Rgb(0,100,200))                createplate(412+235,768\2-tail,0,20,tail,p(),2)        RotateArray(p(),p2(),Type<_float>(0,pi/2,0),Type(512,768/2,0),0)'tail port        For n As Long=Lbound(p) To Ubound(p)            p(n)=p2(n)        Next n        inc(a(),p(),Rgb(0,100,200))                createplate(412+235,768\2-tail,1,20,tail,p(),3)        RotateArray(p(),p2(),Type<_float>(0,pi/2,0),Type(512,768/2,0),0)'tail port        For n As Long=Lbound(p) To Ubound(p)            p(n)=p2(n)        Next n        inc(a(),p(),Rgb(0,100,200))                createplate(412+235,768\2+40,0,20,30,p(),0)        RotateArray(p(),p2(),Type<_float>(0,pi/2,pi/2),Type(512,768/2,0),0)'fin        For n As Long=Lbound(p) To Ubound(p)            p(n)=p2(n)        Next n        inc(a(),p(),Rgb(0,100,200))        '===  built ====                        Dim As v3 L(1 To 2)={Type(512,768\2,-205),Type(512,768\2,205)}'ends of central axis        inc(a(),L(),0) 'add them to array        SetQsort(V3,QsortZ,down,.z)'initiate quicksort                Redim As v3 result()'working array        Dim As Single ang        Dim As Single r,g,b,rad,dt        Dim As v3 light=Type(512,-10000,0)        Dim As v3 ip         Dim As Line ln        Dim As Long fps                        RotateArray(a(),result(),Type<_float>(pi/8,pi/2,pi/2),Type(512,768/2,0),0)        For n As Long=Lbound(a) To Ubound(a)                                    a(n)=result(n)                'rotate all points by pi/2 around the y axis        Next                      Do            ang+=.015            RotateArray(a(),result(),Type<_float>(2*ang,0,0),Type(512,768\2,350),1)            Qsortz(result(),Lbound(result),Ubound(result)-2)            Screenlock            Cls            Put(0,0),i,Pset            For n As Long=1 To Ubound(pt)              if rnd>.8 then  Circle(pt(n).x,pt(n).y),10,Rgba(0,0,0,Rnd*80),,,,f 'twinkle            Next n                        Draw String(20,20),"FPS " &fps            For n As Long=Lbound(result) To Ubound(result)-2                Select Case As Const result(n).flag                                Case 0 'tube                    Dim As v3 d=result(n)-light'    'point to light                    ln=Type<Line>(result(Ubound(result)-1),result(Ubound(result))) 'the central cylinder axis (line)                    segment_distance(ln,result(n),ip) 'need ip (intercept of central axis)                    Dim As v3 c=Type(result(n).x-ip.x,result(n).y-ip.y,result(n).z-ip.z)  'cylinder normals at point                    Var q=c.unit dot d.unit        'shade by dot product                    dt=map(-1,1,q,1,0)             'map dot product to [1,0]                        r=Cast(Ubyte Ptr,@result(n).col)[2]*dt                    g=Cast(Ubyte Ptr,@result(n).col)[1]*dt                    b=Cast(Ubyte Ptr,@result(n).col)[0]*dt                                    Case 1 'ends                    dt=map(600,200,result(n).y,.3,1) 'shade by .y                    r=Cast(Ubyte Ptr,@result(n).col)[2]*dt                    g=Cast(Ubyte Ptr,@result(n).col)[1]*dt                    b=Cast(Ubyte Ptr,@result(n).col)[0]*dt                                     Case 2,3 'wings                    Var v1=result(n)-result(Ubound(result))                    Var v2=result(n)-result(Ubound(result)-1)                    If result(n).flag=3  Then Swap v1,v2                    Var v=(v1 cross v2)                    Var vL=(result(n)-light)                    Var q=v.unit dot vL.unit        'shade by dot product                    dt=map(-1,1,q,1,.2)             'map dot product to [1,.2]                                        r=Cast(Ubyte Ptr,@result(n).col)[2]*dt                    g=Cast(Ubyte Ptr,@result(n).col)[1]*dt                    b=Cast(Ubyte Ptr,@result(n).col)[0]*dt                End Select                                rad=map(-200,200,result(n).z,2,1)                 Circle(result(n).x,result(n).y),rad,Rgb(r,g,b),,,,f            Next n                        Screenunlock            Sleep regulate(40,fps)        Loop Until Inkey=Chr(27)        Imagedestroy i               Sleep                         `
UEZ
Posts: 618
Joined: May 05, 2017 19:59
Location: Germany

### Re: Endless loop.

Looks very nice. I should also proceed from 2D to 3D stuff...

Maybe a scenario with trees and and a cloudy sky would better fit to the endless looping plane. ^^

Thanks for sharing.
BasicCoder2
Posts: 3585
Joined: Jan 01, 2009 7:03
Location: Australia

### Re: Endless loop.

Dodicat has done some really great pixel cloud 3d demos and has honed the code maximise speed and short but for me mostly unreadable source code. I tried to do a forum search for older examples of pixel cloud 3d by typing Saturn for an example I posted but the search engine turned up nothing! For some time now I haven't been able to motivate myself to code anything.
D.J.Peters
Posts: 8145
Joined: May 28, 2005 3:28
Contact:

### Re: Endless loop.

Nice idea but on older 2.66 GHz Intel CPU I get only 8-10 FPS here ?
We wrote in the 80ths 3D software demos on 386 CPU's with 40-120 MHz !
2660 MHz / 120 MHZ = factor ~22 !

So I can give only 2 from 5 possible stars :-)

Joshy
dodicat
Posts: 6687
Joined: Jan 10, 2006 20:30
Location: Scotland

### Re: Endless loop.

basiccoder2
The forum search is not working properly anymore, I had a request to fix it a while back.
You can try things like saturn "basiccoder2" in Google
or
But it is a bit hit and miss.
UEZ
I thought I would give an off planet (don't know which planet) theme for a change.
Getting the normals off every point in the array is a bit tedious, better to use areas (like quads and triangles in opengl) for any serious 3D work I would say.
Thanks for those two stars D.J.Peters.
xbgtc
Posts: 210
Joined: Oct 14, 2007 5:40
Location: Australia

### Re: Endless loop.

code lost me after 12 lines :)
took about 20 secs in WINFBE to get a window then about 9 secs after "please wait.." :)

Get 10 FPS on Win10 4GB ram 2.6Ghz G620 Intel and Nvidia Geforce GT440 1GB vid
dodicat
Posts: 6687
Joined: Jan 10, 2006 20:30
Location: Scotland

### Re: Endless loop.

xbgtc
You should use -gen gcc -Wc -O3 as compiler options, this is pretty standard for graphics.
Try the 64 bit compiler although the 32 bit compiler is generally better at graphics.
I don't use WINFBE, but I am sure you can set these options (drop down list?)
Another nice ide is fbedit, I use it sometimes, fbide cannot handle uppercase options.
dodicat
Posts: 6687
Joined: Jan 10, 2006 20:30
Location: Scotland

### Re: Endless loop.

I can get 500 frames per second by using straight areas (not points).
Example, 6 circles, light source far top left.

Code: Select all

` Screen 20,32Dim As Integer xres,yresScreeninfo xres,yresType pt    As Single x,y,z    Declare Function length As Single    Declare Function normalize As ptEnd Type#define cross ^#define dot *Dim Shared As pt eyepointeyepoint=Type(xres\2,yres\2,800)Operator -(Byref v1 As pt,Byref v2 As pt) As ptReturn Type(v1.x-v2.x,v1.y-v2.y,v1.z-v2.z)End OperatorOperator * (Byref v1 As pt,Byref v2 As pt) As Single Return v1.x*v2.x+v1.y*v2.y+v1.z*v2.zEnd OperatorOperator ^ (Byref v1 As pt,Byref v2 As pt) As pt Return Type(v1.y*v2.z-v2.y*v1.z,-(v1.x*v2.z-v2.x*v1.z),v1.x*v2.y-v2.x*v1.y)End OperatorFunction pt.length As Single    Return Sqr(x*x+y*y+z*z)End FunctionFunction pt.normalize As pt    Dim n As Single=length    If n=0 Then n=1e-20    Return Type(x/n,y/n,z/n)End FunctionSub fill(p() As pt,c As Ulong,im As Any Ptr=0)    Dim As Long Sy=1e8,By=-1e8,i    Redim As Long a(Ubound(p)-Lbound(p)+1,1)    Dim As Long ctr    For i =Lbound(p) To Ubound(p)        a(ctr,0)=p(i).x        a(ctr,1)=p(i).y        If Sy>p(i).y Then Sy=p(i).y        If By<p(i).y Then By=p(i).y        ctr+=1    Next i    Dim As Long j,k,dy,dx,x,y,xi(Ubound(a,1))    Dim As Single S(Ubound(a,1))    a(Ubound(a,1),0) = a(0,0)    a(Ubound(a,1),1) = a(0,1)    For i=0 To Ubound(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 Ubound(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 iNext yEnd SubFunction RotateArray(wa() As pt,result() As pt,angle As pt,centre As pt,flag As Long=0)As pt    Dim As Single dx,dy,dz,w,cx,cy,cz    Dim As Single SinAX=Sin(angle.x)    Dim As Single SinAY=Sin(angle.y)    Dim As Single SinAZ=Sin(angle.z)    Dim As Single CosAX=Cos(angle.x)    Dim As Single CosAY=Cos(angle.y)    Dim As Single CosAZ=Cos(angle.z)    Redim result(Lbound(wa) To Ubound(wa))    For z As Long=Lbound(wa) To Ubound(wa)        dx=wa(z).x-centre.x        dy=wa(z).y-centre.y        dz=wa(z).z-centre.z        Result(z).x=((Cosay*Cosaz)*dx+(-Cosax*Sinaz+Sinax*Sinay*Cosaz)*dy+(Sinax*Sinaz+Cosax*Sinay*Cosaz)*dz)+centre.x        result(z).y=((Cosay*Sinaz)*dx+(Cosax*Cosaz+Sinax*Sinay*Sinaz)*dy+(-Sinax*Cosaz+Cosax*Sinay*Sinaz)*dz)+centre.y        result(z).z=((-Sinay)*dx+(Sinax*Cosay)*dy+(Cosax*Cosay)*dz)+centre.z        #macro perspective()        w = 1 + (result(z).z/eyepoint.z)        result(z).x = (result(z).x-eyepoint.x)/w+eyepoint.x         result(z).y = (result(z).y-eyepoint.y)/w+eyepoint.y        result(z).z = (result(z).z-eyepoint.z)/w+eyepoint.z        #endmacro        If flag =1 Or flag=3 Then: perspective():End If        If flag=2 Or flag=3 Then            cx+=Result(z).x            cy+=Result(z).y            cz+=Result(z).z        End If        'result(z).col=wa(z).col        ' result(z).flag=wa(z).flag    Next z    If flag=2 Or flag=3 Then        Var t=Ubound(result)-Lbound(result)+1        Return Type<pt>(cx/t,cy/t,cz/t)    End IfEnd FunctionSub sort(a() As pt,p() As Long)    For n1 As Long=1 To 5        For n2 As Long=n1+1 To 6            If a(n1).z<a(n2).z Then                Swap a(n1),a(n2)                Swap p(n1),p(n2)            End If        Next n2    Next n1End SubFunction Regulate(Byval MyFps As Long,Byref fps As Long=0) As Long    Static As Double timervalue,_lastsleeptime,t3,frames    Var t=Timer    frames+=1    If (t-t3)>=1 Then t3=t:fps=frames:frames=0    Var sleeptime=_lastsleeptime+((1/myfps)-T+timervalue)*1000    If sleeptime<1 Then sleeptime=1    _lastsleeptime=sleeptime    timervalue=T    Return sleeptimeEnd FunctionFunction drawline(p As pt,angle As Double,length As Double)As pt    angle=angle*.0174532925199433  '=4*atn(1)/180    Dim As pt p2    p2.x=p.x+length*Cos(angle)    p2.y=p.y-length*Sin(angle)    Return p2End FunctionFunction getcircle(xm As Long, ym As Long, r As Long,p() As pt) As pt    Redim p(0 To 359)    Dim As Long count    Dim As pt ctr=Type(xm,ym)    For n As Long=1 To 360 Step 9        p(count)=drawline(ctr,n,r)         count+=1    Next n    Redim Preserve p(count-1)    Return ctrEnd FunctionSub getshade(Byref c As Ulong,p() As pt,light As pt,mdl As pt)    #define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)    Var q=p(Ubound(p)/4) 'get a good cross product    Var v1=( (p(2)-mdl) cross (q-mdl)).normalize    Var v2=(mdl-light).normalize    Var dt=v1 dot v2    Var r=Cast(Ubyte Ptr,@c)[2]    Var g=Cast(Ubyte Ptr,@c)[1]    Var b=Cast(Ubyte Ptr,@c)[0]    Var f=map(-1,1,dt,1,.3)    c=Rgb(r*f,g*f,b*f)End SubDim As Single pi=4*Atn(1)Redim As pt rot()Redim As pt f(),r(),b(),l(),t(),u()'front,right,back,left,top,undernerathDim As pt centre,centres(1 To 6)   'centre of each faceDim As Long painter(1 To 6)        'get drawing orderDim As Long size=200               'radiuscentre=getcircle(xres\2,yres\2,size,f()) 'centre of first facecentres(1)=centre                        centre.z+=size                            'now centre of 3d shape 'rotate first face,f(), into the other five positions to fill the arrayscentres(2)=rotatearray(f(),r(),Type(0,pi/2,0),centre,2)centres(3)=rotatearray(f(),b(),Type(0,pi,0),centre,2)centres(4)=rotatearray(f(),l(),Type(0,(3/2)*pi,0),centre,2)centres(5)=rotatearray(f(),t(),Type(pi/2,0,0),centre,2)centres(6)=rotatearray(f(),u(),Type((3/2)*pi,0,0),centre,2)Dim As Single aDim As Ulong colourDim As Long fpsDim As pt light=Type(-500,-500,size)     'light sourceDim As pt rotatorRedim As pt rot2()Do        For n As Long=1 To 6        painter(n)=n    Next    a+=.002    rotator=Type(a,a/2,a)    Screenlock    Cls        Draw String(20,20),"Framerate "&fps    rotatearray(centres(),rot(),rotator,Type(xres\2,yres\2,size),1)        sort(rot(),painter())            For n As Long=1 To 6        Select Case painter(n)        Case 1            Var r= rotatearray(f(),rot2(),rotator,centre,3)             colour=Rgb(255,0,0)            getshade(colour,rot2(),light,r)            fill(rot2(),colour)        Case 2            Var r= rotatearray(r(),rot2(),rotator,centre,3)            colour=Rgb(0,255,0)            getshade(colour,rot2(),light,r)            fill(rot2(),colour)        Case 3            Var r=rotatearray(b(),rot2(),rotator,centre,3)            colour=Rgb(0,0,255)            getshade(colour,rot2(),light,r)            fill(rot2(),colour)          Case 4            Var r= rotatearray(l(),rot2(),rotator,centre,3)            colour=Rgb(255,100,0)            getshade(colour,rot2(),light,r)            fill(rot2(),colour)        Case 5            Var r= rotatearray(t(),rot2(),rotator,centre,3)            colour=Rgb(0,255,255)            getshade(colour,rot2(),light,r)            fill(rot2(),colour)        Case 6            Var r=rotatearray(u(),rot2(),rotator,centre,3)            colour=Rgb(255,255,255)            getshade(colour,rot2(),light,r)            fill(rot2(),colour)        End Select    Next n        Screenunlock    Sleep regulate(500,fps),1Loop Until Len(Inkey)`
xbgtc
Posts: 210
Joined: Oct 14, 2007 5:40
Location: Australia

### Re: Endless loop.

Oh WOW dunno what those switches did but starts much faster and now get 13 FPS and with 64bit 16/17 :)

I usually use FBIde but that only has v1.1 on it and every time i run example code from the forum it always comes up with errors so now i just run example code in WinFBE as it's still installed and came with v1.07 so always works :)

Yeh seen Joshy's FBEdit but have never tried it as been using FBIde since i started FB basically and just stuck with it - maybe try it one day :)

Anyway nice demos and the last code get 65 with both 32 and 64bit BUT you get 500!! must have a fast system!
dodicat
Posts: 6687
Joined: Jan 10, 2006 20:30
Location: Scotland

### Re: Endless loop.

Hi xbgtc
I think your sleep 1 (which you will get with the speed regulator set very high) is actually the 15 millisecond sleep.
Try this (windows)
at the top
Declare Function settimer Alias "timeBeginPeriod"(As Ulong=1) As Long
Declare Function freetimer Alias "timeEndPeriod" (As Ulong=1) As Long

at sleep

settimer
Sleep regulate(500,fps),1
freetimer

Like this:

Code: Select all

` Declare Function settimer Alias "timeBeginPeriod"(As Ulong=1) As LongDeclare Function freetimer Alias "timeEndPeriod" (As Ulong=1) As LongScreen 20,32Dim As Integer xres,yresScreeninfo xres,yresType pt    As Single x,y,z    Declare Function length As Single    Declare Function normalize As ptEnd Type#define cross ^#define dot *Dim Shared As pt eyepointeyepoint=Type(xres\2,yres\2,800)Operator -(Byref v1 As pt,Byref v2 As pt) As ptReturn Type(v1.x-v2.x,v1.y-v2.y,v1.z-v2.z)End OperatorOperator * (Byref v1 As pt,Byref v2 As pt) As Single Return v1.x*v2.x+v1.y*v2.y+v1.z*v2.zEnd OperatorOperator ^ (Byref v1 As pt,Byref v2 As pt) As pt Return Type(v1.y*v2.z-v2.y*v1.z,-(v1.x*v2.z-v2.x*v1.z),v1.x*v2.y-v2.x*v1.y)End OperatorFunction pt.length As Single    Return Sqr(x*x+y*y+z*z)End FunctionFunction pt.normalize As pt    Dim n As Single=length    If n=0 Then n=1e-20    Return Type(x/n,y/n,z/n)End FunctionSub fill(p() As pt,c As Ulong,im As Any Ptr=0)    Dim As Long Sy=1e8,By=-1e8,i    Redim As Long a(Ubound(p)-Lbound(p)+1,1)    Dim As Long ctr    For i =Lbound(p) To Ubound(p)        a(ctr,0)=p(i).x        a(ctr,1)=p(i).y        If Sy>p(i).y Then Sy=p(i).y        If By<p(i).y Then By=p(i).y        ctr+=1    Next i    Dim As Long j,k,dy,dx,x,y,xi(Ubound(a,1))    Dim As Single S(Ubound(a,1))    a(Ubound(a,1),0) = a(0,0)    a(Ubound(a,1),1) = a(0,1)    For i=0 To Ubound(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 Ubound(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 iNext yEnd SubFunction RotateArray(wa() As pt,result() As pt,angle As pt,centre As pt,flag As Long=0)As pt    Dim As Single dx,dy,dz,w,cx,cy,cz    Dim As Single SinAX=Sin(angle.x)    Dim As Single SinAY=Sin(angle.y)    Dim As Single SinAZ=Sin(angle.z)    Dim As Single CosAX=Cos(angle.x)    Dim As Single CosAY=Cos(angle.y)    Dim As Single CosAZ=Cos(angle.z)    Redim result(Lbound(wa) To Ubound(wa))    For z As Long=Lbound(wa) To Ubound(wa)        dx=wa(z).x-centre.x        dy=wa(z).y-centre.y        dz=wa(z).z-centre.z        Result(z).x=((Cosay*Cosaz)*dx+(-Cosax*Sinaz+Sinax*Sinay*Cosaz)*dy+(Sinax*Sinaz+Cosax*Sinay*Cosaz)*dz)+centre.x        result(z).y=((Cosay*Sinaz)*dx+(Cosax*Cosaz+Sinax*Sinay*Sinaz)*dy+(-Sinax*Cosaz+Cosax*Sinay*Sinaz)*dz)+centre.y        result(z).z=((-Sinay)*dx+(Sinax*Cosay)*dy+(Cosax*Cosay)*dz)+centre.z        #macro perspective()        w = 1 + (result(z).z/eyepoint.z)        result(z).x = (result(z).x-eyepoint.x)/w+eyepoint.x         result(z).y = (result(z).y-eyepoint.y)/w+eyepoint.y        result(z).z = (result(z).z-eyepoint.z)/w+eyepoint.z        #endmacro        If flag =1 Or flag=3 Then: perspective():End If        If flag=2 Or flag=3 Then            cx+=Result(z).x            cy+=Result(z).y            cz+=Result(z).z        End If        'result(z).col=wa(z).col        ' result(z).flag=wa(z).flag    Next z    If flag=2 Or flag=3 Then        Var t=Ubound(result)-Lbound(result)+1        Return Type<pt>(cx/t,cy/t,cz/t)    End IfEnd FunctionSub sort(a() As pt,p() As Long)    For n1 As Long=1 To 5        For n2 As Long=n1+1 To 6            If a(n1).z<a(n2).z Then                Swap a(n1),a(n2)                Swap p(n1),p(n2)            End If        Next n2    Next n1End SubFunction Regulate(Byval MyFps As Long,Byref fps As Long=0) As Long    Static As Double timervalue,_lastsleeptime,t3,frames    Var t=Timer    frames+=1    If (t-t3)>=1 Then t3=t:fps=frames:frames=0    Var sleeptime=_lastsleeptime+((1/myfps)-T+timervalue)*1000    If sleeptime<1 Then sleeptime=1    _lastsleeptime=sleeptime    timervalue=T    Return sleeptimeEnd FunctionFunction drawline(p As pt,angle As Double,length As Double)As pt    angle=angle*.0174532925199433  '=4*atn(1)/180    Dim As pt p2    p2.x=p.x+length*Cos(angle)    p2.y=p.y-length*Sin(angle)    Return p2End FunctionFunction getcircle(xm As Long, ym As Long, r As Long,p() As pt) As pt    Redim p(0 To 359)    Dim As Long count    Dim As pt ctr=Type(xm,ym)    For n As Long=1 To 360 Step 9        p(count)=drawline(ctr,n,r)         count+=1    Next n    Redim Preserve p(count-1)    Return ctrEnd FunctionSub getshade(Byref c As Ulong,p() As pt,light As pt,mdl As pt)    #define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)    Var q=p(Ubound(p)/4) 'get a good cross product    Var v1=( (p(2)-mdl) cross (q-mdl)).normalize    Var v2=(mdl-light).normalize    Var dt=v1 dot v2    Var r=Cast(Ubyte Ptr,@c)[2]    Var g=Cast(Ubyte Ptr,@c)[1]    Var b=Cast(Ubyte Ptr,@c)[0]    Var f=map(-1,1,dt,1,.3)    c=Rgb(r*f,g*f,b*f)End SubDim As Single pi=4*Atn(1)Redim As pt rot()Redim As pt f(),r(),b(),l(),t(),u()'front,right,back,left,top,undernerathDim As pt centre,centres(1 To 6)   'centre of each faceDim As Long painter(1 To 6)        'get drawing orderDim As Long size=200               'radiuscentre=getcircle(xres\2,yres\2,size,f()) 'centre of first facecentres(1)=centre                        centre.z+=size                            'now centre of 3d shape 'rotate first face,f(), into the other five positions to fill the arrayscentres(2)=rotatearray(f(),r(),Type(0,pi/2,0),centre,2)centres(3)=rotatearray(f(),b(),Type(0,pi,0),centre,2)centres(4)=rotatearray(f(),l(),Type(0,(3/2)*pi,0),centre,2)centres(5)=rotatearray(f(),t(),Type(pi/2,0,0),centre,2)centres(6)=rotatearray(f(),u(),Type((3/2)*pi,0,0),centre,2)Dim As Single aDim As Ulong colourDim As Long fpsDim As pt light=Type(-500,-500,size)     'light sourceDim As pt rotatorRedim As pt rot2()Do        For n As Long=1 To 6        painter(n)=n    Next    a+=.002    rotator=Type(a,a/2,a)    Screenlock    Cls        Draw String(20,20),"Framerate "&fps    rotatearray(centres(),rot(),rotator,Type(xres\2,yres\2,size),1)        sort(rot(),painter())            For n As Long=1 To 6        Select Case painter(n)        Case 1            Var r= rotatearray(f(),rot2(),rotator,centre,3)             colour=Rgb(255,0,0)            getshade(colour,rot2(),light,r)            fill(rot2(),colour)        Case 2            Var r= rotatearray(r(),rot2(),rotator,centre,3)            colour=Rgb(0,255,0)            getshade(colour,rot2(),light,r)            fill(rot2(),colour)        Case 3            Var r=rotatearray(b(),rot2(),rotator,centre,3)            colour=Rgb(0,0,255)            getshade(colour,rot2(),light,r)            fill(rot2(),colour)          Case 4            Var r= rotatearray(l(),rot2(),rotator,centre,3)            colour=Rgb(255,100,0)            getshade(colour,rot2(),light,r)            fill(rot2(),colour)        Case 5            Var r= rotatearray(t(),rot2(),rotator,centre,3)            colour=Rgb(0,255,255)            getshade(colour,rot2(),light,r)            fill(rot2(),colour)        Case 6            Var r=rotatearray(u(),rot2(),rotator,centre,3)            colour=Rgb(255,255,255)            getshade(colour,rot2(),light,r)            fill(rot2(),colour)        End Select    Next n        Screenunlock    settimer    Sleep regulate(500,fps),1    freetimerLoop Until Len(Inkey)' `
D.J.Peters
Posts: 8145
Joined: May 28, 2005 3:28
Contact:

### Re: Endless loop.

xbgtc wrote:... Yeh seen Joshy's FBEdit but have never tried ...
What I wrote an editor that's new for me :-)

FBEdit is from "KetilO" https://www.freebasic.net/forum/viewtopic.php?f=8&t=13932

Joshy
dodicat
Posts: 6687
Joined: Jan 10, 2006 20:30
Location: Scotland

### Re: Endless loop.

D.J.Peters.
You nearly wrote one yesterday (rich edit).
Another couple of hours spent on that would produce a perfectly good IDE.
deltarho[1859]
Posts: 2603
Joined: Jan 02, 2017 0:34
Location: UK

### Re: Endless loop.

The resolution of Sleep is too coarse in dodicat's 'Sleep regulate(<whatever>,fps)'. Requesting a Sleep of less than 15.625ms, and we get 15.625ms whether we like it or not.

Declare Function settimer Alias "timeBeginPeriod"(As Ulong=1) As Long
settimer

to dodicat's graphics programs which use 'regulate' and get a 1ms resolution Sleep.

The opening post went from 20fps to 28fps. OK, no big deal but still an increase of 40% for just a couple of lines of code.
dodicat
Posts: 6687
Joined: Jan 10, 2006 20:30
Location: Scotland

### Re: Endless loop.

deltarho.
My regulate function regulates regardless of 1 or 15.625 milliseconds sleep.
If you have 15.625 as sleep 1 then it will regulate to about 60 fps or whatever the max fps the machine can achieve.
deltarho[1859]
Posts: 2603
Joined: Jan 02, 2017 0:34
Location: UK

### Re: Endless loop.

dodicat wrote:My regulate function regulates regardless of 1 or 15.625 milliseconds sleep.

Obviously.
If you have 15.625 as sleep 1 then it will regulate to about 60 fps or whatever the max fps the machine can achieve.

OK, so why when I am using '-fpu sse -arch 686 -gen gcc -Wc -O3' with gcc 8.3 (the fastest version with this code) on an i7 3.9GHz I am only getting 20fps?