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.

Here are some Haskell implementations.

One

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

import Control.Arrow
import Control.Monad
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 Control.Monad.Cont
import Control.Monad.ST

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

LogicT monad

A very short implementation using the LogicT monad

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

type Square = (Int, Int)
type Board  = Map Square Int

successors :: Int -> Board -> Square -> [Square]
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') ]

stop :: Square -> Board -> Maybe Int
stop = lookup

empty :: Square -> Board -> Bool
empty s = isNothing . lookup s

mark :: Square -> Int -> Board -> Board
mark = insert

choose :: MonadPlus m => [a] -> m a
choose = msum . map return

tour :: Int -> Int -> Square -> Board -> Logic Board
tour n k s b | k > n*n   = return b
             | otherwise = do next <- choose $ successors n b s
                              tour n (k+1) next (mark next k b)

showBoard :: Int -> Board -> String
showBoard n b = unlines . map unwords
  $ [ [ fmt . fromJust $ 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
          let b = observe . tour n 2 (1,1) $ singleton (1,1) 1
          putStrLn $ showBoard n b

</haskell>