Solve a Holy Knight's tour
You are encouraged to solve this task according to the task description, using any language you may know.
Chess coaches have been known to inflict a kind of torture on beginners by taking a chess board, placing some pennies on some squares and requiring that a Knight's tour that avoids squares with pennies be constructed.
This kind of knight's tour puzzle is similar to Hidato.
The present task is to produce a solution to such problems. At least demonstrate your program by solving the following:
- Example 1
0 0 0
0 0 0
0 0 0 0 0 0 0
0 0 0 0 0
0 0 0 0 0
1 0 0 0 0 0 0
0 0 0
0 0 0
Extra credit is available for other interesting examples.
Ada
This solution uses the package Knights_Tour from Knight's Tour#Ada. The board is quadratic, the size of the board is read from the command line and the board itself is read from the standard input. For the board itself, Space and Minus indicate a no-go (i.e., a coin on the board), all other characters represent places the knight must visit. A '1' represents the start point. Ill-formatted input will crash the program.
<lang Ada>with Knights_Tour, Ada.Text_IO, Ada.Command_Line;
procedure Holy_Knight is
Size: Positive := Positive'Value(Ada.Command_Line.Argument(1)); package KT is new Knights_Tour(Size => Size); Board: KT.Tour := (others => (others => Natural'Last)); Start_X, Start_Y: KT.Index:= 1; -- default start place (1,1) S: String(KT.Index); I: Positive := KT.Index'First;
begin
-- read the board from standard input
while not Ada.Text_IO.End_Of_File and I <= Size loop
S := Ada.Text_IO.Get_Line;
for J in KT.Index loop
if S(J) = ' ' or S(J) = '-' then
Board(I,J) := Natural'Last;
elsif S(J) = '1' then
Start_X := I; Start_Y := J; Board(I,J) := 1;
else Board(I,J) := 0;
end if;
end loop;
I := I + 1;
end loop;
-- print the board
Ada.Text_IO.Put_Line("Start Configuration (Length:"
& Natural'Image(KT.Count_Moves(Board)) & "):");
KT.Tour_IO(Board, Width => 1);
Ada.Text_IO.New_Line;
-- search for the tour and print it
Ada.Text_IO.Put_Line("Tour:");
KT.Tour_IO(KT.Warnsdorff_Get_Tour(Start_X, Start_Y, Board));
end Holy_Knight;</lang>
- Output:
>holy_knight 8 < standard_problem.txt Start Configuration (Length: 36): --000--- --0-00-- -0000000 000--0-0 0-0--000 1000000- --00-0-- ---000-- Tour: - - 30 15 20 - - - - - 21 - 29 16 - - - 33 14 31 22 19 6 17 13 36 23 - - 28 - 8 34 - 32 - - 7 18 5 1 12 35 24 27 4 9 - - - 2 11 - 25 - - - - - 26 3 10 - -
Extra Credit
The Holy_Knight program can immediately be used to tackle "more interesting" problems, such as those from New Knight's Tour Puzzles and Graphs. Here is one sample solution:
>holy_knight 13 < problem10.txt Start Configuration (Length: 56): -----1-0----- -----0-0----- ----00000---- -----000----- --0--0-0--0-- 00000---00000 --00-----00-- 00000---00000 --0--0-0--0-- -----000----- ----00000---- -----0-0----- -----0-0----- Tour: - - - - - 1 - 27 - - - - - - - - - - 56 - 2 - - - - - - - - - 24 3 28 55 26 - - - - - - - - - 54 25 4 - - - - - - - 50 - - 23 - 29 - - 6 - - 51 20 47 22 53 - - - 5 30 9 32 7 - - 52 49 - - - - - 33 36 - - 19 48 21 46 17 - - - 37 10 31 8 35 - - 18 - - 45 - 11 - - 34 - - - - - - - 16 41 38 - - - - - - - - - 42 39 44 15 12 - - - - - - - - - 14 - 40 - - - - - - - - - - 43 - 13 - - - - -
Bracmat
This solution can handle different input formats: the widths of the first and the other columns are computed. The cell were to start from should have a unique value, but this value is not prescribed. Non-empty cells (such as the start cell) should contain a character that is different from '-', '.' or white space. The puzzle solver itself is only a few lines long. <lang bracmat>( ( Holy-Knight
= begin colWidth crumbs non-empty pairs path parseLine
, display isolateStartCell minDistance numberElementsAndSort
, parseBoard reverseList rightAlign solve strlen
. "'non-empty' is a pattern that is used several times in bigger patterns."
& ( non-empty
=
= %@
: ~( "."
| "-"
| " "
| \t
| \r
| \n
)
)
& ( reverseList
= a L
. :?L
& whl'(!arg:%?a ?arg&!a !L:?L)
& !L
)
& (strlen=e.@(!arg:? [?e)&!e)
& ( rightAlign
= string width
. !arg:(?width,?string)
& !width+-1*strlen$!string:?width
& whl
' ( !width+-1:~<0:?width
& " " !string:?string
)
& str$!string
)
& ( minDistance
= board pat1 pat2 minWidth pos1 pos2 pattern
. !arg:(?board,(=?pat1),(=?pat2))
& -1:?minWidth
& "Construct a pattern using a template.
The pattern finds the smallest distance between any two columns in the input.
Assumption: all columns have the same width and columns are separated by one or
more spaces. The function can also be used to find the width of the first column
by letting pat1 match a new line."
&
' ( ?
( $pat1
[?pos1
(? " "|`)
()$pat2
[?pos2
?
& !pos2+-1*!pos1
: ( <!minWidth
| ?&!minWidth:<0
)
: ?minWidth
& ~
)
)
: (=?pattern)
& "'pattern', by design, always fails. The interesting part is a side effect:
the column width."
& (@(!board:!pattern)|!minWidth)
)
& ( numberElementsAndSort
= a sum n
. 0:?sum:?n
& "An evaluated sum is always sorted. The terms are structured so the sorting
order is by row and then by column (both part of 'a')."
& whl
' ( !arg:%?a ?arg
& 1+!n:?n
& (!a,!n)+!sum:?sum
)
& "return the sorted list (sum) and also the size of a field that can contain
the highest number."
& (!sum.strlen$!n+1)
)
& ( parseLine
= line row columnWidth width col
, bins val A M Z cell validPat
. !arg:(?line,?row,?width,?columnWidth,?bins)
& 0:?col
& "Find the cells and create a pair [row,col] for each. Put each pair in a bin.
There are as many bins as there are different values in cells."
& '(? ($!non-empty:?val) ?)
: (=?validPat)
& whl
' ( @(!line:?cell [!width ?line)
& ( @(!cell:!validPat)
& ( !bins:?A (!val.?M) ?Z
& !A (!val.(!row.!col) !M) !Z
| (!val.!row.!col) !bins
)
: ?bins
|
)
& !columnWidth:?width
& 1+!col:?col
)
& !bins
)
& ( parseBoard
= board firstColumnWidth columnWidth,row bins line
. !arg:?board
& ( minDistance
$ (str$(\r \n !arg),(=\n),!non-empty)
, minDistance$(!arg,!non-empty,!non-empty)
)
: (?firstColumnWidth,?columnWidth)
& 0:?row
& :?bins
& whl
' ( @(!board:?line \n ?board)
& parseLine
$ (!line,!row,!firstColumnWidth,!columnWidth,!bins)
: ?bins
& (!bins:|1+!row:?row)
)
& parseLine
$ (!board,!row,!firstColumnWidth,!columnWidth,!bins)
: ?bins
)
& "Find the first bin with only one pair. Return this pair and the combined pairs in
all remaining bins."
& ( isolateStartCell
= A begin Z valuedPairs pairs
. !arg:?A (?.? [1:?begin) ?Z
& !A !Z:?arg
& :?pairs
& whl
' ( !arg:(?.?valuedPairs) ?arg
& !valuedPairs !pairs:?pairs
)
& (!begin.!pairs)
)
& ( display
= board solution row col x y n colWidth
. !arg:(?board,?solution,?colWidth)
& out$!board
& 0:?row
& -1:?col
& whl
' ( !solution:((?y.?x),?n)+?solution
& whl
' ( !row:<!y
& 1+!row:?row
& -1:?col
& put$\n
)
& whl
' ( 1+!col:?col:<!x
& put$(rightAlign$(!colWidth,))
)
& put$(rightAlign$(!colWidth,!n))
)
& put$\n
)
& ( solve
= A Z x y crumbs pairs X Y solution
. !arg:((?y.?x),?crumbs,?pairs)
& ( !pairs:&(!y.!x) !crumbs
| !pairs
: ?A
( (?Y.?X) ?Z
& (!x+-1*!X)*(!y+-1*!Y)
: (2|-2)
& solve
$ ( (!Y.!X)
, (!y.!x) !crumbs
, !A !Z
)
: ?solution
)
& !solution
)
)
& ( isolateStartCell$(parseBoard$!arg):(?begin.?pairs)
| out$"Sorry, I cannot identify a start cell."&~
)
& solve$(!begin,,!pairs):?crumbs
& numberElementsAndSort$(reverseList$!crumbs)
: (?path.?colWidth)
& display$(!arg,!path,!colWidth)
)
& "
0 0 0
0 0 0
0 0 0 0 0 0 0
0 0 0 0 0
0 0 0 0 0
1 0 0 0 0 0 0
0 0 0
0 0 0
"
"
1-0-----
0-0-----
00000----
000-----
--0--0-0--0-- 00000---00000 --00-----00-- 00000---00000 --0--0-0--0--
000-----
00000----
0-0-----
0-0-----"
: ?boards
& whl'(!boards:%?board ?boards&Holy-Knight$!board) & done );</lang> Output:
0 0 0
0 0 0
0 0 0 0 0 0 0
0 0 0 0 0
0 0 0 0 0
1 0 0 0 0 0 0
0 0 0
0 0 0
21 30 19
36 22 29
31 20 35 18 23 28 25
15 34 17 26 8
32 14 9 24 27
1 16 33 10 13 4 7
2 5 11
12 3 6
-----1-0-----
-----0-0-----
----00000----
-----000-----
--0--0-0--0--
00000---00000
--00-----00--
00000---00000
--0--0-0--0--
-----000-----
----00000----
-----0-0-----
-----0-0-----
1 27
26 56
30 55 2 25 28
24 29 54
36 31 3 50
37 34 39 32 23 53 4 47 6 51
22 35 49 52
21 38 33 40 19 9 46 5 48 7
20 41 45 8
18 43 10
42 11 14 17 44
16 12
13 15
C++
<lang cpp>
- include <vector>
- include <sstream>
- include <iostream>
- include <iterator>
- include <stdlib.h>
- include <string.h>
using namespace std;
struct node {
int val; unsigned char neighbors;
};
class nSolver { public:
nSolver()
{
dx[0] = -1; dy[0] = -2; dx[1] = -1; dy[1] = 2; dx[2] = 1; dy[2] = -2; dx[3] = 1; dy[3] = 2; dx[4] = -2; dy[4] = -1; dx[5] = -2; dy[5] = 1; dx[6] = 2; dy[6] = -1; dx[7] = 2; dy[7] = 1;
}
void solve( vector<string>& puzz, int max_wid )
{
if( puzz.size() < 1 ) return; wid = max_wid; hei = static_cast<int>( puzz.size() ) / wid; int len = wid * hei, c = 0; max = len; arr = new node[len]; memset( arr, 0, len * sizeof( node ) );
for( vector<string>::iterator i = puzz.begin(); i != puzz.end(); i++ ) { if( ( *i ) == "*" ) { max--; arr[c++].val = -1; continue; } arr[c].val = atoi( ( *i ).c_str() ); c++; }
solveIt(); c = 0; for( vector<string>::iterator i = puzz.begin(); i != puzz.end(); i++ ) { if( ( *i ) == "." ) { ostringstream o; o << arr[c].val; ( *i ) = o.str(); } c++; } delete [] arr;
}
private:
bool search( int x, int y, int w )
{
if( w > max ) return true;
node* n = &arr[x + y * wid]; n->neighbors = getNeighbors( x, y );
for( int d = 0; d < 8; d++ ) { if( n->neighbors & ( 1 << d ) ) { int a = x + dx[d], b = y + dy[d]; if( arr[a + b * wid].val == 0 ) { arr[a + b * wid].val = w; if( search( a, b, w + 1 ) ) return true; arr[a + b * wid].val = 0; } } } return false;
}
unsigned char getNeighbors( int x, int y )
{
unsigned char c = 0; int a, b; for( int xx = 0; xx < 8; xx++ ) { a = x + dx[xx], b = y + dy[xx]; if( a < 0 || b < 0 || a >= wid || b >= hei ) continue; if( arr[a + b * wid].val > -1 ) c |= ( 1 << xx ); } return c;
}
void solveIt()
{
int x, y, z; findStart( x, y, z ); if( z == 99999 ) { cout << "\nCan't find start point!\n"; return; } search( x, y, z + 1 );
}
void findStart( int& x, int& y, int& z )
{
z = 99999; for( int b = 0; b < hei; b++ ) for( int a = 0; a < wid; a++ ) if( arr[a + wid * b].val > 0 && arr[a + wid * b].val < z ) { x = a; y = b; z = arr[a + wid * b].val; }
}
int wid, hei, max, dx[8], dy[8]; node* arr;
};
int main( int argc, char* argv[] ) {
int wid; string p;
//p = "* . . . * * * * * . * . . * * * * . . . . . . . . . . * * . * . . * . * * . . . 1 . . . . . . * * * . . * . * * * * * . . . * *"; wid = 8;
p = "* * * * * 1 * . * * * * * * * * * * . * . * * * * * * * * * . . . . . * * * * * * * * * . . . * * * * * * * . * * . * . * * . * * . . . . . * * * . . . . . * * . . * * * * * . . * * . . . . . * * * . . . . . * * . * * . * . * * . * * * * * * * . . . * * * * * * * * * . . . . . * * * * * * * * * . * . * * * * * * * * * * . * . * * * * * "; wid = 13;
istringstream iss( p ); vector<string> puzz;
copy( istream_iterator<string>( iss ), istream_iterator<string>(), back_inserter<vector<string> >( puzz ) );
nSolver s; s.solve( puzz, wid );
int c = 0;
for( vector<string>::iterator i = puzz.begin(); i != puzz.end(); i++ )
{
if( ( *i ) != "*" && ( *i ) != "." ) { if( atoi( ( *i ).c_str() ) < 10 ) cout << "0"; cout << ( *i ) << " ";
}
else cout << " "; if( ++c >= wid ) { cout << endl; c = 0; }
} cout << endl << endl; return system( "pause" );
} </lang>
- Output:
17 14 29
28 18 15
13 16 27 30 19 32 07
25 02 11 06 20
12 26 31 08 33
01 24 03 10 05 34 21
36 23 09
04 35 22
01 05
10 12
02 13 04 09 06
08 11 14
34 03 07 16
7 30 39 28 35 15 56 49 54 51
36 33 17 52
1 38 29 40 27 19 48 55 50 53
32 41 47 18
26 23 20
42 21 44 25 46
24 22
43 45
D
From the refactored C++ version with more precise typing, and some optimizations. The HolyKnightPuzzle struct is created at compile-time, so its pre-conditions can catch most malformed puzzles at compile-time. <lang d>import std.stdio, std.conv, std.string, std.range, std.algorithm,
std.typecons, std.typetuple;
struct HolyKnightPuzzle {
private alias InputCellBaseType = char;
private enum InputCell : InputCellBaseType { available = '#', unavailable = '.', start='1' }
private alias Cell = uint;
private enum : Cell { unknownCell = 0, unavailableCell = Cell.max, startCell=1 } // Special Cell values.
// Neighbors, [shift row, shift column].
static struct P { int x, y; }
alias shifts = TypeTuple!(P(-2, -1), P(2, -1), P(-2, 1), P(2, 1),
P(-1, -2), P(1, -2), P(-1, 2), P(1, 2));
immutable size_t gridWidth, gridHeight; private immutable Cell nAvailableCells; private /*immutable*/ const InputCell[] flatPuzzle; private Cell[] grid; // Flattened mutable game grid.
@disable this();
this(in string[] rawPuzzle) pure @safe
in {
assert(!rawPuzzle.empty);
assert(!rawPuzzle[0].empty);
assert(rawPuzzle.all!(row => row.length == rawPuzzle[0].length)); // Is rectangular.
assert(rawPuzzle.join.count(InputCell.start) == 1); // Exactly one start point.
} body {
//immutable puzzle = rawPuzzle.to!(InputCell[][]);
immutable puzzle = rawPuzzle.map!representation.array.to!(InputCell[][]);
gridWidth = puzzle[0].length;
gridHeight = puzzle.length;
flatPuzzle = puzzle.join;
// This counts the start cell too.
nAvailableCells = flatPuzzle.representation.count!(ic => ic != InputCell.unavailable);
grid = flatPuzzle
.map!(ic => ic.predSwitch(InputCell.available, unknownCell,
InputCell.unavailable, unavailableCell,
InputCell.start, startCell))
.array;
}
Nullable!(string[][]) solve(size_t width)() pure /*nothrow*/ @safe
out(result) {
if (!result.isNull)
assert(!grid.canFind(unknownCell));
} body {
assert(width == gridWidth);
// Find start position.
foreach (immutable r; 0 .. gridHeight)
foreach (immutable c; 0 .. width)
if (grid[r * width + c] == startCell &&
search!width(r, c, startCell + 1)) {
auto result = zip(flatPuzzle, grid) // Not nothrow.
//.map!({p, c} => ...
.map!(pc => (pc[0] == InputCell.available) ?
pc[1].text :
InputCellBaseType(pc[0]).text)
.array
.chunks(width)
.array;
return typeof(return)(result);
}
return typeof(return)(); }
private bool search(size_t width)(in size_t r, in size_t c, in Cell cell) pure nothrow @safe @nogc {
if (cell > nAvailableCells)
return true; // One solution found.
// This doesn't use the Warnsdorff rule.
foreach (immutable sh; shifts) {
immutable r2 = r + sh.x,
c2 = c + sh.y,
pos = r2 * width + c2;
// No need to test for >= 0 because uint wraps around.
if (c2 < width && r2 < gridHeight && grid[pos] == unknownCell) {
grid[pos] = cell; // Try.
if (search!width(r2, c2, cell + 1))
return true;
grid[pos] = unknownCell; // Restore.
}
}
return false; }
}
void main() @safe {
// Enum HolyKnightPuzzle to catch malformed puzzles at compile-time.
enum puzzle1 = ".###....
.#.##...
.#######
###..#.#
#.#..###
1######.
..##.#..
...###..".split.HolyKnightPuzzle;
enum puzzle2 = ".....1.#.....
.....#.#.....
....#####....
.....###.....
..#..#.#..#..
#####...#####
..##.....##..
#####...#####
..#..#.#..#..
.....###.....
....#####....
.....#.#.....
.....#.#.....".split.HolyKnightPuzzle;
foreach (/*enum*/ puzzle; TypeTuple!(puzzle1, puzzle2)) {
//immutable solution = puzzle.solve!(puzzle.gridWidth);
enum width = puzzle.gridWidth;
immutable solution = puzzle.solve!width; // Solved at run-time.
if (solution.isNull)
writeln("No solution found for puzzle.\n");
else
writefln("One solution:\n%(%-(%2s %)\n%)\n", solution);
}
}</lang>
- Output:
One solution: . 17 14 29 . . . . . 28 . 18 15 . . . . 13 16 27 30 19 32 7 25 2 11 . . 6 . 20 12 . 26 . . 31 8 33 1 24 3 10 5 34 21 . . . 36 23 . 9 . . . . . 4 35 22 . . One solution: . . . . . 1 . 5 . . . . . . . . . . 10 . 12 . . . . . . . . . 2 13 4 9 6 . . . . . . . . . 8 11 14 . . . . . . . 34 . . 3 . 7 . . 16 . . 37 30 39 28 35 . . . 15 56 49 54 51 . . 36 33 . . . . . 17 52 . . 31 38 29 40 27 . . . 19 48 55 50 53 . . 32 . . 41 . 47 . . 18 . . . . . . . 26 23 20 . . . . . . . . . 42 21 44 25 46 . . . . . . . . . 24 . 22 . . . . . . . . . . 43 . 45 . . . . .
Run-time about 0.58 seconds with ldc2 compiler (using a switch statement if you don't have the predSwitch yet in Phobos), about 23 times faster than the Haskell entry.
Haskell
<lang Haskell>import qualified Data.Array as Arr import qualified Data.Foldable as Fold import qualified Data.List as List import Data.Maybe
type Position = (Int, Int) type KnightBoard = Arr.Array Position (Maybe Int)
toSlot :: Char -> Maybe Int toSlot '0' = Just 0 toSlot '1' = Just 1 toSlot _ = Nothing
toString :: Maybe Int -> String toString Nothing = replicate 3 ' ' toString (Just n) = replicate (3 - length nn) ' ' ++ nn
where nn = show n
chunksOf :: Int -> [a] -> a chunksOf _ [] = [] chunksOf n xs = take n xs : (chunksOf n $ drop n xs)
showBoard :: KnightBoard -> String showBoard board =
List.intercalate "\n" . map concat . List.transpose . chunksOf (height + 1) . map toString $ Arr.elems board where (_, (_, height)) = Arr.bounds board
toBoard :: [String] -> KnightBoard toBoard strs = board
where
height = length strs
width = minimum $ map length strs
board = Arr.listArray ((0, 0), (width - 1, height - 1))
. map toSlot . concat . List.transpose $ map (take width) strs
add :: Num a => (a, a) -> (a, a) -> (a, a)
add (a, b) (x, y) = (a + x, b + y)
within :: Ord a => ((a, a), (a, a)) -> (a, a) -> Bool within ((a, b), (c, d)) (x, y) =
a <= x && x <= c && b <= y && y <= d
-- Enumerate valid moves given a board and a knight's position. validMoves :: KnightBoard -> Position -> [Position] validMoves board position = filter isValid plausible
where
bound = Arr.bounds board
plausible = map (add position) [(1, 2), (2, 1), (2, -1), (-1, 2),
(-2, 1), (1, -2), (-1, -2), (-2, -1)]
isValid pos = within bound pos && maybe False (== 0) (board Arr.! pos)
isSolved :: KnightBoard -> Bool isSolved = Fold.all (maybe True (/= 0))
-- Solve the knight's tour with a simple Depth First Search. solveKnightTour :: KnightBoard -> Maybe KnightBoard solveKnightTour board = solve board 1 initPosition
where
initPosition = fst $ head $ filter ((== (Just 1)) . snd) $ Arr.assocs board
solve boardA depth position =
let boardB = boardA Arr.// [(position, Just depth)]
in if isSolved boardB
then Just boardB
else listToMaybe $ mapMaybe (solve boardB $ depth + 1)
$ validMoves boardB position
tourExA :: [String] tourExA =
[" 000 " ," 0 00 " ," 0000000" ,"000 0 0" ,"0 0 000" ,"1000000 " ," 00 0 " ," 000 "]
tourExB :: [String] tourExB =
["-----1-0-----" ,"-----0-0-----" ,"----00000----" ,"-----000-----" ,"--0--0-0--0--" ,"00000---00000" ,"--00-----00--" ,"00000---00000" ,"--0--0-0--0--" ,"-----000-----" ,"----00000----" ,"-----0-0-----" ,"-----0-0-----"]
main :: IO () main =
flip mapM_ [tourExA, tourExB] (\board -> case solveKnightTour $ toBoard board of Nothing -> putStrLn "No solution.\n" Just solution -> putStrLn $ showBoard solution ++ "\n")</lang>
- Output:
19 26 17
36 20 25
31 18 27 16 21 6 23
35 28 15 24 8
30 32 7 22 5
1 34 29 14 11 4 9
2 33 13
12 3 10
1 31
32 28
56 27 2 33 30
34 29 26
48 55 3 24
47 52 45 54 35 25 4 11 6 23
36 49 9 22
51 46 53 44 37 21 12 5 10 7
50 43 13 8
38 41 20
42 19 16 39 14
40 18
17 15
Icon and Unicon
This is a Unicon-specific solution: <lang unicon>global nCells, cMap, best record Pos(r,c)
procedure main(A)
puzzle := showPuzzle("Input",readPuzzle())
QMouse(puzzle,findStart(puzzle),&null,0)
showPuzzle("Output", solvePuzzle(puzzle)) | write("No solution!")
end
procedure readPuzzle()
# Start with a reduced puzzle space
p := [[-1],[-1]]
nCells := maxCols := 0
every line := !&input do {
put(p,[: -1 | -1 | gencells(line) | -1 | -1 :])
maxCols <:= *p[-1]
}
every put(p, [-1]|[-1])
# Now normalize all rows to the same length
every i := 1 to *p do p[i] := [: !p[i] | (|-1\(maxCols - *p[i])) :]
return p
end
procedure gencells(s)
static WS, NWS
initial {
NWS := ~(WS := " \t")
cMap := table() # Map to/from internal model
cMap["#"] := -1; cMap["_"] := 0
cMap[-1] := " "; cMap[0] := "_"
}
s ? while not pos(0) do {
w := (tab(many(WS))|"", tab(many(NWS))) | break
w := numeric(\cMap[w]|w)
if -1 ~= w then nCells +:= 1
suspend w
}
end
procedure showPuzzle(label, p)
write(label," with ",nCells," cells:")
every r := !p do {
every c := !r do writes(right((\cMap[c]|c),*nCells+1))
write()
}
return p
end
procedure findStart(p)
if \p[r := !*p][c := !*p[r]] = 1 then return Pos(r,c)
end
procedure solvePuzzle(puzzle)
if path := \best then {
repeat {
loc := path.getLoc()
puzzle[loc.r][loc.c] := path.getVal()
path := \path.getParent() | break
}
return puzzle
}
end
class QMouse(puzzle, loc, parent, val)
method getVal(); return val; end method getLoc(); return loc; end method getParent(); return parent; end method atEnd(); return nCells = val; end
method visit(r,c)
if /best & validPos(r,c) then return Pos(r,c)
end
method validPos(r,c)
v := val+1
xv := (0 <= puzzle[r][c]) | fail
if xv = (v|0) then { # make sure this path hasn't already gone there
ancestor := self
while xl := (ancestor := \ancestor.getParent()).getLoc() do
if (xl.r = r) & (xl.c = c) then fail
return
}
end
initially
val := val+1 if atEnd() then return best := self QMouse(puzzle, visit(loc.r-2,loc.c-1), self, val) QMouse(puzzle, visit(loc.r-2,loc.c+1), self, val) QMouse(puzzle, visit(loc.r-1,loc.c+2), self, val) QMouse(puzzle, visit(loc.r+1,loc.c+2), self, val) QMouse(puzzle, visit(loc.r+2,loc.c+1), self, val) QMouse(puzzle, visit(loc.r+2,loc.c-1), self, val) QMouse(puzzle, visit(loc.r+1,loc.c-2), self, val) QMouse(puzzle, visit(loc.r-1,loc.c-2), self, val)
end</lang>
Sample run:
->hkt <hkt.in
Input with 36 cells:
_ _ _
_ _ _
_ _ _ _ _ _ _
_ _ _ _ _
_ _ _ _ _
1 _ _ _ _ _ _
_ _ _
_ _ _
Output with 36 cells:
19 4 13
12 18 5
25 20 3 14 17 6 31
21 2 11 32 16
26 24 15 30 7
1 22 27 10 35 8 33
36 23 29
28 9 34
->
Perl 6
Using the Warnsdorff algorithm from Solve_a_Hidato_puzzle. <lang perl6>my @adjacent =
[ -2, -1], [ -2, 1],
[-1,-2], [-1,+2],
[+1,-2], [+1,+2],
[ +2, -1], [ +2, 1];
solveboard q:to/END/;
. 0 0 0 . 0 . 0 0 . 0 0 0 0 0 0 0 0 0 0 . . 0 . 0 0 . 0 . . 0 0 0 1 0 0 0 0 0 0 . . 0 0 . 0 . . . 0 0 0 END</lang>
- Output:
25 14 27
36 24 15
31 26 13 28 23 6 17
35 12 29 16 22
30 32 7 18 5
1 34 11 8 19 4 21
2 33 9
10 3 20
84 tries
Racket
This solution uses the module "hidato-family-solver.rkt" from Solve a Numbrix puzzle#Racket. The difference between the two is essentially the neighbourhood function.
It solves the tasked problem, as well as the "extra credit" from #Ada.
<lang racket>#lang racket (require "hidato-family-solver.rkt")
(define knights-neighbour-offsets
'((+1 +2) (-1 +2) (+1 -2) (-1 -2) (+2 +1) (-2 +1) (+2 -1) (-2 -1)))
(define solve-a-knights-tour (solve-hidato-family knights-neighbour-offsets))
(displayln
(puzzle->string
(solve-a-knights-tour
#(#(_ 0 0 0 _ _ _ _)
#(_ 0 _ 0 0 _ _ _)
#(_ 0 0 0 0 0 0 0)
#(0 0 0 _ _ 0 _ 0)
#(0 _ 0 _ _ 0 0 0)
#(1 0 0 0 0 0 0 _)
#(_ _ 0 0 _ 0 _ _)
#(_ _ _ 0 0 0 _ _)))))
(newline)
(displayln
(puzzle->string
(solve-a-knights-tour
#(#(- - - - - 1 - 0 - - - - -)
#(- - - - - 0 - 0 - - - - -)
#(- - - - 0 0 0 0 0 - - - -)
#(- - - - - 0 0 0 - - - - -)
#(- - 0 - - 0 - 0 - - 0 - -)
#(0 0 0 0 0 - - - 0 0 0 0 0)
#(- - 0 0 - - - - - 0 0 - -)
#(0 0 0 0 0 - - - 0 0 0 0 0)
#(- - 0 - - 0 - 0 - - 0 - -)
#(- - - - - 0 0 0 - - - - -)
#(- - - - 0 0 0 0 0 - - - -)
#(- - - - - 0 - 0 - - - - -)
#(- - - - - 0 - 0 - - - - -)))))</lang>
- Output:
_ 13 30 23 _ _ _ _ _ 24 _ 14 31 _ _ _ _ 29 12 25 22 15 32 7 11 26 21 _ _ 6 _ 16 28 _ 10 _ _ 33 8 5 1 20 27 34 9 4 17 _ _ _ 2 19 _ 35 _ _ _ _ _ 36 3 18 _ _ _ _ _ _ _ 1 _ 51 _ _ _ _ _ _ _ _ _ _ 50 _ 2 _ _ _ _ _ _ _ _ _ 56 3 52 49 54 _ _ _ _ _ _ _ _ _ 48 55 4 _ _ _ _ _ _ _ 46 _ _ 5 _ 53 _ _ 24 _ _ 45 8 11 6 47 _ _ _ 23 30 19 28 21 _ _ 44 9 _ _ _ _ _ 25 22 _ _ 43 10 7 12 41 _ _ _ 31 18 29 20 27 _ _ 42 _ _ 13 _ 17 _ _ 26 _ _ _ _ _ _ _ 40 37 32 _ _ _ _ _ _ _ _ _ 36 33 14 39 16 _ _ _ _ _ _ _ _ _ 38 _ 34 _ _ _ _ _ _ _ _ _ _ 35 _ 15 _ _ _ _ _
REXX
This REXX program is essentially a modified knight's tour REXX program with support to place pennies on the chessboard.
Also supported is the specification of the size of the chessboard and the placement of the knight (initial position).
<lang rexx>/*REXX pgm solves the holy knight's tour problem for a NxN chessboard.*/
blank=pos('//',space(arg(1),0))\==0 /*see if pennies are to be shown.*/
parse arg ops '/' cent /*obtain the options and pennies.*/
parse var ops N sRank sFile . /*boardsize, starting pos, pennys*/
if N== | N==',' then N=8 /*Boardsize specified? Default. */
if sRank== then sRank=N /*starting rank given? Default. */
if sFile== then sFile=1 /* " file " " */
NN=N**2; NxN='a ' N"x"N ' chessboard' /* [↓] r=Rank, f=File.*/
@.=; do r=1 for N; do f=1 for N; @.r.f=' '; end /*f*/; end /*r*/
/*[↑] blank the NxN chessboard.*/
cent=space(translate(cent,,',')) /*allow use of comma (,) for sep.*/ cents=0 /*number of pennies on chessboard*/
do while cent\= /* [↓] possibly place pennies. */
parse var cent cr cf x '/' cent /*extract where to place pennies.*/
if x= then x=1 /*if # not specified, use 1 penny*/
if cr= then iterate /*support the "blanking" option. */
do cf=cf for x /*now, place X pennies on board*/
@.cr.cf='¢' /*mark board position with penny.*/
end /*cf*/ /* [↑] places X pennies on board*/
end /*while cent¬= */ /* [↑] allows of placing X ¢s.*/
/* [↓] traipse through the board*/
do r=1 for N; do f=1 for N; cents=cents+(@.r.f=='¢'); end; end
/* [↑] count number of pennies. */
if cents\==0 then say cents 'pennies placed on chessboard.' target=NN-cents /*use this as the number of moves*/ Kr = '2 1 -1 -2 -2 -1 1 2' /*legal "rank" move for a knight.*/ Kf = '1 2 2 1 -1 -2 -2 -1' /* " "file" " " " " */
do i=1 for words(Kr) /*legal knight moves*/
Kr.i = word(Kr,i); Kf.i = word(Kf,i)
end /*i*/ /*for fast indexing.*/
!=left(, 9*(n<18)) /*used for indentation of board. */ if @.sRank.sFile==' ' then @.sRank.sFile=1 /*knight's starting pos*/ if @.sRank.sFile\==1 then do sRank=1 for N /*find a starting rank.*/
do sFile=1 for N /* " " " file.*/
if @.sRank.sFile==' ' then do /*got a spot*/
@.sRank.sFile=1
leave sRank
end
end /*sRank*/
end /*sFile*/
if \move(2,sRank,sFile) & ,
\(N==1) then say "No holy knight's tour solution for" NxN'.'
else say "A solution for the holy knight's tour on" NxN':'
_=substr(copies("┼───",N),2); say; say ! translate('┌'_"┐", '┬', "┼")
do r=N for N by -1; if r\==N then say ! '├'_"┤"; L=@.
do f=1 for N; L=L'│'centre(@.r.f,3) /*preserve squareness.*/
end /*f*/
if blank then L=translate(L,,'¢') /*blank out the pennies ? */
say ! L'│' /*show a rank of the chessboard.*/
end /*r*/ /*80 cols can view 19x19 chessbrd*/
say ! translate('└'_"┘", '┴', "┼") /*show the last rank of the board*/ exit /*stick a fork in it, we're done.*/ /*──────────────────────────────────MOVE subroutine─────────────────────*/ move: procedure expose @. Kr. Kf. N target; parse arg #,rank,file; b=' '
do t=1 for 8; nr=rank+Kr.t; nf=file+Kf.t
if @.nr.nf==b then do; @.nr.nf=# /*Kn move.*/
if #==target then return 1 /*last mv?*/
if move(#+1,nr,nf) then return 1
@.nr.nf=b /*undo the above move. */
end /*try different move. */
end /*t*/
return 0 /*the tour not possible.*/</lang>
output when the following is used for input:
, 3 1 /1,1 3 /1,7 2 /2,1 2 /2,5 /2,8 /3,8 /4,2 /4,4 2 /5,4 2 /5,6 /6,1 /7,1 2 /7,4 /7,7 1 /8,1 2 /8,6 3
26 pennies placed on chessboard.
A solution for the knight's tour on a 8x8 chessboard:
┌───┬───┬───┬───┬───┬───┬───┬───┐
│ ¢ │ ¢ │26 │35 │ 4 │ ¢ │ ¢ │ ¢ │
├───┼───┼───┼───┼───┼───┼───┼───┤
│ ¢ │ ¢ │ 3 │ ¢ │25 │16 │ ¢ │ 6 │
├───┼───┼───┼───┼───┼───┼───┼───┤
│ ¢ │27 │36 │17 │34 │ 5 │24 │15 │
├───┼───┼───┼───┼───┼───┼───┼───┤
│37 │ 2 │33 │ ¢ │ ¢ │ ¢ │ 7 │22 │
├───┼───┼───┼───┼───┼───┼───┼───┤
│28 │ ¢ │18 │ ¢ │ ¢ │23 │14 │ 9 │
├───┼───┼───┼───┼───┼───┼───┼───┤
│ 1 │38 │29 │32 │13 │ 8 │21 │ ¢ │
├───┼───┼───┼───┼───┼───┼───┼───┤
│ ¢ │ ¢ │12 │19 │ ¢ │31 │10 │ ¢ │
├───┼───┼───┼───┼───┼───┼───┼───┤
│ ¢ │ ¢ │ ¢ │30 │11 │20 │ ¢ │ ¢ │
└───┴───┴───┴───┴───┴───┴───┴───┘
output when the following is used for input:
, 3 1 /1,1 3 /1,7 2 /2,1 2 /2,5 /2,8 /3,8 /4,2 /4,4 2 /5,4 2 /5,6 /6,1 /7,1 2 /7,4 /7,7 1 /8,1 2 /8,6 3 //
26 pennies placed on chessboard.
A solution for the knight's tour on a 8x8 chessboard:
┌───┬───┬───┬───┬───┬───┬───┬───┐
│ │ │26 │35 │ 4 │ │ │ │
├───┼───┼───┼───┼───┼───┼───┼───┤
│ │ │ 3 │ │25 │16 │ │ 6 │
├───┼───┼───┼───┼───┼───┼───┼───┤
│ │27 │36 │17 │34 │ 5 │24 │15 │
├───┼───┼───┼───┼───┼───┼───┼───┤
│37 │ 2 │33 │ │ │ │ 7 │22 │
├───┼───┼───┼───┼───┼───┼───┼───┤
│28 │ │18 │ │ │23 │14 │ 9 │
├───┼───┼───┼───┼───┼───┼───┼───┤
│ 1 │38 │29 │32 │13 │ 8 │21 │ │
├───┼───┼───┼───┼───┼───┼───┼───┤
│ │ │12 │19 │ │31 │10 │ │
├───┼───┼───┼───┼───┼───┼───┼───┤
│ │ │ │30 │11 │20 │ │ │
└───┴───┴───┴───┴───┴───┴───┴───┘
Ruby
This solution uses HLPsolver from here <lang ruby>require 'HLPsolver'
ADJACENT = [[-1,-2],[-2,-1],[-2,1],[-1,2],[1,2],[2,1],[2,-1],[1,-2]]
boardy = <<EOS . . 0 0 0 . . 0 . 0 0 . 0 0 0 0 0 0 0 0 0 0 . . 0 . 0 0 . 0 . . 0 0 0 1 0 0 0 0 0 0 . . 0 0 . 0 . . . 0 0 0 EOS t0 = Time.now HLPsolver.new(boardy).solve puts " #{Time.now - t0} sec"</lang>
Which produces:
Problem:
0 0 0
0 0 0
0 0 0 0 0 0 0
0 0 0 0 0
0 0 0 0 0
1 0 0 0 0 0 0
0 0 0
0 0 0
Solution:
8 33 14
13 7 32
9 34 31 22 15 6 29
35 12 21 30 16
10 36 23 28 5
1 20 11 24 27 4 17
2 19 25
26 3 18
0.005 sec
Tcl
<lang tcl>package require Tcl 8.6
oo::class create HKTSolver {
variable grid start limit
constructor {puzzle} {
set grid $puzzle for {set y 0} {$y < [llength $grid]} {incr y} { for {set x 0} {$x < [llength [lindex $grid $y]]} {incr x} { if {[set cell [lindex $grid $y $x]] == 1} { set start [list $y $x] } incr limit [expr {$cell>=0}] } } if {![info exist start]} { return -code error "no starting position found" }
}
method moves {} {
return { -1 -2 1 -2 -2 -1 2 -1 -2 1 2 1 -1 2 1 2 }
}
method Moves {g r c} {
set valid {} foreach {dr dc} [my moves] { set R [expr {$r + $dr}] set C [expr {$c + $dc}] if {[lindex $g $R $C] == 0} { lappend valid $R $C } } return $valid
}
method Solve {g r c v} {
lset g $r $c [incr v] if {$v >= $limit} {return $g} foreach {r c} [my Moves $g $r $c] { return [my Solve $g $r $c $v] } return -code continue
}
method solve {} {
while {[incr i]==1} { set grid [my Solve $grid {*}$start 0] return } return -code error "solution not possible"
}
method solution {} {return $grid}
}
proc parsePuzzle {str} {
foreach line [split $str "\n"] {
if {[string trim $line] eq ""} continue lappend rows [lmap {- c} [regexp -all -inline {(.)\s?} $line] { string map {" " -1} $c }]
}
set len [tcl::mathfunc::max {*}[lmap r $rows {llength $r}]]
for {set i 0} {$i < [llength $rows]} {incr i} {
while {[llength [lindex $rows $i]] < $len} { lset rows $i end+1 -1 }
} return $rows
} proc showPuzzle {grid name} {
foreach row $grid {foreach cell $row {incr c [expr {$cell>=0}]}}
set len [string length $c]
set u [string repeat "_" $len]
puts "$name with $c cells"
foreach row $grid {
puts [format " %s" [join [lmap c $row { format "%*s" $len [if {$c==-1} list elseif {$c==0} {set u} {set c}] }]]]
}
}
set puzzle [parsePuzzle {
0 0 0 0 0 0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0
0 0 0
0 0 0
}] showPuzzle $puzzle "Input" HKTSolver create hkt $puzzle hkt solve showPuzzle [hkt solution] "Output"</lang>
- Output:
Input with 36 cells
__ __ __
__ __ __
__ __ __ __ __ __ __
__ __ __ __ __
__ __ __ __ __
1 __ __ __ __ __ __
__ __ __
__ __ __
Output with 36 cells
13 6 15
8 12 31
5 14 7 16 27 32 29
9 2 11 30 26
4 22 17 28 33
1 10 3 18 21 34 25
36 23 19
20 35 24