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

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