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

[oleg at okmij.org]

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 2-dimensional map as a nested 1-dimensional 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,i-dx] , j' <- [j+dy, j-dy]
		                , 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 (k-length s) ' ' ++ s

main = do (n:_) <- map read `fmap` getArgs
          let (b:_) = runM Nothing . tour n 2 (1,1) $ initmap n
          putStrLn $ showBoard n b