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