The Knights Tour
Revision as of 02:14, 1 December 2008 by DonStewart (talk | contribs)
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