[Haskell-cafe] Performance of Knight's Tour

[Artyom Kazak]

Hi! I'm learning Haskell, and now I'm trying to make framework for
solving searching problems, such as Knight's Tour. For small boards it
answers instantly. For 7x8 board - 23 seconds. For 8x8 board - more
than 30 minutes (it hasn't finished yet). Where is the root of the
evil?

--program
module Main where

import Data.List
import Data.Array.Unboxed
import qualified Data.Array.IArray as IArr
import Data.Ix

data SResult = Good | GoodProcess | Process | Bad

data SDPSearch a p r = SDPSearch (a -> p -> [a])           --expand
                                 (p -> p)                  --update
                                 (a -> p -> SResult)       --sort
                                 ([a] -> r)                --result

runSDPSearch :: SDPSearch a c b -> [a] -> c -> b
runSDPSearch (SDPSearch e u s r) list p = r (rec list params)
  where
    params = iterate u p
    rec [] _             = []
    rec (l:lp) pr@(n:np) = case s l n of
                             Good        -> l : rec lp pr
                             GoodProcess -> l : (rec (e l n) np) ++ (rec lp pr)
                             Process     -> (rec (e l n) np) ++ (rec lp pr)
                             Bad         -> rec lp pr

main = do
  (a, b) <- (break (== ' ')) `fmap` getLine
  print (knightTour (read a) (read b))

knightTour :: Int -> Int -> UArray (Int, Int) Int
knightTour a b = runSDPSearch (SDPSearch e u s r) [((1, 1), sArray)] 2
  where
    size = a * b
    range = ((1, 1), (a, b))
    sArray = listArray range (1 : (replicate (size - 1) 0))
    allTurns :: Array (Int, Int) [(Int, Int)]
    allTurns = IArr.listArray range [turns x y | x <- [1..a], y <- [1..b]]
      where
        shifts = [(1, 2),(1, -2),(2, 1),(2, -1),(-1, 2),(-1, -2),(-2,
1),(-2, -1)]
        turns x y = [(x+i, y+j) | (i, j) <- shifts, inRange range (x+i, y+j)]
    e ((x, y), arr) p = [(t, arr // [(t, p)]) | t <- changes]
      where
        changes = [t | t <- allTurns ! (x, y), arr ! t == 0]
    s el p | p == size = Good
           | otherwise = Process
    u = (+ 1)
    r l | not (null l) = snd (head l)
        | otherwise    = error "No solutions!"