I have something like this in squares.
But I have converted it to inheritance.
No need for any other oop features.
, but full of air, so I apologise if I am off topic.
Code: Select all
'====== globals ====
Type temp As Point Ptr 'advance notice
Dim Shared lightsource As temp
Const pi=4*Atn(1)
Dim Shared As Integer xres,yres
Screen 19,32,,64 'screen 20 or 19 or 17
Color Rgb(200,200,200),Rgb(0,0,55)
Screeninfo xres,yres
#define farpoint type<point>(xres\2,yres\2,1000) 'eyepoint
Randomize 10
'======================
Declare Function Fmain() As Long
'run
End Fmain
'types
Type Point
As Single x,y,z
Declare Function rotate(As Point,As Point,As Point=Type<Point>(1,1,1)) As Point
Declare Function perspective(As Point=farpoint) As Point
Declare Function dot(As Point) As Single
End Type
Type plane
As Point p(Any)
Declare Sub Draw(As Ulong)
Declare Static Sub fill(() As Point,As Ulong,As Long,As Long)
End Type
Type Shape 'needs point and plane
As plane f(Any) 'faces
As Point norm(Any) 'normals to faces
As Ulong clr(Any) 'colours
Declare Sub setarrays(As Long,As Long,s() As Point)'set the above in constructors
As Point centre 'centroid
As Point aspect 'orientation in space
As Point d ' speed (dx,dy,dz)
Declare Sub spin(As Point) 'spin about centroid
Declare Sub translate(v As Point,s As Double) 'shift and blow
Declare Function rotate(As Point,As Point) As Shape 'roatate about a chosen point
Declare Static Sub bsort(() As Shape ) 'bubblesort (fast enough for a small number of shapes)
Declare Sub Draw
End Type
Type cube Extends Shape
Declare Constructor
End Type
Type tetra Extends Shape
Declare Constructor
End Type
Type square Extends Shape
Declare Constructor
End Type
'========== methods for shape =========
Sub shape.setarrays(uboundf As Long,uboundp As Long,s() As Point)
Redim f(1 To uboundf)
Redim norm(1 To uboundf)
Redim clr(1 To uboundf)
For n As Long=1 To uboundf
Redim (f(n).p)(1 To uboundp)'faces vertices
Next
For n As Long=1 To uboundf
clr(n)=Rgb(Rnd*255,Rnd*255,Rnd*255) 'set a default colour
For m As Long=1 To uboundp
f(n).p(m)= s(n,m) 'set to s()
Next m
Next n
End Sub
Sub Shape.spin(p As Point)
Dim As Shape tmp=This
For n As Long=1 To Ubound(f)
For m As Long=1 To Ubound(f(n).p)
tmp.f(n).p(m)=this.f(n).p(m).rotate(centre,p)
tmp.f(n).p(m)=tmp.f(n).p(m).perspective()
Next
tmp.norm(n)=tmp.norm(n).rotate(centre,p)'normals spin also
Next
tmp.draw
End Sub
Sub Shape.draw
Static As Ubyte Ptr col
For n As Long=1 To Ubound(f)-1
For m As Long=n+1 To Ubound(f)
If norm(n).z<norm(m).z Then
Swap f(n),f(m)
Swap norm(n),norm(m)
Swap clr(n),clr(m)
End If
Next m
Next n
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
For n As Long=1 To Ubound(f)
col=Cptr(Ubyte Ptr,@clr(n))
Dim As Single cx=norm(n).x-centre.x,cy=norm(n).y-centre.y,cz=norm(n).z-centre.z
Dim As Point k=Type<Point>(cx,cy,cz)
Dim As Single dt=k.dot(*lightsource)
dt=map(1,-1,dt,.3,1)
f(n).draw(Rgba(dt*col[2],dt*col[1],dt*col[0],col[3]))
Next n
End Sub
Sub Shape.translate(v As Point,s As Double)
For n As Long=1 To Ubound(f)
norm(n).x*=s
norm(n).y*=s
norm(n).z*=s
For m As Long=1 To Ubound(f(n).p)
f(n).p(m).x*=s
f(n).p(m).y*=s
f(n).p(m).z*=s
Next m
Next n
For n As Long=1 To Ubound(f)
norm(n).x=norm(n).x+v.x
norm(n).y=norm(n).y+v.y
norm(n).z=norm(n).z+v.z
For m As Long=1 To Ubound(f(n).p)
f(n).p(m).x= f(n).p(m).x+v.x
f(n).p(m).y= f(n).p(m).y+v.y
f(n).p(m).z= f(n).p(m).z+v.z
Next m
Next n
centre.x+=v.x
centre.y+=v.y
centre.z+=v.z
End Sub
Function Shape.rotate(c As Point,ang As Point) As Shape
Dim As Shape tmp=This
For n As Long=1 To Ubound(f)
For m As Long=1 To Ubound(f(n).p)
tmp.f(n).p(m)=this.f(n).p(m).rotate(c,ang)
Next
tmp.norm(n)=this.norm(n).rotate(c,ang)
Next
tmp.centre=this.centre.rotate(c,ang)
Return tmp
End Function
Sub Shape.bsort(c() As Shape)
For n As Long=Lbound(c) To Ubound(c)-1
For m As Long=n+1 To Ubound(c)
If c(n).centre.z<c(m).centre.z Then Swap c(n),c(m)
Next
Next
End Sub
'====================== methods for point ====================
Function point.dot(v2 As Point) As Single 'dot product |v1| * |v2| *cos(angle between v1 and v2)
Dim As Single d1=Sqr(x*x + y*y+ z*z),d2=Sqr(v2.x*v2.x + v2.y*v2.y +v2.z*v2.z)
Dim As Single v1x=x/d1,v1y=y/d1,v1z=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
Function point.Rotate(c As Point,angle As Point,scale As Point) As Point
Dim As Single sx=Sin(angle.x),sy=Sin(angle.y),sz=Sin(angle.z)
Dim As Single cx=Cos(angle.x),cy=Cos(angle.y),cz=Cos(angle.z)
Dim As Single dx=this.x-c.x,dy=this.y-c.y,dz=this.z-c.z
Return Type<Point>((scale.x)*((cy*cz)*dx+(-cx*sz+sx*sy*cz)*dy+(sx*sz+cx*sy*cz)*dz)+c.x,_
(scale.y)*((cy*sz)*dx+(cx*cz+sx*sy*sz)*dy+(-sx*cz+cx*sy*sz)*dz)+c.y,_
(scale.z)*((-sy)*dx+(sx*cy)*dy+(cx*cy)*dz)+c.z)',p.col)
End Function
Function point.perspective(eyepoint As Point) As Point
Dim As Single w=1+(this.z/eyepoint.z)
Return Type<Point>((this.x-eyepoint.x)/w+eyepoint.x,_
(this.y-eyepoint.y)/w+eyepoint.y,_
(this.z-eyepoint.z)/w+eyepoint.z)
End Function
' ================ methods for plane ===================
Sub plane.fill(a() As Point, c As Ulong,min As Long,max As Long)
Static As Long i,j,k,dy,dx, x,y
Static As Long NewX (1 To Ubound(a))
Static As Single Grad(1 To Ubound(a))
For i=1 To Ubound(a) - 1
dy=a(i+1).y-a(i).y
dx=a(i+1).x-a(i).x
If(dy=0) Then Grad(i)=1
If(dx=0) Then Grad(i)=0
If ((dy <> 0) And (dx <> 0)) Then
Grad(i) = dx/dy
End If
Next i
For y=min To max
k = 1
For i=1 To Ubound(a) - 1
If( ((a(i).y<=y) Andalso (a(i+1).y>y)) Or ((a(i).y>y) _
Andalso (a(i+1).y<=y))) Then
NewX(k)= Int(a(i).x+ Grad(i)*(y-a(i).y))
k +=1
End If
Next i
For j = 1 To k-2
For i = 1 To k-2
If NewX(i) > NewX(i+1) Then Swap NewX(i),NewX(i+1)
Next i
Next j
For i = 1 To k - 2 Step 2
Line (NewX(i),y)-(NewX(i+1)+1,y), c
Next i
Next y
End Sub
Sub plane.draw(clr As Ulong )
Static As Long miny=1e6,maxy=-1e6
Redim As Point V1(1 To Ubound(p)+1)
Dim As Long n
For n =1 To Ubound(p)
If miny>p(n).y Then miny=p(n).y
If maxy<p(n).y Then maxy=p(n).y
V1(n)=p(n)
Next
v1(Ubound(v1))=p(Lbound(p))
plane.fill(v1(),clr,miny,maxy)
End Sub
'construct three shapes around origin (0,0,0)
Constructor cube
Static As Point g(1 To ...,1 To ...)= _
{{(-1,-1,-1),(1,-1,-1),(1,1,-1),(-1,1,-1)},_'front
{(1,-1,-1),(1,-1,1),(1,1,1),(1,1,-1)},_ 'right
{(-1,-1,1),(1,-1,1),(1,1,1),(-1,1,1)},_ 'back
{(-1,-1,-1),(-1,-1,1),(-1,1,1),(-1,1,-1)},_ 'left
{(1,1,-1),(1,1,1),(-1,1,1),(-1,1,-1)},_ 'top
{(1,-1,-1),(1,-1,1),(-1,-1,1),(-1,-1,-1)}} 'base
setarrays(6,4,g()) '6 faces,4 face vertices
norm(1)=Type(0,0,-1) 'face normals to cube
norm(2)=Type(1,0,0)
norm(3)=Type(0,0,1)
norm(4)=Type(-1,0,0)
norm(5)=Type(0,1,0)
norm(6)=Type(0,-1,0)
centre=Type(0,0,0)
aspect=Type(Rnd*2*pi,Rnd*2*pi,Rnd*2*pi)
For n As Long=1 To Ubound(f)
norm(n)=norm(n).rotate(centre,aspect)
For m As Long=1 To Ubound(f(n).p)
f(n).p(m)=f(n).p(m).rotate(centre,aspect)
Next
Next
'speeds
d=Type((Rnd-Rnd)/50,(Rnd-Rnd)/50,(Rnd-Rnd)/50)
End Constructor
Constructor tetra
Static As Point t(1 To ...,1 To ...)= _
{{(-1,-1/Sqr(3),-1/Sqr(6)),(1,-1/Sqr(3),-1/Sqr(6)),(0,2/Sqr(3),-1/Sqr(6))}, _ 'b
{(-1,-1/Sqr(3),-1/Sqr(6)),(1,-1/Sqr(3),-1/Sqr(6)),(0,0,3/Sqr(6))},_ 'f
{(1,-1/Sqr(3),-1/Sqr(6)),(0,2/Sqr(3),-1/Sqr(6)),(0,0,3/Sqr(6))}, _ 'r
{(-1,-1/Sqr(3),-1/Sqr(6)),(0,2/Sqr(3),-1/Sqr(6)),(0,0,3/Sqr(6))}} 'l
setarrays(4,3,t())'4 faces,3 face vertices
norm(1)=Type(0, 0,-0.4082483)
norm(2)=Type(0,-0.3849002, 0.1360828)
norm(3)=Type(0.3333333, 0.1924501, 0.1360828)
norm(4)=Type(-0.3333333, 0.1924501, 0.1360828)
centre=Type(0,0,0)
aspect=Type(Rnd*2*pi,Rnd*2*pi,Rnd*2*pi)
For n As Long=1 To Ubound(f)
norm(n)=norm(n).rotate(centre,aspect)
For m As Long=1 To Ubound(f(n).p)
f(n).p(m)=f(n).p(m).rotate(centre,aspect)
Next
Next
'speeds
d=Type((Rnd-Rnd)/50,(Rnd-Rnd)/50,(Rnd-Rnd)/50)
End Constructor
Constructor square
Static As Point s(1 To ...,1 To ...)= _
{{(-1,-1,0),(1,-1,0),(1,1,0),(-1,1,0)}}
setarrays(1,4,s())'1 faces,4 face vertices
norm(1)=Type(0,0,1)
centre=Type(0,0,0)
aspect=Type(Rnd*2*pi,Rnd*2*pi,Rnd*2*pi)
For n As Long=1 To 1
norm(n)=norm(n).rotate(centre,aspect)
For m As Long=1 To 4
f(n).p(m)=f(n).p(m).rotate(centre,aspect)
Next
Next
'speeds
d=Type((Rnd-Rnd)/50,(Rnd-Rnd)/50,(Rnd-Rnd)/50)
End Constructor
'================ end methods ======================
'independent functions
Function Regulate(Byval MyFps As Long,Byref fps As Long) 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 Fmain() As Long
lightsource=New Point(0,1,0)
Dim As Shape Ptr c(1 To 9)={New cube,New cube,New cube,New cube,New cube, _
New tetra,New tetra, _
New square,New square}
c(8)->clr(1)=Rgba(255,0,0,100)'set transparent colour for this square
Dim As Shape tmp(Lbound(c) To Ubound(c))
Dim As Single cx=xres\2,cy=yres\2
'set the screen positions and sizes
c(1)->translate(Type(cx-.5*cx,cy-.6*cy,0),cx/10) 'cube
c(2)->translate(Type(cx+.5*cx,cy-.6*cy,0),cx/10) 'cube
c(3)->translate(Type(cx+.5*cx,cy+.6*cy,0),cx/10) 'cube
c(4)->translate(Type(cx-.5*cx,cy+.6*cy,0),cx/10) 'cube
c(5)->translate(Type(cx,cy,0),cx/5) 'centre cube
c(6)->translate(Type(cx,cy-.75*cy,0),cx/10) 'tetra
c(7)->translate(Type(cx,cy+.75*cy,0),cx/10) 'tetra
c(8)->translate(Type(cx-.75*cy,cy,0),cx/10) 'square
c(9)->translate(Type(cx+.75*cy,cy,0),cx/10) 'square
Dim As Double pi2=2*pi
For n As Long=Lbound(c) To Ubound(c)
*c(n)=c(n)->rotate(Type(xres\2,yres\2,0),Type(0,pi/2,0)) 'flip 90 (set up for rotation).
Next
Dim As Point a
'start angles y and z
a.y=-pi/9
a.z= pi/2
Dim As Long fps
#define fmod(x,y) y*Frac(x/y)
#define circ(n) c(n)->aspect.x=fmod(c(n)->aspect.x,pi2)
Dim As String key
Do
key=Inkey
If key=Chr(255)+"P" Then a.y-=.05 'down
If key=Chr(255)+"H" Then a.y+=.05 'up
If key=Chr(255)+"K" Then a.z-=.05 'right
If key=Chr(255)+"M" Then a.z+=.05 'left
If key=" " Then a.z=pi/2:a.y=-pi/9 'reset
Screenlock
Cls
a.x+=.01:a.x=fmod(a.x,pi2) 'keep within 2*pi
Draw String (20,20),"Cubes tetrahedrons and plates. use arrow and space keys"
Draw String (20,50),"FPS = " &fps
For n As Long=Lbound(c) To Ubound(c)
tmp(n)=c(n)->rotate(Type(xres\2,yres\2,0),a) 'rotate shapes about screen cenre
Next
Shape.bsort(tmp()) 'sort by centre.z
For n As Long=Lbound(tmp) To Ubound(tmp)'advance aspect and spin.
c(n)->aspect.x+=c(n)->d.x:circ(n) 'keep within 2*pi
c(n)->aspect.y+=c(n)->d.y:circ(n)
c(n)->aspect.z+=c(n)->d.z:circ(n)
tmp(n).spin(tmp(n).aspect)
Next
Screenunlock
Sleep regulate(90,fps),1
Loop Until key=Chr(27)
Sleep
For i As Long=Lbound(c) To Ubound(c)
Delete c(i)
Next
Delete lightsource
Return 0
End Function