# The Knights Tour

The Knight's Tour is a mathematical problem involving a knight on a chessboard. The knight is placed on the empty board and, moving according to the rules of chess, must visit each square exactly once.

## 1 One

```--
-- Quick implementation by dmwit on #haskell
-- Faster, shorter, uses less memory than the Python version.
--

import Control.Arrow
import Data.List
import Data.Maybe
import Data.Ord
import System.Environment
import qualified Data.Map as M

sortOn f = map snd . sortBy (comparing fst) . map (f &&& id)

clip coord size = coord >= 0 && coord < size
valid size solution xy@(x, y) = and [clip x size, clip y size, isNothing (M.lookup xy solution)]
neighbors size solution xy = length . filter (valid size solution) \$ sequence moves xy

moves = do
f <- [(+), subtract]
g <- [(+), subtract]
(x, y) <- [(1, 2), (2, 1)]
[f x *** g y]

solve size solution n xy = do
guard (valid size solution xy)
let solution'   = M.insert xy n solution
sortedMoves = sortOn (neighbors size solution) (sequence moves xy)
if n == size * size
then [solution']
else sortedMoves >>= solve size solution' (n+1)

printBoard size solution = board [0..size-1] where
sqSize    = size * size
elemSize  = length (show sqSize)
separator = intercalate (replicate elemSize '-') (replicate (size + 1) "+")
pad n s   = replicate (elemSize - length s) ' ' ++ s
elem xy   = pad elemSize . show \$ solution M.! xy
line y    = concat  . intersperseWrap "|" \$ [elem (x, y) | x <- [0..size-1]]
board     = unlines . intersperseWrap separator . map line
intersperseWrap s ss = s : intersperse s ss ++ [s]

go size = case solve size M.empty 1 (0, 0) of
[]    -> "No solution found"
(s:_) -> printBoard size s

main = do
args <- getArgs
name <- getProgName
putStrLn \$ case map reads args of
[]             -> go 8
[[(size, "")]] -> go size
_              -> "Usage: " ++ name ++ " <size>"```

## 2 Using Continuations

An efficient version (some 10x faster than the example Python solution) using continuations.

This is about as direct a translation of the Python algorithm as you'll get without sticking the whole thing in IO. The Python version prints the board and exits immediately upon finding it, so it can roll back changes if that doesn't happen. Instead, this version sets up an exit continuation using callCC and calls that to immediately return the first solution found. The Logic version below takes around 50% more time.

```import Control.Monad.Cont

import Data.Array.ST
import Data.List
import Data.Ord
import Data.Ix

import System.Environment

type Square  = (Int, Int)
type Board s = STUArray s (Int,Int) Int
type ChessM r s = ContT r (ST s)
type ChessK r s = String -> ChessM r s ()

successors :: Int -> Board s -> Square -> ChessM r s [Square]
successors n b = sortWith (fmap length . succs) <=< succs
where
sortWith f l = map fst `fmap` sortBy (comparing snd)
`fmap` mapM (\x -> (,) x `fmap` f x) l
succs (i,j) = filterM (empty b)
[ (i', j') | (dx,dy) <- [(1,2),(2,1)]
, i' <- [i+dx,i-dx] , j' <- [j+dy, j-dy]
, inRange ((1,1),(n,n)) (i',j') ]

empty :: Board s -> Square -> ChessM r s Bool
empty b s = fmap (<1) . lift \$ readArray b s

mark :: Square -> Int -> Board s -> ChessM r s ()
mark s k b = lift \$ writeArray b s k

tour :: Int -> Int -> ChessK r s -> Square -> Board s -> ChessM r s ()
tour n k exit s b | k > n*n   = showBoard n b >>= exit
| otherwise = successors n b s >>=
mapM_ (\x -> do mark x k b
tour n (k+1) exit x b
-- failed
mark x 0 b)

showBoard :: Int -> Board s -> ChessM r s String
showBoard n b = fmap unlines . forM [1..n] \$ \i ->
fmap unwords . forM [1..n] \$ \j ->
where
k = floor . log . fromIntegral \$ n*n
pad i = let s = show i in replicate (k-length s) ' ' ++ s

main = do (n:_) <- map read `fmap` getArgs
s <- stToIO . flip runContT return \$
(do b <- lift \$ newArray ((1,1),(n,n)) 0
mark (1,1) 1 b
callCC \$ \k -> tour n 2 k (1,1) b >> fail "No solution!")
putStrLn s```

A very short implementation using the LogicT monad

16 lines of code. 7 imports.

```import Control.Monad.Logic

import Data.List
import Data.Maybe
import Data.Ord
import Data.Ix
import qualified Data.Map as Map
import System.Environment

successors n b = sortWith (length . succs) . succs
where sortWith f = map fst . sortBy (comparing snd) . map (\x -> (x, f x))
succs (i,j) = [ (i', j') | (dx,dy) <- [(1,2),(2,1)]
, i' <- [i+dx,i-dx] , j' <- [j+dy, j-dy]
, isNothing (Map.lookup (i',j') b)
, inRange ((1,1),(n,n)) (i',j') ]

tour n k s b | k > n*n   = return b
| otherwise = do next <- msum . map return \$ successors n b s
tour n (k+1) next \$ Map.insert next k b

showBoard n b = unlines . map (\i -> unwords . map (\j ->
pad . fromJust \$ Map.lookup (i,j) b) \$ [1..n]) \$ [1..n]
where k = ceiling . logBase 10 . fromIntegral \$ n*n
pad i = let s = show i in replicate (k-length s) ' ' ++ s

main = do (n:_) <- map read `fmap` getArgs
let b = observe . tour n 2 (1,1) \$ Map.singleton (1,1) 1
putStrLn \$ showBoard n b```