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 = 8
Const mlCOL_COUNT As Long = 8
'the maximum number of permissable attempts to solve the puzzle
'change max number of attempts to suit:
Const mlMAX_ATTEMPTS As Long = 10
'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
'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
'get a reference to a range which represents our chess board
Set mrngChessBoard = Worksheets.Add.Range(msTOP_LEFT_CELL).Resize(mlROW_COUNT, mlCOL_COUNT)
'try to solve the puzzle
Do
'we must start with an empty board
mrngChessBoard.Clear
lAttempts = lAttempts + 1
Loop While KnightMoves <> (mlROW_COUNT * mlCOL_COUNT) And lAttempts < mlMAX_ATTEMPTS
'tidy up the chess board presentation however you need to....
mrngChessBoard.Columns.AutoFit
'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
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
'let's take a random corner of the board as our starting point
Set rngCurrent = GetStartingSquare
KnightMoves = 1
With rngCurrent
.Value = KnightMoves
.Interior.Color = vbYellow 'mark the starting square yellow
End With
'move the knight around the board until we run out of available squares
Do
Set rngCurrent = GetNextMove(rngCurrent)
If Not rngCurrent Is Nothing Then
KnightMoves = KnightMoves + 1
rngCurrent.Value = KnightMoves
Else
Exit Do
End If
Loop
End Function
'use Warnsdorff's algorithm to determine the next move:
'--> we move to the next square which itself has the
'least number of possible legal moves
Private Function GetNextMove(ByRef Square As Range) As Range
Const bytMAXMOVES As Byte = 8 '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 Byte 'track the least number of subsequent legal moves
Set rngMove1 = GetLegalMoves(Square)
'if there are no legal first moves then do nothing
If rngMove1 Is Nothing Then
'if there is only one legal move then we have to move there
ElseIf rngMove1.Areas.Count = 1 Then
Set GetNextMove = rngMove1
'if there are multiple legal moves we have to determine
'which is the best
Else
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
If .Count < bytNextMoveCounter Then
bytNextMoveCounter = .Count
Set GetNextMove = rngSquare
ElseIf .Count = 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
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 corner of the chess board to start from
Private Function GetStartingSquare() As Range
Dim sngRandomNumber As Single
Randomize
sngRandomNumber = Rnd
With mrngChessBoard
If sngRandomNumber >= 0.75 Then
Set GetStartingSquare = .Cells(1, 1)
ElseIf sngRandomNumber >= 0.5 Then
Set GetStartingSquare = .Cells(1, mlCOL_COUNT)
ElseIf sngRandomNumber >= 0.25 Then
Set GetStartingSquare = .Cells(mlROW_COUNT, 1)
Else
Set GetStartingSquare = .Cells(mlROW_COUNT, mlCOL_COUNT)
End If
End With
End Function
