Option Explicit
'grid rows and columns representing dimensions of the chess board
'change dimensions to suit (a traditional board is 8x8):
Const mlROW_COUNT As Long = 32
Const mlCOL_COUNT As Long = 32
'the maximum number of permissable attempts to solve the puzzle
'change max number of attempts to suit:
Const mlMAX_ATTEMPTS As Long = 10
'the number of moves to look ahead
'change to suit:
Const levels As Integer = 12
'we will use C3 as the top left cell so that no moves can
'take us off the worksheet
Const msTOP_LEFT_CELL As String = "C3"
'a range representing a chess board
Dim mrngChessBoard As Range
Dim firstsquare As Range 'JDG: a range representing the knight's starting position
Dim finalsquares(levels) As Range 'JDG: these are the squares to which move n-x may go to acheive a closed tour
Dim finalsquarescount(levels) As Integer 'JDG: how many of those squares are still available
Dim finalsquarestemp(levels) As Range 'JDG: finalsquares set before removing overlap with lower levels
Dim i As Integer
'the main sub to run to try to solve the puzzle
Public Sub Main()
Dim lAttempts As Long 'a counter to monitor how many tries the algorithm has had
Dim sMsg As String 'a report message
Dim exitMsg As String 'alert user to board size
exitMsg = "Board size " & mlROW_COUNT & " x " & mlCOL_COUNT & ", looking ahead " & levels & " moves."
If MsgBox(exitMsg, vbOKCancel, "WARNING") = vbCancel Then Exit Sub
'get a reference to a range which represents our chess board
'In a new sheet:
'Set mrngChessBoard = Worksheets.Add.Range(msTOP_LEFT_CELL).Resize(mlROW_COUNT, mlCOL_COUNT)
'In the existing sheet:
Set mrngChessBoard = ActiveSheet.Range(msTOP_LEFT_CELL).Resize(mlROW_COUNT, mlCOL_COUNT)
'try to solve the puzzle
Do
'we must start with an empty board
'mrngChessBoard.Clear
clear_board
mrngChessBoard.ClearContents
'Application.ScreenUpdating = False
Range(Cells(101, 2), Cells((mlROW_COUNT * mlCOL_COUNT) + 101, 3)).Value = Range(Cells(101, 12), Cells((mlROW_COUNT * mlCOL_COUNT) + 101, 13)).Value
Range(Cells(101, 12), Cells((mlROW_COUNT * mlCOL_COUNT) + 101, 13)).ClearContents
lAttempts = lAttempts + 1
Loop While KnightMoves <> (mlROW_COUNT * mlCOL_COUNT) And lAttempts < mlMAX_ATTEMPTS
'Application.ScreenUpdating = True
'tidy up the chess board presentation however you need to....
'mrngChessBoard.Columns.AutoFit
Range(Cells(101, 2), Cells((mlROW_COUNT * mlCOL_COUNT) + 101, 3)).Value = Range(Cells(101, 12), Cells((mlROW_COUNT * mlCOL_COUNT) + 101, 13)).Value
'create a report message for the end user
sMsg = "solved after " & lAttempts & " attempt": If lAttempts > 1 Then sMsg = sMsg & "s"
'did we solve it? if not then adjust the report message....
If lAttempts = mlMAX_ATTEMPTS Then sMsg = "NOT " & sMsg
MsgBox sMsg
'clean up
Set mrngChessBoard = Nothing
Set firstsquare = Nothing
For i = 0 To levels
Set finalsquares(i) = Nothing
Set finalsquarestemp(i) = Nothing
Next i
End Sub
Private Sub clear_board()
'
' Macro4 Macro
' Macro recorded 1/23/2009 by John Gardner
'
'
Range("C3").Interior.ColorIndex = xlNone
Range("D3").Interior.ColorIndex = 15
Range("C3:D3").Copy
Range(Cells(3, 5), Cells(3, mlCOL_COUNT + 2)).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("D3:E3").Copy
Range(Cells(4, 3), Cells(4, mlCOL_COUNT + 2)).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range(Cells(3, 2), Cells(4, mlCOL_COUNT + 2)).Copy
Range(Cells(5, 2), Cells(mlROW_COUNT + 2, mlCOL_COUNT + 2)).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("A1").Select
End Sub
'a function which moves the knight around the board and tracks the number of moves
Private Function KnightMoves() As Double
Dim rngCurrent As Range 'a range representing the current position of the knight
Dim rngSquare As Range
'If we're repeating from a failed attempt, use the same starting square
'If Not firstsquare Is Nothing Then
'Set rngCurrent = firstsquare
'otherwise let's take any random square on the board as our starting point
'Else
Set rngCurrent = GetStartingSquare
Set firstsquare = rngCurrent
'End If
KnightMoves = 1
'mark the starting square red
With rngCurrent
.Value = KnightMoves
'.Interior.Color = vbRed
End With
'Determine the cells from which a move to cell #1 is possible
'A closed tour must end on one of these cells.
For i = 0 To levels
Set finalsquares(i) = Nothing
Set finalsquarestemp(i) = Nothing
Next i
Set finalsquares(0) = firstsquare
Set finalsquarestemp(0) = finalsquares(0)
finalsquarescount(0) = 1
Set finalsquares(1) = GetLegalMoves(rngCurrent)
Set finalsquarestemp(1) = finalsquares(1)
finalsquarescount(1) = finalsquares(1).Areas.Count
'********************Lookahead*******************************
For i = 1 To levels
For Each rngSquare In finalsquarestemp(i - 1).Areas
If finalsquarestemp(i) Is Nothing Then
Set finalsquarestemp(i) = GetLegalMoves(rngSquare)
Else
Set finalsquarestemp(i) = Union(finalsquarestemp(i), GetLegalMoves(rngSquare))
End If
Next rngSquare
For Each rngSquare In finalsquarestemp(i)
If i > 1 Then
If Intersect(finalsquarestemp(i - 2), rngSquare) Is Nothing Then
If finalsquares(i) Is Nothing Then
Set finalsquares(i) = rngSquare
Else
Set finalsquares(i) = Union(finalsquares(i), rngSquare)
End If
End If
End If
Next rngSquare
'audit
Cells(100 + i, 5).Value = finalsquares(i).Areas.Count
Next i
Dim colortouse As Integer
'color code the levels of lastmove(x) in the display
For i = 1 To levels
colortouse = GetSquareColor(i)
For Each rngSquare In finalsquares(i).Areas
rngSquare.Interior.ColorIndex = colortouse
Next rngSquare
Next i
'color code the inner three, and outermost, levels of lastmove(x)
'For i = 1 To 3
'colortouse = GetSquareColor(i)
'For Each rngSquare In finalsquares(i).Areas
'rngSquare.Interior.ColorIndex = colortouse
'Next rngSquare
'Next i
'For Each rngSquare In finalsquares(levels).Areas
'rngSquare.Interior.ColorIndex = 9
'Next rngSquare
'******************************************************************
'move the knight around the board until we run out of available squares
Do
'data table for graphical move display
Cells(KnightMoves + 100, 12) = rngCurrent.Column - 2
Cells(KnightMoves + 100, 13) = rngCurrent.Row - 2
'Set rngCurrent = GetNextMove(rngCurrent, levels)
Set rngCurrent = GetNextMove(rngCurrent)
If Not rngCurrent Is Nothing Then
KnightMoves = KnightMoves + 1
rngCurrent.Value = KnightMoves
For i = 1 To levels
If Not Intersect(rngCurrent, finalsquares(i)) Is Nothing Then finalsquarescount(i) = finalsquarescount(i) - 1
Next i
Else
Exit Do
End If
Loop
End Function
'use Warnsdorff's algorithm to determine the next move:
'--> we always move to the next square which itself has the
'least number of possible legal moves, unless it is the final member of any finalsquares(x).
'In that case, we move to the second-least moves square.
'Ties are broken first by artificially inflating the number of legal moves of any
'finalsquares(x) candidate by larger amounts as the (x) decreases, then by random selection.
'If we have used up all eight of the finalsquares(1) before move #64, start over.
'Private Function GetNextMove(ByRef Square As Range, levels As Integer) As Range
Private Function GetNextMove(ByRef Square As Range) As Range
Const bytMAXMOVES As Integer = 1000 'the largest number of squares a knight can move to is 8
Dim rngMove1 As Range 'looking one move ahead
Dim rngMove2 As Range 'looking two moves ahead
Dim rngSquare As Range 'a cell counter
Dim bytNextMoveCounter As Double 'track the least number of subsequent legal moves
Dim thatcellmove As Double 'allow penalty for membership in finalsquares(x)
Dim tiebreaker(levels) As Double 'to avoid last finalsquares(x) cell until no longer possible
Set rngMove1 = GetLegalMoves(Square)
'if there are no legal first moves then do nothing
If rngMove1 Is Nothing Then
Range("AB68").Value = "No legal moves"
'if used up all final eight possibilites then do nothing
ElseIf finalsquarescount(1) = 0 Then
Range("AB68").Value = "All used up"
'if there is only one legal move then we have to move there
ElseIf rngMove1.Areas.Count = 1 Then
Range("AB68").Value = "One legal move"
Set GetNextMove = rngMove1
'if there are multiple legal moves we have to determine
'which is the best
Else
Range("AB68").Value = "Multiple legal moves"
bytNextMoveCounter = bytMAXMOVES
'loop through all the squares which are legal 1st moves
For Each rngSquare In rngMove1.Areas
'determine all the possible legal 2nd moves from the 1st move
Set rngMove2 = GetLegalMoves(rngSquare)
If Not rngMove2 Is Nothing Then
With rngMove2.Areas
'if there are less 2nd moves from that square than
'any others we have checked then we want it
tiebreaker(1) = 0.5
If finalsquarescount(1) = 1 Then tiebreaker(1) = 6.5 'forces avoidance of last finalsquares(1) memeber
If Not Intersect(rngSquare, finalsquares(1)) Is Nothing Then thatcellmove = thatcellmove + tiebreaker(1)
thatcellmove = .Count
'For i = 1 To levels
For i = levels To 1 Step -1
tiebreaker(i) = (0 + levels - i) / levels
If finalsquarescount(1) = 1 Then tiebreaker(i) = 6.5 + ((0 + levels - i) / levels)
If Not Intersect(rngSquare, finalsquares(i)) Is Nothing Then thatcellmove = .Count + tiebreaker(i)
Next i
If thatcellmove < bytNextMoveCounter Then
bytNextMoveCounter = thatcellmove
Set GetNextMove = rngSquare
ElseIf thatcellmove = bytNextMoveCounter Then
'if two squares are equally viable let's randomly pick one
'so that our algorithm produces different results each time
Randomize
If Rnd >= 0.5 Then Set GetNextMove = rngSquare
End If
End With
End If
Range("AB68").Value = "Legal moves: " & rngMove1.Areas.Count
Next rngSquare
End If
End Function
'A function to get all the legal moves the knight can make
Private Function GetLegalMoves(ByRef Square As Range) As Range
Dim rngCell As Range
For Each rngCell In GetAllMoves(Square)
If IsMoveLegal(rngCell) Then
If GetLegalMoves Is Nothing Then
Set GetLegalMoves = rngCell
Else
Set GetLegalMoves = Union(GetLegalMoves, rngCell)
End If
End If
Next rngCell
End Function
'A function to determine if a move to a square is allowed
Private Function IsMoveLegal(ByRef Square As Range) As Boolean
'has the square been visited yet?
If IsEmpty(Square) Then
'is the square on the chess board?
If Not Intersect(Square, mrngChessBoard) Is Nothing Then IsMoveLegal = True
End If
End Function
'A function to determine all the possible moves (legal or not) a knight could make
Private Function GetAllMoves(ByRef Square As Range) As Range
With Square
Set GetAllMoves = Union( _
.Offset(-2, -1), _
.Offset(-2, 1), _
.Offset(-1, -2), _
.Offset(-1, 2), _
.Offset(1, -2), _
.Offset(1, 2), _
.Offset(2, -1), _
.Offset(2, 1) _
)
End With
End Function
'a function to determine a square on the chess board to start from
Private Function GetStartingSquare() As Range
With mrngChessBoard
'Full randomizer
Dim sqrow As Integer
Dim sqcol As Integer
Randomize
sqrow = Int(mlROW_COUNT * Rnd) + 1
Randomize
sqcol = Int(mlCOL_COUNT * Rnd) + 1
Set GetStartingSquare = .Cells(sqrow, sqcol)
'non random
'Set GetStartingSquare = .Cells(mlROW_COUNT / 2, mlCOL_COUNT / 2)
End With
End Function
Private Function GetSquareColor(ByRef level As Integer) As Integer
Dim x As Integer
Select Case level
Case 17
x = 13
Case 16
x = 54
Case 15
x = 39
Case 14
x = 34
Case 13
x = 8
Case 12
x = 42
Case 11
x = 5
Case 10
x = 14
Case 9
x = 4
Case 8
x = 12
Case 7
x = 43
Case 6
x = 6
Case 5
x = 40
Case 4
x = 44
Case 3
x = 45
Case 2
x = 46
Case 1
x = 3
End Select
GetSquareColor = x
End Function
