Personal tools

The Knights Tour

From HaskellWiki

(Difference between revisions)
Jump to: navigation, search
(Improved ContT r (ST s) code)
Line 75: Line 75:
   
 
An efficient version (some 10x faster than the example Python solution) 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.
   
 
<haskell>
 
<haskell>
import Control.Applicative ((<$>))
 
 
import Control.Monad.Cont
 
import Control.Monad.Cont
 
import Control.Monad.ST
 
import Control.Monad.ST
Line 85: Line 86:
 
import Data.Ord
 
import Data.Ord
 
import Data.Ix
 
import Data.Ix
import Data.Map (Map, lookup, singleton, insert)
 
   
 
import System.Environment
 
import System.Environment
Line 91: Line 91:
 
type Square = (Int, Int)
 
type Square = (Int, Int)
 
type Board s = STUArray s (Int,Int) Int
 
type Board s = STUArray s (Int,Int) Int
 
 
type ChessM r s = ContT r (ST s)
 
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 :: Int -> Board s -> Square -> ChessM r s [Square]
successors n b s = sortWith (fmap length . succs) =<< succs s
+
successors n b = sortWith (fmap length . succs) <=< succs
 
where
 
where
sortWith f l = map fst <$> sortBy (comparing snd) <$> mapM (\x -> (,) x <$> f x) l
+
sortWith f l = map fst `fmap` sortBy (comparing snd)
succs (i,j) = filterM (empty b) [ (i', j') | (dx,dy) <- [(1,2),(2,1)]
+
`fmap` mapM (\x -> (,) x `fmap` f x) l
, i' <- [i+dx,i-dx] , j' <- [j+dy, j-dy]
+
succs (i,j) = filterM (empty b)
, inRange ((1,1),(n,n)) (i',j') ]
+
[ (i', j') | (dx,dy) <- [(1,2),(2,1)]
+
, i' <- [i+dx,i-dx] , j' <- [j+dy, j-dy]
stop :: Square -> Board s -> ChessM r s Int
+
, inRange ((1,1),(n,n)) (i',j') ]
stop s b = lift $ readArray b s
 
   
 
empty :: Board s -> Square -> ChessM r s Bool
 
empty :: Board s -> Square -> ChessM r s Bool
Line 110: Line 110:
 
mark s k b = lift $ writeArray b s k
 
mark s k b = lift $ writeArray b s k
   
tour :: Int -> Int -> (Board s -> ChessM r s ()) -> Square -> Board s -> ChessM r s ()
+
tour :: Int -> Int -> ChessK r s -> Square -> Board s -> ChessM r s ()
tour n k exit s b | k > n*n = exit b
+
tour n k exit s b | k > n*n = showBoard n b >>= exit
| otherwise = do ss <- successors n b s
+
| otherwise = successors n b s >>=
try ss
+
mapM_ (\x -> do mark x k b
where
+
tour n (k+1) exit x b
try [] = return ()
+
-- failed
try (x:xs) = do mark x k b
+
mark x 0 b)
tour n (k+1) exit x b
 
-- failed
 
mark x 0 b
 
try xs
 
   
 
showBoard :: Int -> Board s -> ChessM r s String
 
showBoard :: Int -> Board s -> ChessM r s String
showBoard n b = fmap (unlines . map unwords) . sequence . map sequence
+
showBoard n b = fmap unlines . forM [1..n] $ \i ->
$ [ [ fmt `fmap` stop (i,j) b | i <- [1..n] ] | j <- [1..n] ]
+
fmap unwords . forM [1..n] $ \j ->
  +
pad `fmap` lift (readArray b (i,j))
 
where
 
where
fmt i | i < 10 = ' ': show i
+
k = floor . log . fromIntegral $ n*n
| otherwise = show i
+
pad i = let s = show i in replicate (k-length s) ' ' ++ s
   
 
main = do (n:_) <- map read `fmap` getArgs
 
main = do (n:_) <- map read `fmap` getArgs
Line 129: Line 129:
 
(do b <- lift $ newArray ((1,1),(n,n)) 0
 
(do b <- lift $ newArray ((1,1),(n,n)) 0
 
mark (1,1) 1 b
 
mark (1,1) 1 b
callCC $ \exit -> tour n 2 exit (1,1) b >> fail "No solution!"
+
callCC $ \k -> tour n 2 k (1,1) b >> fail "No solution!")
showBoard n b)
 
 
putStrLn s
 
putStrLn s
  +
 
</haskell>
 
</haskell>
   

Revision as of 02:18, 1 December 2008


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.

Contents


1 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>"


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 Control.Monad.ST
 
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 ->
                   pad `fmap` lift (readArray b (i,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

3 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