Endless loop.

[dodicat]

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 v3
End Type

Type Line
    As v3 v1,v2
End Type
#define cross ^
#define dot *
Operator + (Byref v1 As v3,Byref v2 As v3) As v3
Return Type(v1.x+v2.x,v1.y+v2.y,v1.z+v2.z)
End Operator
Operator -(Byref v1 As v3,Byref v2 As v3) As v3
Return Type(v1.x-v2.x,v1.y-v2.y,v1.z-v2.z)
End Operator
Operator * (Byval f As Single,Byref v1 As v3) As v3
Return Type(f*v1.x,f*v1.y,f*v1.z)
End Operator
Operator * (Byref v1 As v3,Byref v2 As v3) As Single 
Return v1.x*v2.x+v1.y*v2.y+v1.z*v2.z
End Operator
Operator ^ (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 Operator
Operator <>(Byref v1 As V3,Byref v2 As V3) As Integer
Return (v1.x<>v2.x) Or (v1.y<>v2.y)
End Operator

Function v3.length As Single
    Return Sqr(x*x+y*y+z*z)
End Function

Function 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 Function

Type _float As V3

Dim 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]

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]

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]

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]

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
site:freebasic.net "saturn" in Google
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]

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]

xbgtc
You should use -gen gcc -Wc -O3 as compiler options, this is pretty standard for graphics.
Framerate of about 25 here.
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]

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,32
Dim As Integer xres,yres
Screeninfo xres,yres

Type pt
    As Single x,y,z
    Declare Function length As Single
    Declare Function normalize As pt
End Type
#define cross ^
#define dot *
Dim Shared As pt eyepoint
eyepoint=Type(xres\2,yres\2,800)
Operator -(Byref v1 As pt,Byref v2 As pt) As pt
Return Type(v1.x-v2.x,v1.y-v2.y,v1.z-v2.z)
End Operator

Operator * (Byref v1 As pt,Byref v2 As pt) As Single 
Return v1.x*v2.x+v1.y*v2.y+v1.z*v2.z
End Operator

Operator ^ (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 Operator

Function pt.length As Single
    Return Sqr(x*x+y*y+z*z)
End Function

Function 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 Function


Sub 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 i
Next y
End Sub

Function 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 If
End Function

Sub 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 n1
End Sub

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

Function 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 p2
End Function

Function 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 ctr
End Function

Sub 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 Sub

Dim As Single pi=4*Atn(1)
Redim As pt rot()
Redim As pt f(),r(),b(),l(),t(),u()'front,right,back,left,top,undernerath
Dim As pt centre,centres(1 To 6)   'centre of each face
Dim As Long painter(1 To 6)        'get drawing order
Dim As Long size=200               'radius
centre=getcircle(xres\2,yres\2,size,f()) 'centre of first face
centres(1)=centre                        
centre.z+=size                            'now centre of 3d shape 
'rotate first face,f(), into the other five positions to fill the arrays
centres(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 a
Dim As Ulong colour
Dim As Long fps
Dim As pt light=Type(-500,-500,size)     'light source
Dim As pt rotator
Redim 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),1
Loop Until Len(Inkey)

[xbgtc]

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]

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 Long
Declare Function freetimer Alias "timeEndPeriod" (As Ulong=1) As Long

Screen 20,32
Dim As Integer xres,yres
Screeninfo xres,yres

Type pt
    As Single x,y,z
    Declare Function length As Single
    Declare Function normalize As pt
End Type
#define cross ^
#define dot *
Dim Shared As pt eyepoint
eyepoint=Type(xres\2,yres\2,800)
Operator -(Byref v1 As pt,Byref v2 As pt) As pt
Return Type(v1.x-v2.x,v1.y-v2.y,v1.z-v2.z)
End Operator

Operator * (Byref v1 As pt,Byref v2 As pt) As Single 
Return v1.x*v2.x+v1.y*v2.y+v1.z*v2.z
End Operator

Operator ^ (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 Operator

Function pt.length As Single
    Return Sqr(x*x+y*y+z*z)
End Function

Function 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 Function


Sub 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 i
Next y
End Sub

Function 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 If
End Function

Sub 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 n1
End Sub

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

Function 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 p2
End Function

Function 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 ctr
End Function

Sub 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 Sub

Dim As Single pi=4*Atn(1)
Redim As pt rot()
Redim As pt f(),r(),b(),l(),t(),u()'front,right,back,left,top,undernerath
Dim As pt centre,centres(1 To 6)   'centre of each face
Dim As Long painter(1 To 6)        'get drawing order
Dim As Long size=200               'radius
centre=getcircle(xres\2,yres\2,size,f()) 'centre of first face
centres(1)=centre                        
centre.z+=size                            'now centre of 3d shape 
'rotate first face,f(), into the other five positions to fill the arrays
centres(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 a
Dim As Ulong colour
Dim As Long fps
Dim As pt light=Type(-500,-500,size)     'light source
Dim As pt rotator
Redim 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
    freetimer
Loop Until Len(Inkey)

' 

[D.J.Peters]

... Yeh seen Joshy's FBEdit but have never tried ...

What I wrote an editor that's new for me :-)

FBEdit is from "KetilO" viewtopic.php?f=8&t=13932

Joshy

[dodicat]

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]]

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.

I always add:

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]

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]]

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?