KnightTour1a.nb

Knight's Tour Code

Author:    Dr Colin Rose, colin@tri.org.au
Designed:    Theoretical Research Institute, Sydney
Copyright:     1998, 2002

Knight’s Tour Functions -- Load me up!

The following text and code from Dr. Colin Rose is converted directly from a Mathematica notebook file called KnightTour.nb:

KnightTour[rows, columns, startingpoint(s)] finds ALL solutions to the knight's tour problem. For instance, KnightTour[4, 5, {2,3}] finds all solutions for a chess board that is 4 rows high, 5 columns wide, with the knight starting out at the intersection of row 2 and column 3. Note that {1,1} denotes the bottom left corner of the board. Similarly, KnightTour[4, 5, { {1,2}, {3,1}, {4,3} }] finds all solutions for a chess board that is 4 rows high, 5 columns wide, when the knight's first 3 moves are {1, 2}, then {3,1} and then {4,3}.

KnightTour[ rows, columns, startingpoint(s), endingpoint(s)] supports an optional 4th argument "endingpoint(s)" which allows one to specify the ending position or the ending path, and so find ALL the solutions that satisfy both the given starting path and ending path. Indeed, if the ending path is known, it should always be specified as this makes finding the solution set far more efficient. The more given points specified, the faster the solutions!
[Dan Thomasson suggested the endingpoint feature while Michael Taktikos provided additional code.]

KnightTour[rows_Integer, columns_Integer, start_List, end_List:{}] := 
   Module[{sR = rows+1, sC = columns+1, i = 0, j = 0, path, endMoves,
           tree = {0}, SNew, KnightMoves, FeasibleMoves, area},
           
    path = If[IntegerQ[start[[1]]], {start}, start];
    
    endMoves  = If[end != {}, If[IntegerQ[end[[1]]],{end},end], {}];
    
    area = (rows*columns) - Length[endMoves];
      
    KnightMoves[lis_List] := KnightMoves[lis] = Complement[
        Cases[ Map[ lis +#&, {{1,2},{1,-2},{-1,2},{-1,-2},{2,1},{2,-1},{-2,1},{-2,-1}}], 
             {x_/;0<x<sR, y_/;0<y<sC}], endMoves];
 
    FeasibleMoves = Compile[{{lis1, _Integer, 2}, {lis2, _Integer, 2}}, Complement[lis1, lis2]];
                   
While[First[tree]==0,
     
  SNew = FeasibleMoves[KnightMoves[Last[path]], path];
                   
Which[ SNew == {},         (* Back  *) 
                                  j++;  path = tree[[-1]];  tree = Drop[tree, -1],
                                             
Length[SNew] == 1,  (* Advance -> single branch *)
  AppendTo[path, First[SNew]]; 
    If[ Length[path] == area,
      Which[ endMoves == {},  
        i++; Print["Solution ",i]; PlotTour[Flatten[{path, endMoves},1]],
       (*  i++; Print["Solution ",i,": ", Flatten[{path, endMoves},1]]; PlotTour[Flatten[{path, endMoves},1]], *)
       Intersection[KnightMoves[First[endMoves]],{Last[path]}] == {Last[path]},
        i++; Print["Solution ",i]; PlotTour[Flatten[{path, endMoves},1]] ]
       (*  i++; Print["Solution ",i,": ", Flatten[{path, endMoves},1]]; PlotTour[Flatten[{path, endMoves},1]] ] *)
      ],
                                                                 
    True, (* Advance -> multiple branches *)
          tree = Join[tree, Map[Append[path, #]&, Rest[SNew]]] ;
            AppendTo[path, First[SNew]]  
           ]
       ];
        
        Print["All Done. I traversed ", j, " paths. Solutions: ", i]  ]

PlotTour[path] plots out a particular path, marking the starting point GREEN and the ending point RED. The PlotTour function automatically checks if the tour is closed (re-entrant). If the tour is closed, the notion of a starting/ending point is not meaningful and therefore the red/green markers are not plotted, and the end point is joined to the start point. The second argument, dotsize, is optional and allows one to vary the pointsize of the black dots at the centre of each square. The default size is 7.

PlotTour[path_, dotsize_:0] := Module[{moves, sol, closedpath, rows, columns, A, B},
    
         moves = {{1,2},{1,-2},{-1,2},{-1,-2},{2,1},{2,-1},{-2,1},{-2,-1}};
    
           sol = Map[Reverse, path];
    
    closedpath = If[ Intersection[Map[#+First[path]&,moves],{Last[path]}]=={}, False, True];
    
    If[closedpath === True, AppendTo[sol, First[sol]]];
    
    {rows, columns} = Map[Max, Transpose[path]];
    
    A = ListPlot[sol, PlotJoined -> False, PlotStyle -> {AbsolutePointSize[dotsize]}, 
                 Frame -> False, PlotRange -> {{0.5, columns+.5}, {0.5, rows+.5}}, 
                 AspectRatio -> rows/columns, Axes -> False, Ticks -> False, 
                 GridLines -> {Table[i - 1/2, {i, columns+1}], Table[i - 1/2, {i, rows+1}]}, 
                 Prolog -> If[closedpath===True, {},
                              {{Hue[0.35,1,1], Rectangle[First[sol]-0.2, First[sol]+0.2]}, 
                               {Hue[1],        Rectangle[Last[sol] -0.2, Last[sol] +0.2]}}],
                 DisplayFunction -> Identity];
    B = ListPlot[sol, PlotJoined-> True, PlotStyle -> Hue[1], DisplayFunction -> Identity];
    Show[A, B, DisplayFunction -> $DisplayFunction] ]