# Difference between revisions of "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.

## 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>"
```

## Using Continuations

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

```import Control.Applicative ((<\$>))

import Data.Array.ST
import Data.List
import Data.Ord
import Data.Ix
import Data.Map (Map, lookup, singleton, insert)

import System.Environment

type Square  = (Int, Int)
type Board s = STUArray s (Int,Int) Int

type ChessM r s = ContT r (ST s)

successors :: Int -> Board s -> Square -> ChessM r s [Square]
successors n b s = sortWith (fmap length . succs) =<< succs s
where
sortWith f l = map fst <\$> sortBy (comparing snd) <\$> mapM (\x -> (,) x <\$> 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') ]

stop :: Square -> Board s -> ChessM r s Int
stop s b = lift \$ readArray b s

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 -> (Board s -> ChessM r s ()) -> Square -> Board s -> ChessM r s ()
tour n k exit s b | k > n*n   = exit b
| otherwise = do ss <- successors n b s
try ss
where
try []     = return ()
try (x:xs) = do mark x k b
tour n (k+1) exit x b
-- failed
mark x 0 b
try xs

showBoard :: Int -> Board s -> ChessM r s String
showBoard n b = fmap (unlines . map unwords) . sequence . map sequence
\$ [ [ fmt `fmap` stop (i,j) b | i <- [1..n] ] | j <- [1..n] ]
where
fmt i | i < 10    = ' ': show i
| otherwise = show i

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 \$ \exit -> tour n 2 exit (1,1) b >> fail "No solution!"
showBoard n b)
putStrLn s
```

A very short implementation using the LogicT monad

19 lines of code. 8 imports.

```import Control.Monad.Logic

import Prelude hiding (lookup)
import Data.List hiding (lookup, insert)
import Data.Maybe
import Data.Ord
import Data.Ix
import Data.Map (Map, lookup, singleton, insert)
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]
, empty (i',j') b, inRange ((1,1),(n,n)) (i',j') ]

empty s = isNothing . lookup s

choose = msum . map return

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

showBoard n b = unlines . map unwords
\$ [ [ fmt . fromJust \$ lookup (i,j) b | i <- [1..n] ] | j <- [1..n] ]
where
fmt i | i < 10    = ' ': show i
| otherwise = show i

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