Personal tools

Haskell Quiz/Amazing Mazes/Solution Burton

From HaskellWiki

< Haskell Quiz | Amazing Mazes(Difference between revisions)
Jump to: navigation, search
m
m
 
(4 intermediate revisions by 2 users not shown)
Line 1: Line 1:
[[Category:Code]]
+
[[Category:Haskell Quiz solutions|Amazing Mazes]]
 
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.
 
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.
   
Line 98: Line 98:
 
h = findH m 1
 
h = findH m 1
 
findW [] x = -1
 
findW [] x = -1
findW (c:cs) x = if elem E (borders c) then x else findW cs (x+1)
+
findW (c:cs) x = if E `elem` (borders c) then x else findW cs (x+1)
 
findH [] x = -1
 
findH [] x = -1
findH (c:cs) x = if elem S (borders c) then (x `div` w) else findH cs (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
 
--get the neighbours of a position in the maze
 
neighbs :: Maze -> Int -> [Neighbour]
 
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 : [])
+
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
 
where len = length m
w = fst (dims m)
+
(w,h) = dims m
h = snd (dims m)
+
neighb x y d | newPos >= len || newPos < 0 = (Nothing, -1, d) --past beginning or end
neighb x y d | newPos > (len)-1 || newPos < 0 = (Nothing, -1, d) --past beginning or end
+
| newX >= w || newX < 0 = (Nothing, -1, d) --last row
| newX > (w-1) || newX < 0 = (Nothing, -1, d) --last row
+
| newY >= h || newY < 0 = (Nothing, -1, d) --last col
| newY > (h-1) || newY < 0 = (Nothing, -1, d) --last col
+
| otherwise = (Just (m!!newPos), newPos, d)
| otherwise = (Just (m!!newPos), newPos, d)
 
 
where newPos = i+x + (y*w)
 
where newPos = i+x + (y*w)
 
newX = x + (i `mod` h)
 
newX = x + (i `mod` h)
Line 123: Line 123:
 
| null newNeighbs = genMaze' m' (tail stk) (head $ tail stk) vis
 
| null newNeighbs = genMaze' m' (tail stk) (head $ tail stk) vis
 
| otherwise = genMaze' m'' (neighbPos:stk) neighbPos (vis+1)
 
