Rubik cube

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

Rubik cube

Postby dodicat » Oct 10, 2018 23:13

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: 670
Joined: Oct 22, 2005 21:12
Location: Denmark

Re: Rubik cube

Postby h4tt3n » Oct 11, 2018 7:24

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

Re: Rubik cube

Postby D.J.Peters » Oct 11, 2018 7:54

Well done :-)

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

Re: Rubik cube

Postby jj2007 » Oct 11, 2018 8:02

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

Re: Rubik cube

Postby grindstone » Oct 11, 2018 8:49

Great!

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

Re: Rubik cube

Postby Lachie Dazdarian » Oct 14, 2018 21:25

Hah, really cool!

Return to “Game Dev”

Who is online

Users browsing this forum: No registered users and 2 guests