Haskell Quiz/Amazing Mazes/Solution Burton

This code runs slowly (~40s to solve a 100x100 maze on my newish machine after compiling with -O2, slower than some of the Ruby efforts!), so I plan to rewrite it using arrays to see if that helps.

module Main
    where

import Random
import System
import System.IO
import System.IO.Unsafe
import Maybe
import List

{--
Algorithm is Dijkstra depth-first search 
The solver is augmented by picking neighbour which is closest to the goal
rather than a random one

*Main> doSol 10 10 Nothing
+---+---+---+---+---+---+---+---+---+---+
| x   x | x   x   x |       |           |
+---+   +   +---+   +   +---+   +   +   +
| x   x | x |   | x |           |   |   |
+   +---+   +   +   +---+---+---+   +---+
| x   x   x |   | x   x |       |       |
+---+---+---+   +---+   +   +   +---+   +
|               | x   x |   |       |   |
+   +   +---+   +   +---+   +---+   +   +
|   |   |       | x |       |   |   |   |
+---+   +   +---+   +---+   +   +   +   +
|       |   | x   x |       |   |   |   |
+   +---+---+   +---+   +---+   +   +   +
|   |       | x   x |       |   |   |   |
+   +   +   +---+   +---+   +   +   +   +
|       |   | x   x |       |           |
+---+---+   +   +---+   +---+---+---+---+
|           | x   x |                   |
+   +---+---+---+   +---+---+---+---+   +
|                 x   x   x   x   x   x |
+---+---+---+---+---+---+---+---+---+---+

--}

data Direction = N | E | S | W
               deriving (Show, Eq, Enum)
data Cell = GenCell [Direction] [Direction] -- Cell borders walls
          deriving Show
type Maze = [Cell]
type Neighbour = (Maybe Cell, Int, Direction) --(cell, position, direction in which it lies)
data CLIFlag = Help | Version | Mode | Input String | Output String | Start Int | End Int
               deriving Show
type Solution = (Maze, [Int], [Int]) --(m, path, backtracks)

borders, walls :: Cell -> [Direction]
borders (GenCell bs ws) = bs
walls (GenCell bs ws) = ws
smaze :: Solution -> Maze
smaze (m, s, b) = m 
spath :: Solution -> [Int]
spath (m, s, b) = s
sback :: Solution -> [Int]
sback (m, s, b) = b  
ncell :: Neighbour -> Maybe Cell
ncell (c, p, d) = c                 
npos :: Neighbour -> Int
npos (c, p, d) = p
ndir :: Neighbour -> Direction
ndir (c, p, d) = d 