| otherwise = genMaze' m'' (neighbPos:stk) neighbPos (vis+1)
where newNeighbs = filter (\x -> (not (elem (npos x) stk)) && allwalls (fromJust $ ncell x)) (neighbs m' cur)
+
where newNeighbs = filter (\x -> (npos x `notElem` stk) && allwalls (fromJust $ ncell x)) (neighbs m' cur)
 
neighb = randElem newNeighbs
 
neighb = randElem newNeighbs
 
neighbWall = opp curWall
 
neighbWall = opp curWall
 
neighbPos = npos neighb
 
neighbPos = npos neighb
neighbCell = fromJust $ ncell neighb
+
Just neighbCell = ncell neighb
 
curWall = ndir neighb
 
curWall = ndir neighb
 
m'' = splice (splice m' (newNeighb, neighbPos)) (newCur, cur)
 
m'' = splice (splice m' (newNeighb, neighbPos)) (newCur, cur)
 
newCur = GenCell (borders curcell) (delete curWall (walls curcell))
 
newCur = GenCell (borders curcell) (delete curWall (walls curcell))
newNeighb = GenCell (borders (neighbCell)) (delete neighbWall $ walls neighbCell)
+
newNeighb = GenCell (borders neighbCell) (delete neighbWall $ walls neighbCell)
 
curcell = m'!!cur
 
curcell = m'!!cur
 
 
   
 
opp :: Direction -> Direction
 
opp :: Direction -> Direction
opp d = case d of N -> S
+
opp N = S
E -> W
+
opp E = W
S -> N
+
opp S = N
W -> E
+
opp W = E
   
 
allwalls :: Cell -> Bool
 
allwalls :: Cell -> Bool
allwalls c = foldr (\(b, w) t -> (b || w) && t) True
+
allwalls c = all (\d -> d `elem` walls c || d `elem` borders c) ds
$ zip [elem d (walls c) | d <- ds] [elem d (borders c) | d <- ds]
 
 
where ds = [N .. W]
 
where ds = [N .. W]
   
Line 156: Line 156:
   
 
asciiMaze :: Solution -> String
 
asciiMaze :: Solution -> String
asciiMaze (m, s, b) = (topBorder w) ++ asciiRows m 0
+
asciiMaze (m, s, b) = topBorder w ++ asciiRows m 0
where w = fst (dims m)
+
where (w,h) = dims m
h = snd (dims m)
 
 
asciiRows [] c = "\n"
 
asciiRows [] c = "\n"
asciiRows m c = (asciiRow (take w m) [] 0 c s b) ++ (asciiRows (drop w m) (c+w))
+
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 :: [Cell] -> [Cell] -> Int -> Int -> [Int] -> [Int] -> String
 
asciiRow [] acc i pos sol bk = ""
 
asciiRow [] acc i pos sol bk = ""
asciiRow [c] acc i pos sol bk | i == 0 = (showCell c i pos sol bk) ++ "|\n" ++ asciiRow (reverse (c:acc)) [] 1 (pos-(length (c:acc))) 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
| otherwise = (showCell c i pos sol bk) ++ "+\n"
+
asciiRow [c] acc i pos sol bk = showCell c i pos sol bk ++ "+\n"
asciiRow (c:cs) acc i pos sol bk | i == 0 = (showCell c i pos sol bk) ++ (asciiRow cs (c:acc) 0 (pos+1) sol bk)
+
asciiRow (c:cs) acc 0 pos sol bk = showCell c i pos sol bk ++ asciiRow cs (c:acc) 0 (pos+1) sol bk
| otherwise = (showCell c i pos sol bk) ++ (asciiRow cs (c:acc) 1 (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 :: Cell -> Int -> Int -> [Int] -> [Int] -> String
showCell c b pos sol bk | b == 0 && (elem pos sol) = showCellMS c
+
showCell c 0 pos sol bk | pos `elem` sol = showCellMS c
| b == 0 && (elem pos bk) = showCellMB c
+
| pos `elem` bk = showCellMB c
| b == 0 = showCellM c
+
| otherwise = showCellM c
| otherwise = showCellB c
+
showCell c _ _ _ _ = showCellB c
   
 
showCellB, showCellM, showCellMS, showCellMB :: Cell -> String
 
showCellB, showCellM, showCellMS, showCellMB :: Cell -> String
showCellB c = if (elem S $ borders c) || (elem S $ walls c) then "+---" else "+ "
+
showCellB c | S `elem` borders c || S `elem` walls c = "+---"
showCellM c = if (elem W $ borders c) || (elem W $ walls c) then "| " else " "
+
| otherwise = "+ "
showCellMS c = if (elem W $ borders c) || (elem W $walls c) then "| x " else " x "
+
showCellM c | W `elem` borders c || W `elem` walls c = "| "
showCellMB c = if (elem W $ borders c) || (elem W $walls c) then "| - " else " - "
+
| 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 :: Maze -> IO ()
Line 188: Line 188:
 
| null newNeighbs = solveMaze' (tail sol) ((head sol):bk) $ head $ tail sol
 
| null newNeighbs = solveMaze' (tail sol) ((head sol):bk) $ head $ tail sol
 
| otherwise = solveMaze' (neighbPos:sol) bk neighbPos
 
| otherwise = solveMaze' (neighbPos:sol) bk neighbPos
where newNeighbs = (filter (\x -> (not (elem (npos x) sol)) && (not (elem (npos x) bk)) && nowalls curcell x)) $ neighbs m cur
+
where newNeighbs = (filter (\x -> npos x `notElem` sol && npos x `notElem` bk && nowalls curcell x) $ neighbs m cur
 
curcell = m!!cur
 
curcell = m!!cur
 
--neighb = randElem newNeighbs
 
--neighb = randElem newNeighbs
Line 213: Line 213:
   
 
nowalls :: Cell -> Neighbour -> Bool
 
nowalls :: Cell -> Neighbour -> Bool
nowalls c n | isNothing $ ncell n = False
+
nowalls c n = case ncell n of
| not (elem dir $ walls c)
+
Nothing -> False
&& not (elem dir $ borders c)
+
Just c' ->
&& not (elem (opp dir) $ borders c')
+
dir `notElem` walls c
&& not (elem (opp dir) $ walls c') = True
+
&& dir `notElem` borders c
| otherwise = False
+
&& opp dir `notElem` borders c'
where c' = fromJust $ ncell n
+
&& opp dir `notElem` walls c'
dir = ndir n
+
where dir = ndir n
   
 
printSolution :: Solution -> IO ()
 
printSolution :: Solution -> IO ()

Latest revision as of 00:14, 22 February 2010

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