The knight’s tour is a chess puzzle where you have to move a knight around a chess board so that it visits each square once. An Excel worksheet grid lends itself to being a chessboard so, when prompted by a question on an online forum, I thought it might be fun to write a little program which produces solutions to the puzzle.
There are several different ways to do this, but I’m going to implement Warnsdorff’s rule. As described at Wikipedia, this rule states that when you are deciding where to move the knight to, you should choose the square which has the least number of subsequent moves and that tie breaks are decided by random choice. This means that the code will tend to move the knight towards the sides or corners of the board, because a knight controls less squares from those places than when it is in the middle. In fact, that’s why chess players generally find that knights are more powerful when they are centrally positioned and that flank pawns can be quite effective against a knight in the end-game.
The first piece of coding is a simple custom class called
cChessBoard which will be used to represent the chessboard. When we run the main procedure to solve the puzzle, we’ll add a new worksheet to the workbook and create a chessboard on it, with the top left square of the chessboard being cell C3. Knights move in 2×1 L-shapes so, by picking C3 as the top left cell, we don’t have to worry about possible runtime errors resulting from moving the knight off of the worksheet.
The last point of note is that the
cChessBoard class has two internal constants which define the height and width of the board. A chessboard is 8×8 squares, but you can change these values if you want to experiment with different board sizes.
Option Explicit 'a range representing a chessboard's squares Private prngSquares As Range Public Sub CreateOn(ByRef wstTarget As Worksheet) 'we will use C3 as the top left square of the board 'so that no knight moves can take us off the worksheet Const strTOP_LEFT_CELL As String = "C3" 'grid rows and columns representing dimensions of the chess board 'change dimensions to suit (a traditional board is 8x8): Const lngROW_COUNT As Long = 8 Const lngCOL_COUNT As Long = 8 'create the chessboard Set prngSquares = wstTarget.Range(strTOP_LEFT_CELL).Resize(lngROW_COUNT, lngCOL_COUNT) End Sub Public Property Get Squares() As Range Set Squares = prngSquares End Property
Next we need a class called
cKnight to represent a knight and which can work out where the knight should move to. This is where we implement the Warnsdorff’s rule mentioned earlier. The methodology is as follows:
- If the knight has not been moved before then place it on a random square.
- Otherwise pick which candidate square to move the knight to:
- Determine all eight candidate squares which the knight can move to, whether or not those candidate squares are valid.
- Determine which of those candidate squares are valid. To be valid, the candidate square must be on the chessboard and must not have been visited by the knight before.
- If there are no valid candidate squares then do not move the knight.
- If there is only one valid candidate square then move the knight to it.
- If there are multiple, valid candidate squares then check them to see how many subsequent, valid moves can be made from each one and pick the one with the least number of subsequent valid moves. Tie breaks are decided by randomly picking a square.
Option Explicit Private prngCurrentPosition As Range Private plngMoveCount As Long 'A function to calculate the best, legal move the knight can make Private Function GetBestMove( _ ByRef rngCurrentSquare As Range, _ ByRef rngChessBoard As Range) As Range '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 'the largest number of squares a knight can move to is 8 Const lngMAX_MOVES As Long = 8 Dim rngPrimaryCandidates As Range 'looking one move ahead Dim rngSecondaryCandidates As Range 'looking two moves ahead Dim rngPrimaryCandidate As Range 'a cell enumerator Dim rngBestSquare As Range 'track the best move we find Dim lngNextMoveCounter As Long 'track the least number of subsequent legal moves 'determine the legal moves the knight can make Set rngPrimaryCandidates = GetLegalMoves(rngCurrentSquare, rngChessBoard) 'if there are no legal first moves then do nothing If rngPrimaryCandidates Is Nothing Then '(set rngBestSquare = nothing) 'if there is only one legal move then we have to move there ElseIf rngPrimaryCandidates.Areas.Count = 1 Then Set rngBestSquare = rngPrimaryCandidates 'if there are multiple legal moves we have to determine 'which is the best Else lngNextMoveCounter = lngMAX_MOVES 'loop through all the squares which are legal 1st moves For Each rngPrimaryCandidate In rngPrimaryCandidates.Areas 'determine all the possible legal 2nd moves from the 1st move Set rngSecondaryCandidates = GetLegalMoves(rngPrimaryCandidate, rngChessBoard) If Not rngSecondaryCandidates Is Nothing Then With rngSecondaryCandidates.Areas 'if there are less 2nd moves from that square than 'any others we have checked then we want it If .Count < lngNextMoveCounter Then lngNextMoveCounter = .Count Set rngBestSquare = rngPrimaryCandidate ElseIf .Count = lngNextMoveCounter Then 'if multiple squares are equally viable we'll randomly pick one 'at the end. This will always be a Union: Set rngBestSquare = Union(rngBestSquare, rngPrimaryCandidate) End If End With End If Next rngPrimaryCandidate 'if there are equally good squares to move to then we'll randomly pick one 'as per the traditional Warnsdorff's algorithm 'note that research by Pohl suggests an improvement would be to then count 'the number of possible moves from these squares too and, only if those are also equal, 'to randomly choose one. ("second level tie-breaking") If Not rngBestSquare Is Nothing Then If rngBestSquare.Count > 1 Then Set rngBestSquare = rngBestSquare.Areas(Int((rngBestSquare.Count) * Rnd + 1)) End If End If End If Set GetBestMove = rngBestSquare End Function 'A function to get all the legal moves the knight can make Private Function GetLegalMoves( _ ByRef rngCurrentSquare As Range, _ ByRef rngChessBoard As Range) As Range Dim rngCell As Range For Each rngCell In GetAllMoves(rngCurrentSquare) If IsMoveLegal(rngCell, rngChessBoard) 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 rngTargetSquare As Range, _ ByRef rngChessBoard As Range) As Boolean 'has the square been visited yet? If IsEmpty(rngTargetSquare.Value2) Then 'is the square on the chess board? IsMoveLegal = Not Intersect(rngTargetSquare, rngChessBoard) Is Nothing End If End Function 'A function to determine all the possible moves (legal or not) a knight could make Private Function GetAllMoves(ByRef rngCurrentSquare As Range) As Range With rngCurrentSquare 'knights move in L shapes 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 random square on chess board to start from Private Function GetStartSquare(ByRef rngChessBoard As Range) As Range With rngChessBoard Set GetStartSquare = .Cells((.Count * Rnd) + 1) End With End Function Private Sub Class_Initialize() Randomize End Sub 'this is the function which will be called to move the knight Public Function Move(ByRef rngChessBoard As Range) As Boolean 'if the knight hasn't moved before, let's put it on the board If plngMoveCount = 0 Then Set prngCurrentPosition = GetStartSquare(rngChessBoard) prngCurrentPosition.Interior.Color = vbYellow 'otherwise let's find the best move for the knight Else Set prngCurrentPosition = GetBestMove(prngCurrentPosition, rngChessBoard) End If 'if we managed to move the knight then let's put the move 'number on the board and return True to the caller If Not prngCurrentPosition Is Nothing Then plngMoveCount = plngMoveCount + 1 prngCurrentPosition.Value2 = plngMoveCount Move = True End If End Function 'a read-only property to return the 'number of moves the knight has made Public Property Get MoveCount() As Long MoveCount = plngMoveCount End Property
Finally we need our main procedure in a standard code module which creates the chessboard and knight, and solves the tour. We’ll give it 10 chances to try to create a valid tour.
Option Explicit 'the main sub to run to try to solve the puzzle Public Sub Main() 'the maximum number of permissable attempts to solve the puzzle 'change max number of attempts to suit: Const lngMAX_ATTEMPTS As Long = 10 Dim lngAttempts As Long 'remember how many tries the algorithm has had Dim strMsg As String 'a report message Dim clsChessBoard As cChessBoard 'a chessboard object holder Dim clsKnight As cKnight 'a knight object holder Dim blnKnightMoved As Boolean 'create a chessboard instance and tell it which sheet it belongs to Set clsChessBoard = New cChessBoard clsChessBoard.CreateOn ThisWorkbook.Worksheets.Add 'try to solve the puzzle Do lngAttempts = lngAttempts + 1 'start with an empty board clsChessBoard.Squares.Clear 'create our knight piece which will be moved around the board Set clsKnight = New cKnight 'move the knight around the board until we run out of available squares Do blnKnightMoved = clsKnight.Move(clsChessBoard.Squares) Loop While blnKnightMoved And (clsKnight.MoveCount < clsChessBoard.Squares.Count) 'did we solve the puzzle? If clsKnight.MoveCount = clsChessBoard.Squares.Count Then strMsg = "Solved" Exit Do End If Loop While lngAttempts < lngMAX_ATTEMPTS 'create a report message for the end user If LenB(strMsg) = 0 Then strMsg = "Failed" strMsg = strMsg & " after " & CStr(lngAttempts) & " attempt" If lngAttempts > 1 Then strMsg = strMsg & "s" MsgBox strMsg End Sub
Have a go at running the main sub a few times and see how you get on. I found that the algorithm runs pretty quickly and only occasionally requires more than one attempt to solve the puzzle on an 8 x 8 board.