[Haskell-cafe] The Knight's Tour: solutions please

[Dan Doel]

Here's a clean-up of my code (it even fits within the line-length limit of my 
mail client :)). Note that it's pretty much exactly the Python algorithm. When 
the Python program finds a solution, it prints the board and exits. Since 
that's evil IO type stuff, we noble functional folk instead set up an exit 
continuation using callCC, and call it when we find a solution. :)

I haven't bothered testing it against the Python version, but the backtracking 
solution I wrote with the Logic monad (and Data.Map) took around 50% more time 
than this.

-- Dan

---- snip ----

module Main where

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, rollback
                                                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