Here is a gold plated cube.
Code: Select all
Screen 19,32 ' or 20 or 21
Dim As Long xr,yr
Screeninfo xr,yr
Color Rgb(192,192,192),Rgb(0,0,0)
Windowtitle "Golden cube"
Type V3
As Single x,y,z
End Type
Type angle3D 'FLOATS for angles for rotator
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 v3,p As v3,a As Angle3D,scale As v3=Type(1,1,1)) As v3
Dim As Single dx=p.x-c.x,dy=p.y-c.y,dz=p.z-c.z
Return Type<v3>((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 v3,eyepoint As v3) As v3
Dim As Single w=1+(p.z/eyepoint.z)
Return Type<v3>((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 v3,v2 As v3) 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 DrawCubeFace(d() As V3,id As Long,c As Ulong)
'source of c code: http://code-heaven.blogspot.it/2009/10/simple-c-program-for-scan-line-polygon.html
'Some help from Pitto in translation
Static As v3 p(3)
For z As Long=1 To 4
p(z-1)=d(id,z)'transfer to a simple 1 D array 0 to 3
Next z
#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 (xi(i)+0,y)-(xi(i+1)+1-0,y),c
Next i
Next y
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
Sub sort(FaceCentroids() As V3,painter() As Long)
For p1 As Long = 1 To 5
For p2 As Long = p1 + 1 To 6
If FaceCentroids(p1).z<FaceCentroids(p2).z Then Swap painter(p1),painter(p2):Swap FaceCentroids(p1),FaceCentroids(p2)
Next p2
Next p1
End Sub
Sub Expand(p() As V3,b As Single,shift As V3,i As Long)
For n As Long=1 To 4
p(i,n).x=b*p(i,n).x+shift.x
p(i,n).y=b*p(i,n).y+shift.y
p(i,n).z=b*p(i,n).z+shift.z
Next n
End Sub
'================================= USE ===============================
'set the cube faces on (0,0,0) as centre
Dim As V3 Cube(1 To 6,1 To 4)= _
{{(-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
'blow up and translate the cube to screen centre
For i As Long=1 To 6
Expand (Cube(),(xr+yr)/10,Type<v3>(xr/2,yr/2,0),i)
Next i
Dim As V3 W(1 To 6,1 To 4)'the working array
Dim As V3 eye= Type<V3>(xr/2,yr/2/2,xr+yr/2)
Dim As V3 fulcrum=Type<V3>(xr/2,yr/2,0) ' middle of cube
Dim As Long fps
Dim As Long painter(1 To 6)={1,2,3,4,5,6} 'fill order
Dim As v3 FaceCentroid(1 To 6) 'Centroids of cube faces
Dim As Single cx,cy,cz 'elements for centroids
Dim As Single x,y,z 'increments
Var colour=Rgb(255,215,0)
Var col=Cptr(Ubyte Ptr,@colour)
Var lightsource=Type<v3>(1,0,0)
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
Do
x+=.01/2 'increments
y+=.02/2
z+=.03/2
For m As Long=1 To 6
cx=0:cy=0:cz=0
For n As Long=1 To 4
W(m,n)=Rotate(fulcrum,Cube(m,n),Angle3D.construct(x,y,z))
W(m,n)=perspective(W(m,n),eye) 'apply the eye (perspective)
cx+=W(m,n).x:cy+=W(m,n).y:cz+=W(m,n).z 'accumulate cx,cy,cz
Next n
FaceCentroid(m)=Type(cx/4,cy/4,cz/4) 'dead centre of each face
Next m
Screenlock
Cls
Draw String(10,30),"Frame Rate = " & fps
'sort the face centriods by .z value and set the painter
sort(FaceCentroid(),painter())
Locate 6,0
Print "Painting order"
For n As Long=1 To 6:Print "face "; painter(n):Next n
For z As Long=4 To 6 'Paint only the closest three faces
Var p=painter(z)
Var FaceNormal=Type<v3>((FaceCentroid(z).x-fulcrum.x),(FaceCentroid(z).y-fulcrum.y),(FaceCentroid(z).z-fulcrum.z))
'shading
Dim As Single dt=dot(FaceNormal,lightsource)
Var dtt=map(1,-1,dt,.05,1)
Dim As Ulong clr=Rgb(dtt*col[2],dtt*col[1],dtt*col[0])
DrawCubeFace(W(),p,clr)
Locate p+6,12
Print "paint"
Next z
Screenunlock
For n As Long=1 To 6:painter(n)=n:Next n 'reset the painter
Sleep regulate(60,fps),1
Loop Until Inkey=Chr(27)
Sleep
I have not tried Badidea's, I dont have openb3d.bi.
Also I don't have glut32.dll, so I cannot test the pyramid.
I have opengl.