Haskell Quiz/Amazing Mazes/Solution Burton
Jump to navigation
Jump to search
The printable version is no longer supported and may have rendering errors. Please update your browser bookmarks and please use the default browser print function instead.
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