Code: Select all
Type pt
As Double x,y,z
End Type
Type triangle
As pt p(0 To 2)
As pt ctr
As Ulong col
As pt norm
End Type
Type angle3D 'FLOATS for angles
As Single sx,sy,sz
As Single cx,cy,cz
Declare Static Function construct(As Single,As Single,As Single) As Angle3D
End Type
Function Angle3D.construct(x As Single,y As Single,z As Single) As Angle3D
Return Type (Sin(x),Sin(y),Sin(z), _
Cos(x),Cos(y),Cos(z))
End Function
Function Rotate(c As pt,p As pt,a As Angle3D,scale As pt=Type(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.cy*a.cz)*dx+(-a.cx*a.sz+a.sx*a.sy*a.cz)*dy+(a.sx*a.sz+a.cx*a.sy*a.cz)*dz)+c.x,_
(scale.y)*((a.cy*a.sz)*dx+(a.cx*a.cz+a.sx*a.sy*a.sz)*dy+(-a.sx*a.cz+a.cx*a.sy*a.sz)*dz)+c.y,_
(scale.z)*((-a.sy)*dx+(a.sx*a.cy)*dy+(a.cx*a.cy)*dz)+c.z)
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)
End Function
Function dot(p As pt,v2 As Pt) As Single 'dot product |v1| * |v2| *cos(angle between v1 and v2)
Dim As Single d1=Sqr(p.x*p.x + p.y*p.y+ p.z*p.z),d2=Sqr(v2.x*v2.x + v2.y*v2.y +v2.z*v2.z)
Dim As Single v1x=p.x/d1,v1y=p.y/d1,v1z=p.z/d1 'normalize
Dim As Single v2x=v2.x/d2,v2y=v2.y/d2,v2z=v2.z/d2 'normalize
Return (v1x*v2x+v1y*v2y+v1z*v2z)
End Function
Sub fill(p() As Pt,c As Ulong,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
For i = 0 To k - 2 Step 2
Line im,(xi(i)+1,y)-(xi(i+1)+1-1,y),c
Next i
Next y
End Sub
Sub blow(d() As pt,t As pt,m As Double)
For n As Long=1 To 12
d(n).x=(d(n).x)*m+t.x
d(n).y=(d(n).y)*m+t.y
d(n).z=(d(n).z)*m+t.z
Next
End Sub
Sub setup(p() As triangle,d() As pt,colours() As Ulong)
Dim As Long i
Dim As Double cx,cy,cz
Dim As pt centre=Type(1024\2,768\2,0)
For n As Long=1 To 20
cx=0:cy=0:cz=0
For k As Long=0 To 2
Read i
p(n).p(k)=d(i)
cx+=d(i).x
cy+=d(i).y
cz+=d(i).z
Next k
p(n).ctr=Type(cx/3,cy/3,cz/3)
p(n).norm=Type(p(n).ctr.x-centre.x,p(n).ctr.y-centre.y,p(n).ctr.z-centre.z)
p(n).col=colours(n)
Next n
End Sub
Sub shadow(p() As triangle)
Dim As triangle tmp
For n As Long=Lbound(p) To Ubound(p)
tmp=p(n)
tmp.p(0).x=p(n).p(0).x+200
tmp.p(1).x=p(n).p(1).x+200
tmp.p(2).x=p(n).p(2).x+200
fill(tmp.p(),Rgba(0,0,0,100))
Next n
End Sub
Sub show(p() As triangle)
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
Dim As pt lightsource
lightsource=Type(.5,0,.5)
For n As Long=Lbound(p)+9 To Ubound(p)
Var col=Cptr(Ubyte Ptr,@p(n).col)
Dim As Single dt=dot(p(n).norm,lightsource)
Var dtt=map(1,-1,dt,.1,1)
Dim As Ulong clr=Rgb(dtt*col[2],dtt*col[1],dtt*col[0])
fill(p(n).p(),clr)
Next n
End Sub
Sub sort(p() As triangle)
For n1 As Long =Lbound(p) To Ubound(p)-1
For n2 As Long=n1+1 To Ubound(p)
If p(n1).ctr.z<p(n2).ctr.z Then Swap p(n1),p(n2)
Next n2
Next n1
End Sub
Function Regulate(Byval MyFps As Long,Byref fps As Long) As Long
Static As Double timervalue,lastsleeptime,t3,frames
frames+=1
If (Timer-t3)>=1 Then t3=Timer:fps=frames:frames=0
Var sleeptime=lastsleeptime+((1/myfps)-Timer+timervalue)*1000
If sleeptime<1 Then sleeptime=1
lastsleeptime=sleeptime
timervalue=Timer
Return sleeptime
End Function
Sub setcolours(colours() As Ulong,colour As Ulong=Rgb(100,255,0))
For n As Long=1 To 20
colours(n)=Rgb(0,255,0)
Next n
End Sub
Function rainbow( x As Single ) As Ulong 'idea from bluatigro
Static As Double pi=4*Atn(1)
#define rad(n) (pi/180)*(n)
Dim As Ulong r , g , b
r = Sin( rad( x ) ) * 127 + 128
g = Sin( rad( x - 120 ) ) * 127 + 128
b = Sin( rad( x + 120 ) ) * 127 + 128
Return Rgb( r And 255 , g And 255 , b And 255 )
End Function
'===============================================================================
Dim As pt d(1 To 12)={ _
(0.000000,-0.525731,0.850651), _
(0.850651,0.000000,0.525731), _
(0.850651,0.000000,-0.525731), _
(-0.850651,0.000000,-0.525731), _
(-0.850651,0.000000,0.525731), _
(-0.525731,0.850651,0.000000), _
(0.525731,0.850651,0.000000), _
(0.525731,-0.850651,0.000000), _
(-0.525731,-0.850651,0.000000), _
(0.000000,-0.525731,-0.850651), _
(0.000000,0.525731,-0.850651), _
(0.000000,0.525731,0.850651)}
Dim As Ulong colours(1 To 20)
Dim As triangle p(1 To 20),rot(1 To 20),shade(1 To 20)
blow(d(),Type(1024\2,768\2,0),200)
setcolours(colours())
setup(p(),d(),colours())
Dim As Angle3D A3d
Dim As pt ang
Dim As pt c=Type(1024\2,768\2,0)
Dim As Long fps,flag,mx,my,btn
Screen 20,32,,64
Dim As Any Ptr i=Imagecreate(1024,768)
For x As Long=0 To 1023
For y As Long=0 To 767
Pset i,(x,y),rainbow(Sqr((x+50)^2+(y+50)^2))
Next
Next
windowtitle "Click for colour"
Do
ang.x+=.03/2 'the orbiting speed
ang.y+=.02/2
ang.z+=.01/2
Getmouse(mx,my,,btn)
If btn And flag=0 And Point(mx,my)<>rgb(255,255,255) Then
flag=1
setcolours(colours(),Point(mx,my))
For n As Long=1 To 20
p(n).col=Point(mx,my)
Next n
End If
A3D=Angle3D.construct(ang.x,ang.y,ang.z)
For n As Long=1 To 20
For m As Long=0 To 2
shade(n).p(m)=Rotate(c,p(n).p(m),A3D,Type(.8,.8,.8))
rot(n).p(m)=Rotate(c,p(n).p(m),A3D)
shade(n).p(m)=perspective(shade(n).p(m),Type(1024\2,768\2,2000))
rot(n).p(m)=perspective(rot(n).p(m),Type(1024\2,768\2,2000))
Next m
shade(n).ctr=Rotate(c,p(n).ctr,A3D,Type(.8,.8,.8))
rot(n).ctr=Rotate(c,p(n).ctr,A3D)
rot(n).norm=Type(rot(n).ctr.x-c.x,rot(n).ctr.y-c.y,rot(n).ctr.z)
rot(n).col=p(n).col
Next n
sort(rot())
Screenlock
Cls
Circle(200,100),20,Rgb(100,255,0),,,,f
Circle(500,100),20,Rgb(255,100,0),,,,f
Circle(800,100),20,Rgb(0,100,255),,,,f
Put(0,0),i,Pset
Draw String(20,20),"framerate = " &fps
shadow(shade())
show(rot())
Screenunlock
Sleep regulate(65,fps)
flag=btn
Loop Until Len(Inkey)
Sleep
imagedestroy(i)
triangles:
Data _
2,3, 7, _
2, 8, 3, _
4, 5, 6, _
5, 4, 9, _
7, 6, 12, _
6, 7, 11, _
10, 11, 3, _
11, 10, 4, _
8, 9, 10, _
9, 8, 1, _
12, 1, 2, _
1, 12, 5, _
7, 3, 11, _
2, 7, 12, _
4, 6, 11, _
6, 5, 12, _
3, 8, 10, _
8, 2, 1, _
4, 10, 9, _
5, 9, 1