The Knights Tour
From HaskellWiki
DonStewart (Talk  contribs) (the knights tour) 
m (link to FBackTrack module) 

(7 intermediate revisions by 2 users not shown)  
Line 1:  Line 1:  
[[Category:Tutorials]] 
[[Category:Tutorials]] 

+  
[http://en.wikipedia.org/wiki/Knight's_tour The Knight's Tour] is a 
[http://en.wikipedia.org/wiki/Knight's_tour The Knight's Tour] is a 

Line 8:  Line 9:  
Here are some Haskell implementations. 
Here are some Haskell implementations. 

−  == One == 
+  __TOC__ 
+  
+  == First Solution == 

<haskell> 
<haskell> 

Line 72:  Line 73:  
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 82:  Line 84:  
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 88:  Line 89:  
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,idx] , j' < [j+dy, jdy] 
+  succs (i,j) = filterM (empty b) 
−  , inRange ((1,1),(n,n)) (i',j') ] 
+  [ (i', j')  (dx,dy) < [(1,2),(2,1)] 
−  +  , i' < [i+dx,idx] , j' < [j+dy, jdy] 

−  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 107:  Line 108:  
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 = ceiling . logBase 10 . fromIntegral $ n*n + 1 
−   otherwise = show i 
+  pad i = let s = show i in replicate (klength s) ' ' ++ s 
main = do (n:_) < map read `fmap` getArgs 
main = do (n:_) < map read `fmap` getArgs 

Line 126:  Line 127:  
(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> 

Line 133:  Line 135:  
A very short implementation using [http://hackage.haskell.org/cgibin/hackagescripts/package/logict the LogicT monad] 
A very short implementation using [http://hackage.haskell.org/cgibin/hackagescripts/package/logict the LogicT monad] 

+  
+  16 lines of code. 7 imports. 

<haskell> 
<haskell> 

import Control.Monad.Logic 
import Control.Monad.Logic 

−  +  
−  import Prelude hiding (lookup) 
+  import Data.List 
−  import Data.List hiding (lookup, insert) 

import Data.Maybe 
import Data.Maybe 

import Data.Ord 
import Data.Ord 

import Data.Ix 
import Data.Ix 

−  import Data.Map (Map, lookup, singleton, insert) 
+  import qualified Data.Map as Map 
−  
import System.Environment 
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,idx] , j' < [j+dy, jdy] 

+  , isNothing (Map.lookup (i',j') b) 

+  , inRange ((1,1),(n,n)) (i',j') ] 

+  
+  tour n k s b  k > n*n = return b 

+   otherwise = do next < msum . map return $ successors n b s 

+  tour n (k+1) next $ Map.insert next k b 

+  
+  showBoard n b = unlines . map (\i > unwords . map (\j > 

+  pad . fromJust $ Map.lookup (i,j) b) $ [1..n]) $ [1..n] 

+  where k = ceiling . logBase 10 . fromIntegral $ n*n + 1 

+  pad i = let s = show i in replicate (klength s) ' ' ++ s 

+  
+  main = do (n:_) < map read `fmap` getArgs 

+  let b = observe . tour n 2 (1,1) $ Map.singleton (1,1) 1 

+  putStrLn $ showBoard n b 

+  </haskell> 

−  type Square = (Int, Int) 
+  == Oleg Kiselyov's Solution == 
−  type Board = Map Square Int 

−  successors :: Int > Board > Square > [Square] 
+  Oleg [http://www.haskell.org/pipermail/haskellcafe/2008December/051277.html provided a solution] on haskellcafe: 
−  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,idx] , j' < [j+dy, jdy] 

−  , empty (i',j') b, inRange ((1,1),(n,n)) (i',j') ] 

−  stop :: Square > Board > Maybe Int 
+  <blockquote> 
−  stop = lookup 
+  It seems the following pure functional (except for the final printout) 
+  version of the search has almost the same performance as the Dan 

+  Doel's latest version with the unboxed arrays and callCC. For the board of 

+  size 40, Dan Doel's version takes 0.047s on my computer; the version 

+  below takes 0.048s. For smaller boards, the difference is 

+  imperceptible. Interestingly, the file sizes of the compiled 

+  executables (ghc O2, ghc 6.8.2) are similar too: 606093 bytes for Dan 

+  Doel's version, and 605938 bytes for the version below. 

−  empty :: Square > Board > Bool 
+  The version below is essentially Dan Doel's earlier version. Since 
−  empty s = isNothing . lookup s 
+  the problem involves only pure search (rather than committed choice), 
+  I took the liberty of substituting [http://okmij.org/ftp/Haskell/FBackTrack.hs FBackTrack] (efficient MonadPlus) 

+  for LogicT. FBackTrack can too be made the instance of LogicT; there 

+  has not been any demand for that though. 

+  </blockquote> 

−  mark :: Square > Int > Board > Board 
+  <haskell> 
−  mark = insert 
+  import Data.List 
+  import Data.Ord 

+  import qualified Data.IntMap as Map 

+  import System.Environment 

+  import FBackTrack 

+  import Control.Monad 

−  choose :: MonadPlus m => [a] > m a 
+   Emulate the 2dimensional map as a nested 1dimensional map 
−  choose = msum . map return 
+  initmap n = Map.fromList $ (1,Map.singleton 1 1):[ (k,Map.empty)  k < [2..n] ] 
+  notMember (i,j) m = Map.notMember j $ Map.findWithDefault undefined i m 

+  insrt (i,j) v m = Map.update (Just . Map.insert j v) i m 

+  lkup (i,j) m = Map.findWithDefault undefined j $ 

+  Map.findWithDefault undefined i m 

+  
+  
+  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,idx] , j' < [j+dy, jdy] 

+  , i' >= 1, j' >= 1, i' <= n, j' <= n 

+  , notMember (i',j') b ] 

