Squares

General FreeBASIC programming questions.
Locked
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Squares

Post by dodicat »

Boot hill

Code: Select all


Type pt
    As Single x,y,z
End Type

Type angle
    As Single a(1 To 6)
    Declare Sub set(p As pt)
End Type

Sub angle.set(p As pt) 
    This= Type<angle>({Sin(p.x),Sin(p.y),Sin(p.z),Cos(p.x),Cos(p.y),Cos(p.z)}) 
End Sub

Type square
    As pt p(3)
    As angle a
    As pt ctr
    As Ulong col
    As pt da
    As pt b
    Declare Constructor
    Declare Constructor(As pt,As Single,As pt,As Ulong)
    Declare Sub fill(im As Any Ptr=0)
    Declare Function rotate(As Single,As Single) As square
End Type

#define up <,>
#define down >,<
#macro SetQsort(datatype,fname,b1,b2,dot)
Sub fname(array() As datatype,begin As Long,Finish As Long)
    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  
        
        #define range(f,l) Int(Rnd*((l+1)-(f)))+(f)
        #define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
        Function Rotate(c As pt,p As pt,a As angle,scale As pt=Type<pt>(1,1,1)) As pt
            Dim As Single dx=p.x-c.x,dy=p.y-c.y,dz=p.z-c.z
            Return Type<pt>((scale.x)*((a.a(5)*a.a(6))*dx+(-a.a(4)*a.a(3)+a.a(1)*a.a(2)*a.a(6))*dy+(a.a(1)*a.a(3)+a.a(4)*a.a(2)*a.a(6))*dz)+c.x,_
            (scale.y)*((a.a(5)*a.a(3))*dx+(a.a(4)*a.a(6)+a.a(1)*a.a(2)*a.a(3))*dy+(-a.a(1)*a.a(6)+a.a(4)*a.a(2)*a.a(3))*dz)+c.y,_
            (scale.z)*((-a.a(2))*dx+(a.a(1)*a.a(5))*dy+(a.a(4)*a.a(5))*dz)+c.z)',p.col)
        End Function
        
        Function perspective(p As pt,eyepoint As pt) As pt
            Dim As Single   w=1+(p.z/eyepoint.z)
            Return Type<pt>((p.x-eyepoint.x)/w+eyepoint.x,_
            (p.y-eyepoint.y)/w+eyepoint.y,_
            (p.z-eyepoint.z)/w+eyepoint.z)',p.col)
        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
        
        Constructor square
        End Constructor
        
        Constructor square(x As pt,sz As Single,a As pt,colour As Ulong)
        Dim As Single ht=range(1,3)
        p(0)=x:p(1)=Type(p(0).x+sz,p(0).y)
        p(2)=Type(p(0).x+sz,p(0).y-ht*sz)
        p(3)=Type(p(0).x,p(0).y-ht*sz)
        For n As Long=0 To 3
            p(n).z=x.z
        Next
        ctr=Type<pt>( (p(0).x+p(1).x+p(2).x+p(3).x)/4,(p(0).y+p(1).y+p(2).y+p(3).y)/4, (p(0).z+p(1).z+p(2).z+p(3).z)/4)
        da=a
        col=colour
        End Constructor
        
        Sub square.fill(im As Any Ptr=0)
            #define ub Ubound
            Dim As Long Sy=1e6,By=-1e6,i,j,y,k
            Dim As Single a(Ub(p)+1,1),dx,dy
            For i =0 To Ub(p)
                a(i,0)=p(i).x
                a(i,1)=p(i).y
                If Sy>p(i).y Then Sy=p(i).y
                If By<p(i).y Then By=p(i).y
            Next i
            Dim As Single xi(Ub(a,1)),S(Ub(a,1))
            a(Ub(a,1),0) = a(0,0)
            a(Ub(a,1),1) = a(0,1)
            For i=0 To Ub(a,1)-1
                dy=a(i+1,1)-a(i,1)
                dx=a(i+1,0)-a(i,0)
                If dy=0 Then S(i)=1
                If dx=0 Then S(i)=0
                If dy<>0 Andalso dx<>0 Then S(i)=dx/dy
            Next i
            For y=Sy-1 To By+1
                k=0
                For i=0 To Ub(a,1)-1
                    If (a(i,1)<=y Andalso a(i+1,1)>y) Orelse _
                    (a(i,1)>y Andalso a(i+1,1)<=y) Then
                    xi(k)=(a(i,0)+S(i)*(y-a(i,1)))
                    k+=1
                End If
            Next i
            For j=0 To k-2
                For i=0 To k-2
                    If xi(i)>xi(i+1) Then Swap xi(i),xi(i+1)
                Next i
            Next j
            Dim As Ulong clr
            For i = 0 To k - 2 Step 2
                Line im,(xi(i),y)-(xi(i+1)+1,y),col
            Next i
        Next y
    End Sub
    
    Function square.rotate(r As Single,u As Single) As square
        b.z=da.z
        a.set(b)
        ctr=Type<pt>( (p(0).x+p(1).x+p(2).x+p(3).x)/4,(p(0).y+p(1).y+p(2).y+p(3).y)/4, (p(0).z+p(1).z+p(2).z+p(3).z)/4) 
        Dim As square s=This
        For n As Long=0 To 3
            s.p(n)= ..Rotate(ctr,this.p(n),a)
            s.p(n)= perspective(s.p(n),Type(r,u,1500))
        Next
        Return s
    End Function
    
    
    Dim As Ulong rcolour
    Screen 20,32
    Dim As square s(1 To 400)
    For n As Long=1 To Ubound(s)
        Dim As pt tmp=Type((Rnd-Rnd)/20,(Rnd-Rnd)/20,(Rnd-Rnd)/20)
        
        Dim As Long k=range(1,4)
        Select Case k
        Case 1:rcolour=Rgb(20,20,20)
        Case 2:rcolour=Rgb(200,200,200)
        Case 3:rcolour=Rgb(50,50,50)
        Case 4:rcolour=Rgb(250,250,250)
        End Select
        Var R=Rnd*5400
        s(n)=square(Type<pt>(range(-100,1100),500,R),25,tmp,rcolour)
    Next
    
    SetQsort(square,QsortZ,down,.ctr.z)
    
    Dim As square z(1 To Ubound(s))
    Dim As Long fps
    Dim As Any Ptr i=Imagecreate(1024,768)
    For n As Long=0 To 600
        Var red=map(0,600,n,0,255)
        Var green=map(0,600,n,0,255)
        Var blue=map(0,600,n,100,255)
        Line i,(0,n)-(1024,n),Rgb(red,green,blue)
    Next
    Circle i,(512,10000),10000-410,Rgb(0,100,0),,,,f
    
    Dim As Single x=512,y=768\2,lasty
    Do
        If Multikey(75) Then x-=1
        If Multikey(77) Then x+=1
        If Multikey(80) Then y+=1 'up
        If Multikey(72) Then y-=1 'down
        If Multikey(57) then x=512:y=768\2 'space
        If lasty<>y Then
            Line i,(0,0)-(1024,768),0,bf
            For n As Long=0 To 600
                Var red=map(0,600,n,0,255)
                Var green=map(0,600,n,0,255)
                Var blue=map(0,600,n,100,255)
                Line i,(0,n)-(1024,n),Rgb(red,green,blue)
            Next
            Circle i,(512,10000+(y-768\2)),10000-410,Rgb(0,100,0),,,,f  
        End If
        If x<0 Then x=0
        If x>1024 Then x=1024
        If y>425 Then y=425
        If y<350 Then y=350
        Screenlock
        Cls
        Put(0,0),i,trans
        For n As Long=1 To Ubound(s)
            For m As Long=0 To 3
                s(n).p(m).z-=5
            Next m
            z(n)=s(n).rotate(x,y)
            If s(n).ctr.z<-1480 Then
                Dim As pt tmp=Type((Rnd-Rnd)/20,(Rnd-Rnd)/20,(Rnd-Rnd)/20)
                Dim As Long k=range(1,4)
                Select Case k
                Case 1:rcolour=Rgb(20,20,20)
                Case 2:rcolour=Rgb(200,200,200)
                Case 3:rcolour=Rgb(50,50,50)
                Case 4:rcolour=Rgb(250,250,250)
                End Select
                s(n)=square(Type<pt>(range(-100,1100),500,4000+Rnd*700),25,tmp,rcolour) 
            End If
        Next n
        
        QsortZ(z(),1,Ubound(z))
        
        For n As Long=1 To Ubound(z)
            z(n).fill()
        Next n
        Draw String(10,10), "fps " &fps
        Screenunlock
        lasty=y
        Sleep regulate(60,fps)
    Loop Until Inkey=Chr(27)
    
    Sleep
    
    
     
coderJeff
Site Admin
Posts: 4313
Joined: Nov 04, 2005 14:23
Location: Ontario, Canada
Contact:

Re: Squares

Post by coderJeff »

"boot hill", nice. Time to lock and start pentagrams? :) I will remember the "C" word til I die now, I think. Thanks for that. :)
Locked