The Knight’s tour is an ancient mathematical problem that dates back to the 9th Century AD. The problem consists of finding a path that allows the Knight chess piece to visit every single square on a chessboard once only.
Whilst there have been many different approaches to solving this problem, one of the earliest known methods was introduced in 1823 by H.C Von Warnsdorf. This post describes an implementation of his rule using Excel and VBA to solve the problem. A video showing the completed solution in action can be found below:
How this Works
To begin with, the application randomly picks a square from an 8×8 chessboard, and then moves the Knight (according to the rule) to a new square until all of the squares have been visited. The diagram below shows the legal moves that the Knight is allowed to make:
From the centre square it can visit any of the locations marked with an X, and can jump over visited squares to get to that location. To cover the whole board, the Knight needs to make 63 moves. The Knight’s path can be tracked by the sequence of numbers it leaves behind.
Implementing the Rule
Warnsdorf’s rule works by identifying all possible moves from a given square, and then selecting the square to move to that has the least amount of onward moves. Any visited squares are not included in the count of onward moves. If there is more than one square that matches the selection criteria, then the square chosen is picked at random from these matching contenders.
In the diagram, the Knight can move to any square with a number in it. The numbers represent the number of onward moves from that particular square. The next square to move to will be the one with the lowest number which in this case happens to be 2. Since there are 2 squares with 2 onward moves, either of these squares can be chosen next.
About the Code
The Excel application itself consists of 3 main elements. The first element is the Knight Tour Class which handles most of the work:
The class consists of methods relating to move identification and piece animation, as well as properties which allow the board range and piece font to be specified. The code for the class is presented here in its entirety:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 |
Option Explicit #If VBA7 Then Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) 'For 64 Bit Systems #Else Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'For 32 Bit Systems #End If Private Type udtLocation RowValue As Long ColumnValue As Integer End Type Private mudtPosition(1 To 8) As udtLocation Private mrngArrVisited() As Range Private mrngBoard As Range Private mintVisitedCnt As Integer Private mintSequence As Integer Private mintPieceAscCode As Integer Private mlngDelay As Long Private mstrPieceFontName As String Private Const CINT_VISITED_COLORINDEX As Integer = 1 Private Const CINT_CURRENT_COLORINDEX As Integer = 45 Private Const CINT_CURRENT_SYMBOL_SIZE As Integer = 28 Private Const CINT_VISITED_SYMBOL_SIZE As Integer = 8 Private Const CINT_DEFAULT_ASCII_CHAR As Integer = 88 Private Const CLNG_DEFAULT_DELAY As Long = 250 Private Const CSTR_DEFAULT_FONT As String = "Arial" Private Sub Class_Initialize() mlngDelay = CLNG_DEFAULT_DELAY mudtPosition(1).RowValue = -2: mudtPosition(1).ColumnValue = 1 mudtPosition(2).RowValue = 1: mudtPosition(2).ColumnValue = 2 mudtPosition(3).RowValue = 2: mudtPosition(3).ColumnValue = 1 mudtPosition(4).RowValue = -1: mudtPosition(4).ColumnValue = 2 mudtPosition(5).RowValue = -2: mudtPosition(5).ColumnValue = -1 mudtPosition(6).RowValue = -1: mudtPosition(6).ColumnValue = -2 mudtPosition(7).RowValue = 1: mudtPosition(7).ColumnValue = -2 mudtPosition(8).RowValue = 2: mudtPosition(8).ColumnValue = -1 mintSequence = 1 ReDim mrngArrVisited(0 To 0) mintVisitedCnt = 0 mstrPieceFontName = CSTR_DEFAULT_FONT mintPieceAscCode = CINT_DEFAULT_ASCII_CHAR End Sub Public Property Let PieceFontName(ByVal Value As String) mstrPieceFontName = Value End Property Public Property Let PieceAscCode(ByVal Value As Integer) mintPieceAscCode = Value End Property Public Property Let BoardArea(ByVal Value As Range) Set mrngBoard = Value mrngBoard.ClearContents End Property Private Function IsValidPosition(ByVal rngCell As Range) As Boolean If Intersect(rngCell, mrngBoard) Is Nothing Then IsValidPosition = False Else IsValidPosition = True End If End Function Public Function GetRandomSquareFromBoard() As Range Dim intRndCell As Integer Dim intBoardCellsCnt As Integer If Not mrngBoard Is Nothing Then intBoardCellsCnt = mrngBoard.Cells.Count intRndCell = GetRandomNumber(intBoardCellsCnt, 1) Set GetRandomSquareFromBoard = mrngBoard.Cells(intRndCell) End If End Function Public Sub RemovePiece(ByVal rngSquare As Range) With rngSquare .Font.Size = CINT_VISITED_SYMBOL_SIZE .Font.Bold = True .Font.ColorIndex = CINT_VISITED_COLORINDEX .Font.Name = CSTR_DEFAULT_FONT End With End Sub Public Sub DisplayPiece(ByVal rngSquare As Range) With rngSquare .Font.Size = CINT_CURRENT_SYMBOL_SIZE .Font.Bold = True .Font.ColorIndex = CINT_CURRENT_COLORINDEX .Value = Chr(mintPieceAscCode) .Font.Name = mstrPieceFontName End With End Sub Public Sub MovePiece(ByVal rngFrom As Range, ByVal rngTo As Range) Application.ScreenUpdating = False Sleep mlngDelay RemovePiece rngFrom rngFrom.Value = mintSequence mintSequence = mintSequence + 1 DisplayPiece rngTo Application.ScreenUpdating = True End Sub Public Function GetNextMove(ByVal rngCell As Range) As Range Dim intCnt As Integer Dim intMaxMoves As Integer Dim intMoves As Integer Dim intArrCnt As Integer Dim intRnd As Integer Dim rngNewLocation As Range Dim arrListOfSquaresToMoveTo() As Range intArrCnt = 0 intMoves = 0 intMaxMoves = UBound(mudtPosition) ReDim Preserve mrngArrVisited(0 To mintVisitedCnt) Set mrngArrVisited(mintVisitedCnt) = rngCell mintVisitedCnt = mintVisitedCnt + 1 For intCnt = LBound(mudtPosition) To UBound(mudtPosition) DoEvents Set rngNewLocation = rngCell.Offset(mudtPosition(intCnt).RowValue, mudtPosition(intCnt).ColumnValue) If IsValidPosition(rngNewLocation) Then If Not IsVisitedLocation(rngNewLocation) Then intMoves = CountPossibleMovesFromLocation(rngNewLocation) Select Case intMoves Case Is < intMaxMoves intMaxMoves = intMoves intArrCnt = 0 ReDim arrListOfSquaresToMoveTo(0 To intArrCnt) Set arrListOfSquaresToMoveTo(intArrCnt) = rngNewLocation intArrCnt = intArrCnt + 1 Case intMaxMoves ReDim Preserve arrListOfSquaresToMoveTo(0 To intArrCnt) Set arrListOfSquaresToMoveTo(intArrCnt) = rngNewLocation intArrCnt = intArrCnt + 1 End Select End If End If Next If intArrCnt > 0 Then intRnd = GetRandomNumber(UBound(arrListOfSquaresToMoveTo), LBound(arrListOfSquaresToMoveTo)) Set GetNextMove = arrListOfSquaresToMoveTo(intRnd) End If Set rngNewLocation = Nothing End Function Private Function CountPossibleMovesFromLocation(ByVal rngCell As Range) As Integer Dim intPos As Integer Dim intCnt As Integer Dim rngNewLocation As Range intCnt = 0 For intPos = LBound(mudtPosition) To UBound(mudtPosition) DoEvents Set rngNewLocation = rngCell.Offset(mudtPosition(intPos).RowValue, mudtPosition(intPos).ColumnValue) If IsValidPosition(rngNewLocation) Then If Not IsVisitedLocation(rngNewLocation) Then intCnt = intCnt + 1 End If End If Next Set rngNewLocation = Nothing CountPossibleMovesFromLocation = intCnt End Function Private Function IsVisitedLocation(ByVal rngCell As Range) As Boolean Dim intCnt As Integer IsVisitedLocation = False If mintVisitedCnt = 0 Then Exit Function End If For intCnt = LBound(mrngArrVisited) To UBound(mrngArrVisited) DoEvents If mrngArrVisited(intCnt).Address = rngCell.Address Then IsVisitedLocation = True Exit Function End If Next End Function Private Function GetRandomNumber(ByVal lngMaxValue As Long, Optional ByVal lngMinValue As Long = 0) Randomize GetRandomNumber = Int((lngMaxValue - lngMinValue + 1) * Rnd) + lngMinValue End Function |
The second element is a main subroutine that runs the entire program using the methods and properties of the Knight tour class. It is fairly short because it does not have much work to do (the program’s complexity is handled by the class!). In a nutshell, all it does is create an instance of the Knight class, tells the instantiated object where the board is, picks a random square to start with, and then keeps moving the Knight to a valid square until no more moves can be found. The code is presented below:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 |
Option Explicit Public Sub StartKnightsTour() On Error GoTo ERR_HANDLER: Dim rngSquare As Range Dim rngSquareNext As Range Dim oKnight As New clsKnightTour oKnight.BoardArea = Range("Board") Set rngSquare = oKnight.GetRandomSquareFromBoard oKnight.PieceAscCode = 140 oKnight.PieceFontName = "Chess Alpha" oKnight.DisplayPiece rngSquare With oKnight Do Set rngSquareNext = .GetNextMove(rngSquare) If rngSquareNext Is Nothing Then Exit Do 'no more possible moves Else .MovePiece rngSquare, rngSquareNext End If Set rngSquare = rngSquareNext Loop End With EXIT_HERE: Set rngSquare = Nothing Set rngSquareNext = Nothing Set oKnight = Nothing Exit Sub ERR_HANDLER: Debug.Print Err.Description GoTo ExitHere End Sub |
The third element is the graphical display. The chessboard is represented using standard Excel cell formatting techniques. However, the Knight chess piece itself is created using a third party TrueType font called Chess Alpha created by Eric Bentzen. The installation of this font occurs when the workbook is opened and it is uninstalled when the workbook is closed. The installation is handled by a separate class in the project. You can read more about the class in this post.
That covers the entire project in full. You can download the solution in the video from here (however please take time to read the disclaimer about content found on this site).
Share :Awesome to see!
— Microsoft Excel (@msexcel) October 13, 2017
