RosettaCodeData/Task/15-puzzle-solver/FreeBASIC/15-puzzle-solver.basic

Randomize Timer

Dim Shared As Integer Nr(15) = {3, 0, 0, 0, 0, 1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3}
Dim Shared As Integer Nc(15) = {3, 0, 1, 2, 3, 0, 1, 2, 3, 0, 1, 2, 3, 0, 1, 2}
Dim Shared As Integer n, nn
Dim Shared As Integer N0(99), N3(100), N4(99)
Dim Shared As Ulongint N2(99)

Enum
    Ki = 1
    Kg = 8
    Ke = 2
    Kl = 4
End Enum

Dim Shared As Integer l = 108, r = 114, u = 117, d = 100

Declare Function fY() As Boolean
Declare Function fZ(w As Integer) As Boolean
Declare Function fN() As Boolean

Sub fI()
    Dim As Integer g = (11 - N0(n)) * 4
    Dim As Ulongint a = (N2(n) And (15ULL Shl g))
    N0(n + 1) = N0(n) + 4
    N2(n + 1) = N2(n) - a + (a Shl 16)
    N3(n + 1) = d
    N4(n + 1) = N4(n)
    If Not(Nr((a Shr g)) <= N0(n)\4) Then N4(n + 1) += 1
    n += 1
End Sub

Sub fG()
    Dim As Integer g = (19 - N0(n)) * 4
    Dim As Ulongint a = (N2(n) And (15ULL Shl g))
    N0(n + 1) = N0(n) - 4
    N2(n + 1) = N2(n) - a + (a Shr 16)
    N3(n + 1) = u
    N4(n + 1) = N4(n)
    If Not(Nr((a Shr g)) >= N0(n)\4) Then N4(n + 1) += 1
    n += 1
End Sub

Sub fE()
    Dim As Integer g = (14 - N0(n)) * 4
    Dim As Ulongint a = (N2(n) And (15ULL Shl g))
    N0(n + 1) = N0(n) + 1
    N2(n + 1) = N2(n) - a + (a Shl 4)
    N3(n + 1) = r
    N4(n + 1) = N4(n)
    If Not(Nc((a Shr g)) <= (N0(n) Mod 4)) Then N4(n + 1) += 1
    n += 1
End Sub

Sub fL()
    Dim As Integer g = (16 - N0(n)) * 4
    Dim As Ulongint a = (N2(n) And (15ULL Shl g))
    N0(n + 1) = N0(n) - 1
    N2(n + 1) = N2(n) - a + (a Shr 4)
    N3(n + 1) = l
    N4(n + 1) = N4(n)
    If Not(Nc((a Shr g)) >= (N0(n) Mod 4)) Then N4(n + 1) += 1
    n += 1
End Sub

Function fY() As Boolean
    If N2(n) = &h123456789abcdef0ULL Then Return True
    If N4(n) <= nn Then Return fN()
    Return False
End Function

Function fZ(w As Integer) As Boolean
    If (w And Ki) > 0 Then
        fI()
        If fY() Then Return True
        n -= 1
    End If
    If (w And Kg) > 0 Then
        fG()
        If fY() Then Return True
        n -= 1
    End If
    If (w And Ke) > 0 Then
        fE()
        If fY() Then Return True
        n -= 1
    End If
    If (w And Kl) > 0 Then
        fL()
        If fY() Then Return True
        n -= 1
    End If
    Return False
End Function

Function fN() As Boolean
    Select Case N0(n)
    Case 0
        Select Case N3(n)
        Case l: Return fZ(Ki)
        Case u: Return fZ(Ke)
        Case Else: Return fZ(Ki Or Ke)
        End Select
    Case 3
        Select Case N3(n)
        Case r: Return fZ(Ki)
        Case u: Return fZ(Kl)
        Case Else: Return fZ(Ki Or Kl)
        End Select
    Case 1, 2
        Select Case N3(n)
        Case l: Return fZ(Ki Or Kl)
        Case r: Return fZ(Ki Or Ke)
        Case u: Return fZ(Ke Or Kl)
        Case Else: Return fZ(Kl Or Ke Or Ki)
        End Select
    Case 12
        Select Case N3(n)
        Case l: Return fZ(Kg)
        Case d: Return fZ(Ke)
        Case Else: Return fZ(Ke Or Kg)
        End Select
    Case 15
        Select Case N3(n)
        Case r: Return fZ(Kg)
        Case d: Return fZ(Kl)
        Case Else: Return fZ(Kg Or Kl)
        End Select
    Case 13, 14
        Select Case N3(n)
        Case l: Return fZ(Kg Or Kl)
        Case r: Return fZ(Ke Or Kg)
        Case d: Return fZ(Ke Or Kl)
        Case Else: Return fZ(Kg Or Ke Or Kl)
        End Select
    Case 4, 8
        Select Case N3(n)
        Case l: Return fZ(Ki Or Kg)
        Case u: Return fZ(Kg Or Ke)
        Case d: Return fZ(Ki Or Ke)
        Case Else: Return fZ(Ki Or Kg Or Ke)
        End Select
    Case 7, 11
        Select Case N3(n)
        Case d: Return fZ(Ki Or Kl)
        Case u: Return fZ(Kg Or Kl)
        Case r: Return fZ(Ki Or Kg)
        Case Else: Return fZ(Ki Or Kg Or Kl)
        End Select
    Case Else
        Select Case N3(n)
        Case d: Return fZ(Ki Or Ke Or Kl)
        Case l: Return fZ(Ki Or Kg Or Kl)
        Case r: Return fZ(Ki Or Kg Or Ke)
        Case u: Return fZ(Kg Or Ke Or Kl)
        Case Else: Return fZ(Ki Or Kg Or Ke Or Kl)
        End Select
    End Select
