Rubik cube

Game development specific discussions.
Post Reply
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Rubik cube

Post by dodicat »

This won't win a prize in Lachie's game site, so I'll put it here instead.
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


      
Last edited by dodicat on Oct 12, 2018 14:07, edited 1 time in total.
h4tt3n
Posts: 698
Joined: Oct 22, 2005 21:12
Location: Denmark

Re: Rubik cube

Post by h4tt3n »

Impressive as always :-)
D.J.Peters
Posts: 8586
Joined: May 28, 2005 3:28
Contact:

Re: Rubik cube

Post by D.J.Peters »

Well done :-)

Joshy
jj2007
Posts: 2326
Joined: Oct 23, 2016 15:28
Location: Roma, Italia
Contact:

Re: Rubik cube

Post by jj2007 »

Indeed, well done!
grindstone
Posts: 862
Joined: May 05, 2015 5:35
Location: Germany

Re: Rubik cube

Post by grindstone »

Great!

Alas, I never got along with this cube. <grin>
Lachie Dazdarian
Posts: 2338
Joined: May 31, 2005 9:59
Location: Croatia
Contact:

Re: Rubik cube

Post by Lachie Dazdarian »

Hah, really cool!
HelenIrvin
Posts: 1
Joined: Feb 05, 2019 6:57

Re: Rubik cube

Post by HelenIrvin »

Very interesting. I also want to learn how to write simple games!
Tourist Trap
Posts: 2958
Joined: Jun 02, 2015 16:24

Re: Rubik cube

Post by Tourist Trap »

HelenIrvin wrote:Very interesting. I also want to learn how to write simple games!
Welcome here HelenIrvin,

whatever you want to do just start trying and ask when you get stuck :) It's what I always do.
Makoto WATANABE
Posts: 231
Joined: Apr 10, 2010 11:41
Location: Japan
Contact:

Re: Rubik cube

Post by Makoto WATANABE »

Thank you for providing wonderful programs every time.
Often I can not solve the cube and I give it up.
I would appreciate if this program ends the cube by aligning it before the program ends.
I think it will help to learn my puzzle solution.

cf. Solve a Rubik's Cube
https://rosettacode.org/wiki/Solve_a_Rubik%27s_Cube
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Rubik cube

Post by dodicat »

Hi Makoto.
I could maybe store all moves in a string and reverse everything done, back to the original.
But it wouldn't be the most direct way to the solution.
Post Reply