Knight’s Tour

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.