End Function

Sub solve()
    If fN() Then
        Exit Sub
    Else
        n = 0
        nn += 1
        solve()
    End If
End Sub

Function createPuzzle(Byval j As Integer) As Ulongint
    Dim As Ulongint q = &h123456789abcdef0ULL
    Dim As String h = Hex(q, 16)
    Dim As Integer z, d, r, u = 0
    While j > 0 ' number of moves to do
        Do
            d = Int(Rnd * 4) + 1
        Loop While d = u
        u = -d
        r = Int(Rnd * 3) + 1
        While r > 0
            z = Instr(h, "0")
            Select Case d
            Case 1 ' -1
                If (z Mod 4) <> 1 Then
                    Mid(h, z, 1) = Mid(h, z - 1, 1)
                    Mid(h, z - 1, 1) = "0"
                    j -= 1
                End If
            Case 2 ' +1
                If (z Mod 4) <> 0 Then
                    Mid(h, z, 1) = Mid(h, z + 1, 1)
                    Mid(h, z + 1, 1) = "0"
                    j -= 1
                End If
            Case 3 ' -4
                If z >= 5 Then
                    Mid(h, z, 1) = Mid(h, z - 4, 1)
                    Mid(h, z - 4, 1) = "0"
                    j -= 1
                End If
            Case 4 ' +4
                If z <= 12 Then
                    Mid(h, z, 1) = Mid(h, z + 4, 1)
                    Mid(h, z + 4, 1) = "0"
                    j -= 1
                End If
            End Select
            r -= 1
        Wend
    Wend
    Return Valulng("&h" + h)
End Function

Sub ShowConfiguration(Byval h As String, i As Integer)
    Dim As Integer r, c
    Dim x As String
    Color 14
    For r = 1 To 4
        For c = 1 To 4
            x = Mid(h, r * 4 - 4 + c, 1)
            If x = "0" Then x = " "
            Locate r + i, c + c - 1: Print x;
        Next
    Next
    Color 7
End Sub

Sub shoWMoves(Byval h As String, Byval s As String, Byval m As Integer, Byval p As Integer)
    Dim As Integer j, z, d
    ShowConfiguration(h, 12)
    For j = 1 To m
        d = Asc(Mid(s, j, 1))
        z = Instr(h, "0")
        Select Case d
        Case l
            If (z Mod 4) <> 1 Then
                Mid(h, z, 1) = Mid(h, z - 1, 1)
                Mid(h, z - 1, 1) = "0"
            End If
        Case r
            If (z Mod 4) <> 0 Then
                Mid(h, z, 1) = Mid(h, z + 1, 1)
                Mid(h, z + 1, 1) = "0"
            End If
        Case u
            If z >= 5 Then
                Mid(h, z, 1) = Mid(h, z - 4, 1)
                Mid(h, z - 4, 1) = "0"
            End If
        Case d
            If z <= 12 Then
                Mid(h, z, 1) = Mid(h, z + 4, 1)
                Mid(h, z + 4, 1) = "0"
            End If
        End Select
        ShowConfiguration(h, 12)
        Sleep p
    Next
    Print
End Sub

Sub fifteenSolver(Byval g As Ulongint, Byval p As Integer)
    Dim As String h, s
    Dim As Integer j
    Dim As Double t0 = Timer
    n = 0
    nn = 0
    h = Hex(g, 16)
    Cls
    Print "Puzzle: "; Lcase(h)
    ShowConfiguration(h, 2)
    Print Chr(10)
    N0(0) = Instr(h, "0") - 1
    N2(0) = g
    solve()
    Print Using "Solution found in & moves: "; n;
    For j = 1 To n
        s &= Chr(N3(j))
    Next
    Print s
    Print Using !"\nTook ###.######## seconds on i5 @ 3.20 GHz"; Timer - t0
    If p Then showMoves(h, s, n, p)
End Sub

fifteenSolver(&hfe169b4c0a73d852ULL, 1000)

Sleep