--get a maze with all walls intact
genBlockedMaze :: Int -> Int -> Maze
genBlockedMaze w h = topRow ++ (genMaze' (h-2) []) ++ bottomRow
                     where genMaze' 0 m = m
                           genMaze' (h+1) m   = midRow ++ genMaze' h m
                           genCells 0 bs ws   = []
                           genCells x bs ws   = (GenCell bs ws) : (genCells (x-1) bs ws)
                           topRow      = (GenCell [W,N] [E,S]) : (genCells (w-2) [N] [E .. W]) ++ [(GenCell [N, E] [S,W])]
                           bottomRow   = (GenCell [W,S] [N, E]) : (genCells (w-2) [S] [N, E, W]) ++ [(GenCell [S, E] [N, W])]
                           midRow      = (GenCell [W] [N .. S]) : (genCells (w-2) [] [N .. W]) ++ [(GenCell [E] [N, S, W])]


getRandNum :: Int -> Int
getRandNum n = unsafePerformIO $ getStdRandom $ randomR (0,n)

getDir :: Int -> Direction
getDir n = if n < 4 
           then [N .. W]!!n 
           else error ("can't give a direction for " ++ (show n)) 

randElem :: [a] -> a
randElem xs = xs!!(getRandNum ((length xs)-1))

--get the dimensions of a maze
dims :: Maze -> (Int, Int)
dims m = (w, (h+1))
         where w = findW m 1
               h = findH m 1
               findW [] x     = -1
               findW (c:cs) x = if E `elem` (borders c) then x else findW cs (x+1)
               findH [] x     = -1
               findH (c:cs) x = if S `elem` (borders c) then x `div` w else findH cs (x+1)

--get the neighbours of a position in the maze 
neighbs :: Maze -> Int -> [Neighbour]
neighbs m i = filter (isJust . ncell) [neighb (-1) 0 W, neighb 1 0 E, neighb 0 (-1) N, neighb 0 1 S]
              where len = length m
                    (w,h) = dims m
                    neighb x y d | newPos >= len || newPos < 0 = (Nothing, -1, d) --past beginning or end
                                 | newX >= w || newX < 0       = (Nothing, -1, d) --last row
                                 | newY >= h || newY < 0       = (Nothing, -1, d) --last col
                                 | otherwise                   = (Just (m!!newPos), newPos, d)
                                 where newPos = i+x + (y*w)
                                       newX   = x + (i `mod` h)
                                       newY   = (i `div` w) + y
                                     
--generate a perfect maze given the dimensions
genMaze :: Int -> Int -> Maze
genMaze w h = genMaze' m [0] 0 1 
              where m = genBlockedMaze w h
                    t = length m
                    genMaze' m' stk cur vis | vis == t = m'
                                            | null newNeighbs = genMaze' m' (tail stk) (head $ tail stk) vis
                                            | otherwise = genMaze' m'' (neighbPos:stk) neighbPos (vis+1)
                                            where newNeighbs = filter (\x -> (npos x `notElem` stk) && allwalls (fromJust $ ncell x)) (neighbs m' cur)
                                                  neighb = randElem newNeighbs
                                                  neighbWall = opp curWall
                                                  neighbPos = npos neighb
                                                  Just neighbCell = ncell neighb
                                                  curWall = ndir neighb
                                                  m'' = splice (splice m' (newNeighb, neighbPos)) (newCur, cur)
                                                  newCur = GenCell (borders curcell) (delete curWall (walls curcell))
                                                  newNeighb = GenCell (borders neighbCell) (delete neighbWall $ walls neighbCell)
                                                  curcell = m'!!cur
                                                 

opp :: Direction -> Direction
opp N = S
opp E = W
opp S = N
opp W = E

allwalls :: Cell -> Bool
allwalls c = all (\d -> d `elem` walls c || d `elem` borders c) ds
           where ds = [N .. W]

splice :: Maze -> (Cell, Int) -> Maze
splice [] _ = []
splice m (c, 0) = c : (tail m)
splice m (c, i) = if i >= length m then error "cannot splice " else take i m ++ [c] ++ drop (i+1) m  

topBorder :: Int -> String
topBorder i = (topBorder' i "") ++ "+\n"
              where topBorder' 0 acc = acc
                    topBorder' (n+1) acc = topBorder' n ("+---" ++ acc)

asciiMaze :: Solution -> String
asciiMaze (m, s, b) = topBorder w ++ asciiRows m 0
    where (w,h) = dims m
          asciiRows [] c = "\n"
          asciiRows m c = asciiRow (take w m) [] 0 c s b ++ asciiRows (drop w m) (c+w)

asciiRow :: [Cell] -> [Cell] -> Int -> Int -> [Int] -> [Int] -> String
asciiRow [] acc i pos sol bk = ""
asciiRow [c] acc 0 pos sol bk = showCell c i pos sol bk ++ "|\n" ++ asciiRow (reverse (c:acc)) [] 1 (pos-length (c:acc)) sol bk
asciiRow [c] acc i pos sol bk = showCell c i pos sol bk ++ "+\n"
asciiRow (c:cs) acc 0 pos sol bk = showCell c i pos sol bk ++ asciiRow cs (c:acc) 0 (pos+1) sol bk
asciiRow (c:cs) acc i pos sol bk = showCell c i pos sol bk ++ asciiRow cs (c:acc) 1 (pos+1) sol bk

showCell :: Cell -> Int -> Int -> [Int] -> [Int] -> String
showCell c 0 pos sol bk | pos `elem` sol = showCellMS c
                        | pos `elem` bk  = showCellMB c
                        | otherwise      = showCellM c
showCell c _ _ _ _ = showCellB c

showCellB, showCellM, showCellMS, showCellMB :: Cell -> String
showCellB c | S `elem` borders c || S `elem` walls c = "+---"
            | otherwise                              = "+   "
showCellM c | W `elem` borders c || W `elem` walls c = "|   "
            | otherwise                              = "    "
showCellMS c | W `elem` borders c || W `elem` walls c = "| x "
             | otherwise                              = "  x "
showCellMB c | W `elem` borders c || W `elem` walls c = "| - "
             | otherwise                              = "  - "

printMaze :: Maze -> IO ()
printMaze m = putStr $ asciiMaze (m ,[], [])

solveMaze :: Maze -> Int -> Int -> Solution
solveMaze m start end = solveMaze' [start] [] start
                        where solveMaze' sol bk cur | cur == end = (m, sol, bk)
                                                    | null newNeighbs = solveMaze' (tail sol) ((head sol):bk) $ head $ tail sol
                                                    | otherwise = solveMaze' (neighbPos:sol) bk neighbPos
                                                    where newNeighbs = (filter (\x -> npos x `notElem` sol && npos x `notElem` bk && nowalls curcell x) $ neighbs m cur
                                                          curcell    = m!!cur
                                                          --neighb  = randElem newNeighbs
                                                          neighb = mhat newNeighbs end $ dims m
                                                          neighbPos  = npos neighb

coords :: Int -> (Int, Int) -> (Int, Int)
coords i (w, h) = (i `mod` w, i `div` h)

xpos, ypos :: (Int, Int) -> Int
xpos = fst
ypos = snd

--get neighbour which is closest to the goal
mhat :: [Neighbour] -> Int -> (Int, Int) -> Neighbour
mhat ns g (w, h) = head (qsort ns)
    where mhatdist n = abs (xpos (coords (npos n) (w, h)) - xposg) + abs (ypos (coords (npos n) (w, h)) - yposg)
          xposg = xpos (coords g (w, h))
          yposg = ypos (coords g (w, h))
          qsort [] = []
          qsort (n:ns) = qsort (filter closer ns) ++ [n] ++ qsort (filter further ns)
              where closer n' = mhatdist n' <= mhatdist n
                    further   = not . closer

nowalls :: Cell -> Neighbour -> Bool
nowalls c n = case ncell n of
               Nothing -> False
               Just c' ->
              dir `notElem` walls c
              && dir `notElem` borders c
              && opp dir `notElem` borders c'
              && opp dir `notElem` walls c'
            where dir = ndir n

printSolution :: Solution -> IO ()
printSolution = putStr . asciiMaze

proc :: [String] -> IO ()
proc args | length args /= 3 && length args /= 4 = usage
          | o == "--gen"                         = doGen w h f
          | o == "--sol"                         = doSol w h f
          | otherwise                            = usage
          where w = read $ args!!0
                h = read $ args!!1
                o = args!!2
                f = if length args == 4 then Just $ args!!3 else Nothing

doGen :: Int -> Int -> Maybe String -> IO ()
doGen w h Nothing  = printMaze $ genMaze w h
doGen w h (Just s) = writeFile s $ asciiMaze ((genMaze w h), [], [])

doSol :: Int -> Int -> Maybe String -> IO ()
doSol w h Nothing  = printSolution $ solveMaze (genMaze w h) 0 ((w*h)-1)
doSol w h (Just s) = writeFile s $ asciiMaze m
                     where m = solveMaze (genMaze w h) 0 ((w*h)-1)

usage :: IO ()
usage = do putStrLn "USAGE:"
           putStrLn "maze w h [--gen|--sol] [OUTFILE] [--start=START] [--end=END]"

main :: IO ()
main = do x <- getArgs
          proc x