−  tour :: Int > Int > Square > Board > Logic Board 

tour n k s b  k > n*n = return b 
tour n k s b  k > n*n = return b 

−   otherwise = do next < choose $ successors n b s 
+   otherwise = do next < foldl1 mplus.map return $ successors n b s 
−  tour n (k+1) next (mark next k b) 
+  tour n (k+1) next $ insrt next k b 
−  showBoard :: Int > Board > String 
+  
−  showBoard n b = unlines . map unwords 
+  showBoard n b = unlines . map (\i > unwords . map (\j > 
−  $ [ [ fmt . fromJust $ stop (i,j) b  i < [1..n] ]  j < [1..n] ] 
+  pad $ lkup (i,j) b) $ [1..n]) $ [1..n] 
−  where 
+  where k = length . show $ n*n + 1 
−  fmt i  i < 10 = ' ': show i 
+  pad i = let s = show i in replicate (klength s) ' ' ++ s 
−   otherwise = show i 

main = do (n:_) < map read `fmap` getArgs 
main = do (n:_) < map read `fmap` getArgs 

−  let b = observe . tour n 2 (1,1) $ singleton (1,1) 1 
+  let (b:_) = runM Nothing . tour n 2 (1,1) $ initmap n 
putStrLn $ showBoard n b 
putStrLn $ showBoard n b 

−  </haskell> 

</haskell> 
</haskell> 
Latest revision as of 10:10, 2 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 
[edit] 1 First Solution
  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..size1] 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..size1]] 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>"
[edit] 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,idx] , j' < [j+dy, jdy] , 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 = ceiling . logBase 10 . fromIntegral $ n*n + 1 pad i = let s = show i in replicate (klength 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
[edit] 3 LogicT monad
A very short implementation using the LogicT monad
16 lines of code. 7 imports.
import Control.Monad.Logic import Data.List import Data.Maybe import Data.Ord import Data.Ix import qualified Data.Map as Map 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,idx] , j' < [j+dy, jdy] , isNothing (Map.lookup (i',j') b) , inRange ((1,1),(n,n)) (i',j') ] tour n k s b  k > n*n = return b  otherwise = do next < msum . map return $ successors n b s tour n (k+1) next $ Map.insert next k b showBoard n b = unlines . map (\i > unwords . map (\j > pad . fromJust $ Map.lookup (i,j) b) $ [1..n]) $ [1..n] where k = ceiling . logBase 10 . fromIntegral $ n*n + 1 pad i = let s = show i in replicate (klength s) ' ' ++ s main = do (n:_) < map read `fmap` getArgs let b = observe . tour n 2 (1,1) $ Map.singleton (1,1) 1 putStrLn $ showBoard n b
[edit] 4 Oleg Kiselyov's Solution
Oleg provided a solution on haskellcafe:
It seems the following pure functional (except for the final printout) version of the search has almost the same performance as the Dan Doel's latest version with the unboxed arrays and callCC. For the board of size 40, Dan Doel's version takes 0.047s on my computer; the version below takes 0.048s. For smaller boards, the difference is imperceptible. Interestingly, the file sizes of the compiled executables (ghc O2, ghc 6.8.2) are similar too: 606093 bytes for Dan Doel's version, and 605938 bytes for the version below. The version below is essentially Dan Doel's earlier version. Since the problem involves only pure search (rather than committed choice), I took the liberty of substituting FBackTrack (efficient MonadPlus) for LogicT. FBackTrack can too be made the instance of LogicT; there has not been any demand for that though.
import Data.List import Data.Ord import qualified Data.IntMap as Map import System.Environment import FBackTrack import Control.Monad  Emulate the 2dimensional map as a nested 1dimensional map initmap n = Map.fromList $ (1,Map.singleton 1 1):[ (k,Map.empty)  k < [2..n] ] notMember (i,j) m = Map.notMember j $ Map.findWithDefault undefined i m insrt (i,j) v m = Map.update (Just . Map.insert j v) i m lkup (i,j) m = Map.findWithDefault undefined j $ Map.findWithDefault undefined i m 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,idx] , j' < [j+dy, jdy] , i' >= 1, j' >= 1, i' <= n, j' <= n , notMember (i',j') b ] tour n k s b  k > n*n = return b  otherwise = do next < foldl1 mplus.map return $ successors n b s tour n (k+1) next $ insrt next k b showBoard n b = unlines . map (\i > unwords . map (\j > pad $ lkup (i,j) b) $ [1..n]) $ [1..n] where k = length . show $ n*n + 1 pad i = let s = show i in replicate (klength s) ' ' ++ s main = do (n:_) < map read `fmap` getArgs let (b:_) = runM Nothing . tour n 2 (1,1) $ initmap n putStrLn $ showBoard n b