# The Knights Tour

### From HaskellWiki

DonStewart (Talk | contribs) |
(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.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 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 | + | successors n b = sortWith (fmap length . succs) <=< succs |

where | where | ||

− | sortWith f l = map fst | + | 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 |

− | + | 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 :: Board s -> Square -> ChessM r s Bool | ||

Line 111: | Line 110: | ||

mark s k b = lift $ writeArray b s k | mark s k b = lift $ writeArray b s k | ||

− | tour :: Int -> Int -> | + | tour :: Int -> Int -> ChessK r s -> Square -> Board s -> ChessM r s () |

− | tour n k exit s b | k > n*n = | + | tour n k exit s b | k > n*n = showBoard n b >>= exit |

− | | otherwise = | + | | 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 :: Int -> Board s -> ChessM r s String | ||

− | showBoard n b = fmap | + | showBoard n b = fmap unlines . forM [1..n] $ \i -> |

− | + | fmap unwords . forM [1..n] $ \j -> | |

+ | pad `fmap` lift (readArray b (i,j)) | ||

where | 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 | main = do (n:_) <- map read `fmap` getArgs | ||

Line 134: | Line 130: | ||

(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 $ \ | + | callCC $ \k -> tour n 2 k (1,1) b >> fail "No solution!") |

− | + | ||

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