Thanks for testing badidea.
The methods in the code can handle three different shapes.
cube, tetrahedron and square (plate).
I did have a try at oop polymorphism for this but got bogged down.
Most of examples of polymorphism have little methods/constructors e.t.c. which say "hello I am here".
But I got bogged down actually doing a real task in each, so I gave up.
Code: Select all
'====== globals ====
type temp as point ptr 'advance notice
Const pi=4*Atn(1)
dim shared lightsource as temp
Dim Shared As integer xres,yres
Screen 20,32,,64 'or 19 or 17
Color Rgb(0,200,0),Rgb(0,0,55)
Screeninfo xres,yres
'====================
Enum
cube
tetra
square
End Enum
Type Point
As Single x,y,z
Declare Static Function rotate(As Point,As Point,As Point,As Point=Type<Point>(1,1,1)) As Point
Declare Static Function perspective(As Point,As Point=Type(xres\2,yres\2,1000)) As Point
Declare Function dot(As Point) As Single
declare sub normalize()
End Type
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,p 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=p.x-c.x,dy=p.y-c.y,dz=p.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(p As Point,eyepoint As Point) As Point
Dim As Single w=1+(p.z/eyepoint.z)
Return Type<Point>((p.x-eyepoint.x)/w+eyepoint.x,_
(p.y-eyepoint.y)/w+eyepoint.y,_
(p.z-eyepoint.z)/w+eyepoint.z)
End Function
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
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
Type shape
As plane f(Any) 'faces
As Point centre
As Point norm(Any) 'normals
As Ulong clr(Any)
As Point aspect
As Point d 'increment speed
Declare Sub Construct(As Long)
Declare Sub translate(v As Point,s As Double)
Declare Sub turn(As Point) 'turn about it's centroid
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 things)
Declare Sub Draw
End Type
Sub shape.construct(flag As Long)
Static As Point g(1 To ...,1 To ...)= _ 'cube
{{(-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
Static As Point t(1 To ...,1 To ...)= _ 'tetra
{{(-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
Static As Point s(1 To ...,1 To ...)= _ 'square
{{(-1,-1,0),(1,-1,0),(1,1,0),(-1,1,0)}}
'================== seperate the three shapes =============
If flag=cube Then
Redim f(1 To 6)
Redim norm(1 To 6)
Redim clr(1 To 6)
For n As Long=1 To 6
Redim (f(n).p)(1 To 4)'faces vertices
Next
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)
End If
If flag=tetra Then
Redim f(1 To 4)
Redim norm(1 To 4)
Redim clr(1 To 4)
For n As Long=1 To 4
Redim (f(n).p)(1 To 3)'faces vertices
Next
norm(1)=Type(0, 0,-0.4082483) 'normals to tetra faces
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)
End If
If flag=square Then
Redim f(1 To 1)
Redim norm(1 To 1)
Redim clr(1 To 1)
For n As Long=1 To Ubound(f)
Redim (f(n).p)(1 To 4)'
Next
norm(1)=Type(0,0,1)
centre=Type(0,0,0)
End If
For n As Long=1 To Ubound(f)
clr(n)=Rgb(Rnd*255,Rnd*255,Rnd*255) 'set a default colour
For m As Long=1 To Ubound(f(n).p)
If flag=cube Then f(n).p(m)= g(n,m) 'set to g()
If flag=tetra Then f(n).p(m)= t(n,m) 'set to t()
If flag=square Then f(n).p(m)= s(n,m) 'set to s()
Next m
Next n
'======================= each shape defined =========
'set some defaults starting aspects
aspect=Type(Rnd*2*pi,Rnd*2*pi,Rnd*2*pi)
For n As Long=1 To Ubound(f)
norm(n)=point.rotate(centre,norm(n),aspect)
For m As Long=1 To Ubound(f(n).p)
f(n).p(m)=point.rotate(centre,f(n).p(m),aspect)
Next
Next
'speeds
d.x=(Rnd-Rnd)/50
d.y=(Rnd-Rnd)/50
d.z=(Rnd-Rnd)/50
End Sub
Sub shape.turn(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)=point.rotate(centre,this.f(n).p(m),p)
tmp.f(n).p(m)=point.perspective(tmp.f(n).p(m))
Next
Next
For n As Long=1 To Ubound(f)
tmp.norm(n)=point.rotate(centre,this.norm(n),p)'normals turn also
Next
tmp.draw
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)=point.rotate(c,this.f(n).p(m),ang)
Next
Next
For n As Long=1 To Ubound(f)
tmp.norm(n)=point.rotate(c,this.norm(n),ang)
Next
tmp.centre=point.rotate(c,this.centre,ang)
Return tmp
End Function
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
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.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
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
'==================== create and run ==============
Randomize 10
Dim As shape c(1 To 8)
c(1).construct(cube)
c(2).construct(cube)
c(3).construct(cube)
c(4).construct(cube)
c(5).construct(cube)
c(6).construct(tetra)
c(7).construct(tetra)
c(Ubound(c)).construct(square)
c(Ubound(c)).clr(1)=Rgba(255,0,0,100)'set colour
dim as single cx=xres\2,cy=yres\2
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) 'cube
c(6).translate(Type(cx,cy-.65*cy,0),cx/10) 'tetra
c(7).translate(Type(cx,cy+.65*cy,0),cx/10) 'tetra
c(8).translate(Type(cx,cy+1.2*cy,0),cx/5) '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
Next
Dim As shape tmp(Lbound(c) To Ubound(c))
Dim As Point a
'fix y and z
a.y=-pi/9
a.z=pi/2
lightsource=new point
*lightsource=type(0,1,0)
Dim As Long fps
#define fmod(x,y) y*frac(x/y)
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)
Draw String (20,20),"Cubes tetrahedrons and a plate. 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)
Next
shape.bsort(tmp())
For n As Long=Lbound(tmp) To Ubound(tmp)
c(n).aspect.x+=c(n).d.x: c(n).aspect.x=fmod(c(n).aspect.x,pi2)'turning angles mod 2pi
c(n).aspect.y+=c(n).d.y: c(n).aspect.y=fmod(c(n).aspect.y,pi2)
c(n).aspect.z+=c(n).d.z: c(n).aspect.z=fmod(c(n).aspect.z,pi2)
tmp(n).turn(Type(tmp(n).aspect.x,tmp(n).aspect.y,tmp(n).aspect.z))
Next
Screenunlock
Sleep regulate(90,fps),1
Loop Until key=Chr(27)
Sleep
delete lightsource