Announcement

Collapse
No announcement yet.

Game of 15 Puzzle - Redux

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • Game of 15 Puzzle - Redux

    Gary posted a very nice compact graphic example that creates a Game of 15 game a little while ago.
    The object of the game is to get the 1-15 numbers in a row like this:
    1-4
    5-8
    9-12
    13-15
    Unfortunately the puzzle is initialized with a configuration that is not solvable

    A slight modification of the source as below does generate a puzzle that can be solved..

    Original...-->.... Alternate Start
    Code:
    #Include "Win32API.inc"
    %IDC_Graphic = 500
    Global hDlg,hFont As Dword, D(), i,j,k,x,y As Long, pt As Point
    Function PBMain() As Long
       Font New "Tahoma",20,1 To hFont
       Dialog New Pixels, 0, "15",300,300,200,200, %WS_OverlappedWindow To hDlg
       Control Add Graphic, hDlg, %IDC_Graphic, "", -50,-50,300,300, %SS_Notify
       Control Set Font hDlg, %IDC_Graphic, hFont
       Dialog Show Modal hDlg Call DlgProc
    End Function
    CallBack Function DlgProc() As Long
       Select Case Cb.Msg
          Case %WM_InitDialog
             ReDim D(0 To 5,0 To 5)  : k = 1       ' ** MOD
             For i=0 To 5 : For j=0 To 5 : D(i,j) = -1                : Next j : Next i  '-1 in perimeter
             For i=1 To 4 : For j=1 To 4 : D(i,j) = k Mod 16 : incr k : Next j : Next i  '0-15 inside
             DrawGame                              '^^^^^^^^' **MOD
          Case %WM_Command
             If Cb.Ctl = %IDC_Graphic And Cb.CtlMsg = %STN_Clicked Then
                GetCursorPos pt : ScreenToClient GetDlgItem(hDlg,%IDC_Graphic), pt
                x = pt.x \ 50 : y = pt.y \ 50
                If D(x+1,y  )=0 Then CSwap(+1, 0) : Drawgame : Exit Select
                If D(x-1,y  )=0 Then CSwap(-1, 0) : Drawgame : Exit Select
                If D(x  ,y-1)=0 Then CSwap( 0,-1) : Drawgame : Exit Select
                If D(x  ,y+1)=0 Then CSwap( 0,+1) : Drawgame : Exit Select
             End If
       End Select
    End Function
    Function CSwap(r As Long, s As Long) As Long
       k = D(x,y) : D(x,y) = D(x+r,y+s) : D(x+r,y+s) = k
    End Function
    Sub DrawGame
       Graphic Clear %White : Graphic Color -1, -2
       For i = 1 To 4 : For j = 1 To 4
             Graphic Box (i*50,j*50)-(i*50+50,j*50+50),,%Blue
             If D(i,j)<>0 Then Graphic Set Pos (i*50,j*50+10) : Graphic Print " " + Trim$(Str$(D(i,j)))
       Next j : Next i
       Graphic ReDraw
    End Sub
    It turns out that half of the possible starting configurations (Factorial 16 ~ 2x10^13) are not solvable !

    For more information on testing Game of 15 configurations for Solvability see this web page.
    Rgds, Dave

  • #2
    Hey Dave!
    50% chance of solvable, and of course my sample fell on the dark side!

    Thanks for comments and revised code. Does the mod you highlighted ensure that all new games are solvable? Very cool beans!

    Comment


    • #3
      Hi Gary,

      With the mod above, the app starts each run with the same (Solvable) configuration.
      I added some other options via a right click menu below.

      This example starts with the same solvable puzzle but gives the option of doing a random shuffle.
      The shuffle will repeat until a solvable config is found / used to update the Graphic.
      Code:
      #DEBUG Display On
      #Include "Win32API.inc"
      %IDC_Graphic = 500
      Global hDlg,hFont As Dword, D(), i,j,k,x,y As Long, pt As Point
      Function PBMain() As Long
         Font New "Tahoma",20,1 To hFont
         Dialog New Pixels, 0, "15",300,300,200,200, %WS_OverlappedWindow To hDlg
         Control Add Graphic, hDlg, %IDC_Graphic, "", -50,-50,300,300, %SS_Notify
         Control Set Font hDlg, %IDC_Graphic, hFont
         Dialog Show Modal hDlg Call DlgProc
      End Function
      CallBack Function DlgProc() As Long
         Select Case Cb.Msg
            Case %WM_InitDialog
               ReDim D(0 To 5,0 To 5)  : k = 1
               For i=0 To 5 : For j=0 To 5 : D(i,j) = -1         : Next j : Next i  '-1 in perimeter
               For i=1 To 4 : For j=1 To 4 : D(i,j) = k Mod 16 : incr k : Next j : Next i  '0-15 vert. / 1-15,0
               DrawGame
            Case %WM_Command
               If Cb.Ctl = %IDC_Graphic And Cb.CtlMsg = %STN_Clicked Then
                  GetCursorPos pt : ScreenToClient GetDlgItem(hDlg,%IDC_Graphic), pt
                  x = pt.x \ 50 : y = pt.y \ 50
                  If D(x+1,y  )=0 Then CSwap(+1, 0) : Drawgame : Exit Select
                  If D(x-1,y  )=0 Then CSwap(-1, 0) : Drawgame : Exit Select
                  If D(x  ,y-1)=0 Then CSwap( 0,-1) : Drawgame : Exit Select
                  If D(x  ,y+1)=0 Then CSwap( 0,+1) : Drawgame : Exit Select
               End If
            Case %WM_ContextMenu : HandleExtras(Cb.wParam, Cb.lParam)   ' ** ADDED Right click Popup Menu
         End Select
      End Function
      Function CSwap(r As Long, s As Long) As Long
         k = D(x,y) : D(x,y) = D(x+r,y+s) : D(x+r,y+s) = k
      End Function
      Sub DrawGame
         Graphic Clear %White : Graphic Color -1, -2
         For i = 1 To 4 : For j = 1 To 4
               Graphic Box (i*50,j*50)-(i*50+50,j*50+50),,%Blue
               If D(i,j)<>0 Then Graphic Set Pos (i*50,j*50+10) : Graphic Print " " + Trim$(Str$(D(i,j)))
         Next j : Next i
         Graphic ReDraw
      End Sub
      '------------------/Original code above (Plus "Case %WM_ContextMenu.." Popup Menu)
      
      '------------------/Added PopUp ContextMenu to allow Analysis and Shuffle / restart
      Function HandleExtras(ByVal wParam As Long, ByVal lParam As Long) As Long
         Local hPopUp, Id As Long                       ' PopUp menu
           Local x, y As Integer
            x = Lo(Integer, lParam) : y = Hi(Integer, lParam)
              Menu New PopUp To hPopup
              Menu Add String, hPopup, "Analyze Puzzle", 103, %MF_Enabled
              Menu Add String, hPopup, "New (Solvable)", 104, %MF_Enabled
            Id = TrackPopupMenu(hPopup, %TPM_LeftButton Or %TPM_ReturnCmd, x, y, 0, hDlg, ByVal 0)
              If Id > 0 Then
               Local n, o, p As Long
               ReDim Test(1 To 16) As Static Long               ' Copy current puzzle sequence
                  p = 1 : For n = 1 To 4 : For o = 1 To 4  : Test(p) = D(o,n) : Incr p : Next o : Next n
              End If
      
            Select Case Id                                      ' Selected option
              Case 103 : TestForSolvability Test() : AMsg $EOF  ' Analyze
              Case 104                                          ' New (Solvable) Automatic
                  If Shuffle(Test()) <> 0 Then
                    WinBeep 1800,400
                    p = 1
                    For n = 1 To 4 : For o = 1 To 4  : D(o,n) = Test(p) : Incr p : Next o : Next n
                    Drawgame                                     
                End If
            End Select'
      
       '      Function = 1 : Exit Function
      End Function
      '------------------/HandleExtras
      
      Function Shuffle(r2arr() As Long) As Long
       Local n, o, p, Res As Long
       Reshuffle:
        Randomize Timer                                 ' shuffle using the Knuth perfect shuffle. TT John Gleason
        For n = 1 To 16 : Swap r2arr(n), r2arr(Rnd(n,16)) : Next n
       '  Array Assign Test() = 0,4,8,12,1,5,9,13,2,6,10,14,3,7,11,15 ' (eg -> Unsolvable)
        Res = TestForSolvability(r2arr())   :  MsgBox Using$("Res # ", Res), %MB_ICONMASK, ""
        If (Res = 0) Then
            WinBeep 400,400 :  AMsg $EOF : Goto ReShuffle
        Else
            AMsg $EOF : Function = 1 : Exit Function
        End If
      End Function
      '------------------/Shuffle
      
      Function TestForSolvability(Puzzle() As Long) As Long     ' counts inversions to determine solvable or not
        Local ii, jj, par, linv, Row, blankrow, gridwidth As Long, sInv, sTest, sReturn, sKey As String
         gridwidth = Sqr(ArrayAttr(Puzzle(),4))
           For ii = 1 To UBound(puzzle())               ' for each position eg 1 - 16
              If (ii Mod gridWidth) = 1 Then Incr Row   ' Start of row
              If puzzle(ii) = 0 Then
                  blankRow = Row                        ' the blank tile is found, save on which row encountered
                  blankrow = gridwidth+1 - blankrow     ' blank tile row count from bottom up
              End If
              For jj = ii+1 To UBound(puzzle())
                  If (puzzle(ii) > puzzle(jj)) And puzzle(jj) <> 0 Then  ' we have an inversion
                    Incr par : Incr linv                ' par = total inversions, linv = inversions from each pos
                  End If
              Next
              sInv += Str$(linv) + $Spc : Reset linv
              sTest += Str$(Puzzle(ii)) + ","
           Next
            AMsg ""
            AMsg " Puzzle order : " + sTest             ' show puzzle number sequence in row order
            AMsg " Blank on Row : " + Str$(BlankRow)
            AMsg " Inversions   : " + sInv              ' list separate inversions from each position
            AMsg " Total (par)  : " + Str$(Par)         ' total inversions - determine Odd or Even number
            AMsg ""
            AMsg IIF$((BlankRow Mod 2) Xor (Par Mod 2), "  Solvable", "  Not solvable")  ' Even Grid rule !
            AMsg ""                                     ' AMsg $EOT / $Esc - Comit / clear massage content
          If (gridWidth Mod 2) = 0 Then                 ' //Even Grid rules.
              If (blankRow Mod 2) <> 0 Then             'If Blank is on an Odd row (counting from bottom)
                  Function = (par Mod 2) = 0            '  Even number of Inversions -> solvable (Function = True)
              Else                                      'If Blank is on an Even row
                  Function = (par Mod 2) <> 0           '  Odd number of inversions  -> solvable (Function = True)
              End If
          Else                                          ' //Odd Grid rule.
              Function = (par Mod 2) = 0                '  Even number of Inversions -> solvable (Function = True)
          End If
      End Function
      '------------------/TestForSolvability
      
      Function AMsg (sMsg AS STRING) As long
        Static sBuf As String, lRes As Long
          If sMsg = $EOF Then                           ' Show analysis
            lRes = MessageBox(0, sBuf+"", "Puzzle analysis", %MB_TOPMOST)
            sBuf = "" : sMsg = ""
          ElseIf sMsg = $Esc Then                       ' Clear analysis
            sBuf = "" : sMsg = ""
          Else
            sBuf += sMsg + $CR                          ' build analysis msg
          End If
      END Function
       '------------------/AMsg
      Rgds, Dave

      Comment


      • #4
        Sweet, Dave!
        I'm headed to bed but will check it out tomorrow!

        Comment


        • #5
          Originally posted by Dave Biggs View Post
          Gary posted a very nice compact graphic example that creates a Game of 15 game a little while ago.

          Unfortunately the puzzle is initialized with a configuration that is not solvable
          It turns out that half of the possible starting configurations (Factorial 16 ~ 2x10^13) are not solvable !

          For more information on testing Game of 15 configurations for Solvability see this web page.
          I did one of these in Visual Basic back in the 90s.
          To assure solvability, I started with the puzzle as finished, and then did a random
          scramble from there.
          The world is strange and wonderful.*
          I reserve the right to be horrifically wrong.
          Please maintain a safe following distance.
          *wonderful sold separately.

          Comment

          Working...
          X