Please note;
The Rubik cube must be the most boring thing around (IMHO)
edit:
Cull hidden faces (To speed it up in Linux)
Add two aspect buttons.
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 'screen 20 or 19
Color Rgb(200,200,200),Rgb(0,0,55)
Screeninfo xres,yres
#define farpoint type<point>(xres\2,yres\2,1000) 'eyepoint
#define range(f,l) Int(Rnd*((l+1)-(f))+(f))
Randomize
'======================
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(1 To 4)
Declare Sub Draw(As Ulong)
Private:
Declare Static Sub fill(() As Point,As Ulong,As Long,As Long)
End Type
Type cube 'needs point and plane
As plane f(1 To 6) 'faces
As Point norm(1 To 6) 'normals to faces
As Ulong clr(1 To 6) 'colours
As Point centre 'centroid
As Point aspect 'orientation in space
Declare Sub construct 'create a unit cube
Declare Function spin(As Point) As cube 'spin about centroid
Declare Sub translate(v As Point,s As Double) 'shift and blow
Declare Function rotate(As Point,As Point) As cube 'roatate about a chosen point
Declare Static Sub bsort(() As cube ) 'bubblesort (fast enough for a small number of cubes)
Declare Sub Draw
As Long idx 'cube id number
End Type
Type Circle
As Single x,y,r
Declare Sub Draw(As Long,as ulong=rgb(200,200,200),msg as string="")'
'macro method ?
#define incircle(cx,cy,radius,x,y) (cx-x)*(cx-x) +(cy-y)*(cy-y)<= radius*radius
End Type
'========== method for circle ==========
Sub circle.draw(z As Long,cl as ulong,msg as string)
Circle(x,y),r,cl,,,,f
if msg="" then ..draw String(x-4,y-4),Str(z),Rgb(0,0,0) else _
..draw String(x-4*len(msg),y-4),msg,rgb(0,0,0)
End Sub
'========== methods for cube =========
'construct unit cubes/normals around origin (0,0,0)
Sub cube.construct
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
For n As Long=1 To 6
For m As Long=1 To 4
f(n).p(m)= g(n,m) 'set to g()
Next m
Next n
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(0,0,0)
End Sub
Function cube.spin(p As Point) As cube
Dim As cube 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
Return tmp
End Function
Sub cube.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 Single dst=Sqr(cx*cx + cy*cy +cz*cz)
Dim As Point cn=Type(cx/dst,cy/dst,cz/dst)'normalized norm
Dim As Point k=Type<Point>(cx,cy,cz)
Dim As Single dt=k.dot(*lightsource)
dt=map(1,-1,dt,.5,1)
If cn.z<.1 Then 'cull face if out of sight (show if the normal points into screen up to about 6 degrees)
f(n).draw(Rgba(dt*col[2],dt*col[1],dt*col[0],col[3]))
End If
Next n
End Sub
Sub cube.translate(v As Point,s As Double)
For n As Long=1 To Ubound(f) 'expand
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) 'shift
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 cube.rotate(c As Point,ang As Point) As cube
Dim As cube 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 cube.bsort(c() As cube)
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)(shader)
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
'================ end methods ======================
'independent procedures
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 StringSplit(s_in As String,chars As String,result() As String) As Long
Dim As Long ctr,ctr2,k,n,LC=Len(chars)
Dim As boolean tally(Len(s_in))
#macro check_instring()
n=0
While n<Lc
If chars[n]=s_in[k] Then
tally(k)=true
If (ctr2-1) Then ctr+=1
ctr2=0
Exit While
End If
n+=1
Wend
#endmacro
#macro split()
If tally(k) Then
If (ctr2-1) Then ctr+=1:result(ctr)=Mid(s_in,k+2-ctr2,ctr2-1)
ctr2=0
End If
#endmacro
'================== LOOP TWICE =======================
For k =0 To Len(s_in)-1
ctr2+=1:check_instring()
Next k
If ctr Then Redim result(1 To ctr): ctr=0:ctr2=0 Else Return 0
For k =0 To Len(s_in)-1
ctr2+=1:split()
Next k
'===================== Last one ========================
If ctr2>0 Then
Redim Preserve result(1 To ctr+1)
result(ctr+1)=Mid(s_in,k+1-ctr2,ctr2)
End If
Return Ubound(result)
End Function
Function Fmain() As Long
Windowtitle "the cube"
Dim As Long mx,my,btn,tk=1,mouseflag
Dim As Single cx=xres\2,cy=yres\2
lightsource=New Point(0,1,1)
Dim As Point screencentre =(xres\2,yres\2,0)
Dim As Single frx=.6,fry=.4
Dim As Circle cir(1 To 11)={(screencentre.x-frx*cx,screencentre.y-fry*cx/1.3,cx/20),_
(screencentre.x-frx*cx,screencentre.y,cx/20), _
(screencentre.x-frx*cx,screencentre.y+fry*cx/1.3,cx/20), _
(screencentre.x-frx*cx/2,screencentre.y-fry*cx*1.3,cx/20),_
(screencentre.x,screencentre.y-fry*cx*1.3,cx/20), _
(screencentre.x+frx*cx/2,screencentre.y-fry*cx*1.3,cx/20), _
(screencentre.x+frx*cx*1.35,screencentre.y+frx*cx/3,cx/15), _
(screencentre.x+frx*cx*1.35,screencentre.y,cx/20), _
(screencentre.x+frx*cx*1.35,screencentre.y-frx*cx/3,cx/25)}
cir(10)=type(.1*xres,.9*yres,cx/30)
cir(11)=type(.15*xres,.9*yres,cx/30)
Dim As String sf1,sf2,sf3,sf4,sf5,sf6,sf7,sf8,sf9
Redim As cube c()
Dim As Long ctr
Dim As Single dfrac=.14
For x As Long=xres\2-.4*cx To xres\2+.4*cx Step .3*cx
For y As Long=yres\2-.4*cx To yres\2+.4*cx Step .3*cx
For z As Long=0-.4*cx To 0+.4*cx Step .3*cx
ctr+=1
Redim Preserve c(1 To ctr)
c(ctr).construct
c(ctr).idx=ctr
c(ctr).translate(Type(x+dfrac*cx,y+dfrac*cx,z+dfrac*cx),dfrac*cx)
For n As Long=1 To 6
Select Case n
Case 1:c(ctr).clr(n)=Rgb(200,0,0)
Case 2:c(ctr).clr(n)=Rgb(0,200,0)
Case 3:c(ctr).clr(n)=Rgb(200,200,0)
Case 4:c(ctr).clr(n)=Rgb(0,0,200)
Case 5:c(ctr).clr(n)=Rgb(250,250,250)
Case 6:c(ctr).clr(n)=Rgb(0,200,200)
End Select
Next n
Next
Next
Next
'screencentre becomes the Rubik cube centroid
Dim As Single ccx,ccy,ccz
For n As Long=Lbound(c) To Ubound(c)
ccx+=c(n).centre.x
ccy+=c(n).centre.y
ccz+=c(n).centre.z
Next
ccx=ccx/Ubound(c)
ccy=ccy/Ubound(c)
ccz=ccz/Ubound(c)
screencentre=Type(ccx,ccy,ccz)
Dim As cube tmp(Lbound(c) To Ubound(c))
Dim As Point a
a.y=-.3
a.x=.3
Dim As Long fps
Dim As String key
Dim As Long tflag,shuffle
Do
key=Inkey
Getmouse mx,my,,btn
If key=Chr(255)+"P" Then a.y-=.05 'down y axis
If key=Chr(255)+"H" Then a.y+=.05 'up y axis
If key=Chr(255)+"K" Then a.z-=.05 'right z axis
If key=Chr(255)+"M" Then a.z+=.05 'left z axis
If key="q" Then a.x+=.05 'x axis
If key="w" Then a.x-=.05 'x axis
If key=" " Then a=type(.3,-.3,0) 'reset
If key="s" Then
If shuffle=0 Then tflag=range(1,9):shuffle=1
End If
Screenlock
Cls
Draw String (20,20),"Use arrow keys and q and w to change aspect, space key to reset"
Draw String (20,40),"Use left and right mouse clicks on circles"
Draw String (20,60),"Press s to shuffle"
Draw String (20,80),"FPS = " &fps
For n As Long=Lbound(c) To Ubound(c)
tmp(n)=c(n).rotate(screencentre,Type(a.x,a.y,a.z)) 'rotates cube about screen cenre
Next
'macros for repeat tasks
#macro turn90degrees
Static As Single t,k
t=(pi/2)/20
k+=t
If k>=pi/2+t Then tflag=0:k=0:t=0
#endmacro
#macro tflagrot(s,p)
Redim As String L()
stringsplit(s,",",L())
turn90degrees
For n As Long=1 To 9
c(Vallng(L(n)))=c(Vallng(L(n)) ).rotate(screencentre,p)
Next n
If t=0 Then
shuffle=t
End If
#endmacro
Select Case tflag
Case 1
tflagrot(sf1,Type(0,tk*t,0))
Case 2
tflagrot(sf2,Type(0,tk*t,0))
Case 3
tflagrot(sf3,Type(0,tk*t,0))
Case 4
tflagrot(sf4,Type(tk*t,0,0))
Case 5
tflagrot(sf5,Type(tk*t,0,0))
Case 6
tflagrot(sf6,Type(tk*t,0,0))
Case 7
tflagrot(sf7,Type(0,0,tk*t))
Case 8
tflagrot(sf8,Type(0,0,tk*t))
Case 9
tflagrot(sf9,Type(0,0,tk*t))
case 10
a=type(.39*tk,.39,0) 'flip aspects
tflag=0
case 11
a=type(.39*tk,-.39,0)
tflag=0
End Select
cube.bsort(tmp()) 'sort by centre.z
sf4=""
sf5=""
sf6=""
sf1=""
sf2=""
sf3=""
sf7=""
sf8=""
sf9=""
For n As Long=Lbound(tmp) To Ubound(tmp)'advance aspect and spin.
tmp(n).spin(tmp(n).aspect)
'=============== verticals ==========
If c(n).centre.x<.4*xres Then 'lft
sf4+=Str(c(n).idx)+","
End If
If c(n).centre.x>.4*xres And c(n).centre.x < .6*xres Then'mid
sf5+=Str(c(n).idx)+","
End If
If c(n).centre.x>.6*xres Then 'rgt
sf6+=Str(c(n).idx)+","
End If
'====================horizontals ==================
If c(n).centre.y<.4*yres Then 'top
sf1+=Str(c(n).idx)+","
End If
If c(n).centre.y>.4*yres And c(n).centre.y<.6*yres Then 'mid
sf2+=Str(c(n).idx)+","
End If
If c(n).centre.y>.6*yres Then 'bot
sf3+=Str(c(n).idx)+","
End If
'=================front to back =============
If c(n).centre.z< screencentre.z-.1*xres Then 'front
sf7+=Str(c(n).idx)+","
End If
If c(n).centre.z< screencentre.z+.01*xres And c(n).centre.z > screencentre.z-.01*xres Then 'mid
sf8+=Str(c(n).idx)+","
End If
If c(n).centre.z> screencentre.z+.1*xres Then 'back
sf9+=Str(c(n).idx)+","
End If
Next
sf4=Rtrim(sf4,",")
sf5=Rtrim(sf5,",")
sf6=Rtrim(sf6,",")
sf1=Rtrim(sf1,",")
sf2=Rtrim(sf2,",")
sf3=Rtrim(sf3,",")
sf7=Rtrim(sf7,",")
sf8=Rtrim(sf8,",")
sf9=Rtrim(sf9,",")
'manage mouse in circles
For n As Long=1 To 11
if n<=9 then cir(n).draw(n)
if n=10 then cir(n).draw(n,rgb(0,100,255),"a1")
if n=11 then cir(n).draw(n,rgb(0,100,255),"a2")
Var x=(cir(n).x),y=(cir(n).y),r=(cir(n).r)
If incircle( x ,y , r ,mx,my) And btn And mouseflag=0 Then
mouseflag=1
If btn=1 Then tk=1
If btn=2 Then tk=-1
tflag=n
End If
Next n
Screenunlock
Sleep regulate(90,fps),1
mouseflag=btn
Loop Until key=Chr(27)
Sleep
Delete lightsource
Return 0
End Function