Personal tools

Haskell Quiz/Amazing Mazes/Solution Kuklewicz

From HaskellWiki

< Haskell Quiz | Amazing Mazes(Difference between revisions)
Jump to: navigation, search
m (Use Data.Set and pick from Set.toList)
(Add solver, now a complete solution)
Line 15: Line 15:
 
direction taken from that node.
 
direction taken from that node.
  
This can generate and print a 100x100 maze in about 21 seconds on
+
This can generate and print a 256x256 maze in about 38 seconds on
 
1.33GHz G4 powerbook (OS X 10.4.8) using ghc-6.6 and compiling with "-O2".
 
1.33GHz G4 powerbook (OS X 10.4.8) using ghc-6.6 and compiling with "-O2".
  
TODO : add a solver
+
-- Usage:
 
+
-- ./mazer height width
 +
-- which defaults to starting at 1 1 and stopping at height width
 +
-- ./mazer height width rowStart colStart rowStop,colStop
 +
-- where row and col are in [1..height] and [1..width] respectively
 
-}
 
-}
module Main where
+
module Main (main) where
  
import Control.Monad
+
import Control.Monad(when)
import Control.Monad.ST
+
import Data.Array.ST(runSTUArray,readArray,writeArray,newArray)
import Data.Array.IArray
+
import Data.Array.Unboxed(UArray,(!),bounds,range)
import Data.Array.MArray
+
import Data.List -- (foldl')
import Data.Array.ST
+
import qualified Data.Set as S(fromDistinctAscList,null,size,toList,delete)
import Data.Array.Unboxed
+
import Data.STRef(newSTRef,readSTRef,writeSTRef)
import Data.List(foldl')
+
import System.Environment
import Data.STRef
+
import System.Random(StdGen,newStdGen,randomR)
import Data.Set(Set)
+
import qualified Data.Set as S
+
import System.Environment(getArgs)
+
import System.Random
+
  
 
type Maze = UArray (Int,Int) Int
 
type Maze = UArray (Int,Int) Int
  
buildMaze :: Int -> Int -> StdGen -> Maze
+
main = do
buildMaze height width g = runSTUArray (buildMazeM height width g)
+
  [hw,iFrom,iTo] <- handleArgs
 +
  putStr . unlines . showMaze . buildMaze hw iFrom iTo =<< newStdGen
 +
 
 +
handleArgs = do
 +
  args <- getArgs
 +
  case length args of
 +
    2 -> let [h,w] = map read args
 +
        in return [(h,w),(1,1),(h*2-1,w*2-1)]
 +
    6 -> let [h,w,r1,c1,r2,c2] = map read args
 +
        in return [(h,w),(r1*2-1,c1*2-1),(r2*2-1,c2*2-1)]
 +
    _ -> fail "Incorrect command line args, need 2 or 6 numbers"
 +
 
 +
blank,solid,startFrom,endAt,onPath :: Int
 +
blank = 0; solid = 5; startFrom = 6; endAt = 7; onPath = 8
 +
-- up down left right = 1 2 3 4
 +
 
 +
showMaze :: Maze -> [String]
 +
showMaze m = let ((hr1,wr1),(hr2,wr2)) = bounds m
 +
                row h = foldr ($) "" [ display (m!(h,w)) | w <- range (wr1,wr2) ]
 +
                display 0 = (':':).(':':)
 +
                display 5 = ('#':).('#':)
 +
                display 6 = ('[':).(']':)
 +
                display 7 = ('{':).('}':)
 +
                display 8 = ('<':).('>':)
 +
                display _ = (':':).(':':) -- default is blank
 +
            in map row (range (hr1,hr2))
 +
 
 +
buildMaze :: (Int,Int) -> (Int,Int) -> (Int,Int) -> StdGen -> Maze
 +
buildMaze hw iFrom iTo g = runSTUArray (buildMazeM hw iFrom iTo g)
  
initMaze height width = do
+
initMaze (height,width) = do
 
   let hwBounds@((hr1,wr1),(hr2,wr2)) = ((0,0),(2*height,2*width))
 
   let hwBounds@((hr1,wr1),(hr2,wr2)) = ((0,0),(2*height,2*width))
 
       hr = range (hr1,hr2)
 
       hr = range (hr1,hr2)
Line 50: Line 77:
 
                         , [(h,wr2) | h <- init $ hr] ] -- right
 
                         , [(h,wr2) | h <- init $ hr] ] -- right
 
       interior = S.fromDistinctAscList [ (h,w) | h <- [2,4..pred hr2], w <- [2,4..pred wr2] ]
 
       interior = S.fromDistinctAscList [ (h,w) | h <- [2,4..pred hr2], w <- [2,4..pred wr2] ]
   m <- newArray hwBounds 0
+
   m <- newArray hwBounds blank
   sequence_ [ writeArray m i 1 | i <- perimeter ]
+
   sequence_ [ writeArray m i solid | i <- perimeter ]
 
   return (m,interior)
 
   return (m,interior)
  
buildMazeM height width g = do
+
buildMazeM hw@(height,width) iFrom iTo g = do
 
   gRef <- newSTRef g
 
   gRef <- newSTRef g
   let rand lu = do (val,g') <- liftM (randomR lu) (readSTRef gRef)
+
  (m,interior) <- initMaze hw
 +
   let rand lu = do (val,g') <- fmap (randomR lu) (readSTRef gRef)
 
                   writeSTRef gRef g'
 
                   writeSTRef gRef g'
 
                   return val
 
                   return val
  (m,interior) <- initMaze height width
+
      addNodes toAdd | S.null toAdd = return ()
  let addNodes toAdd | S.null toAdd = return m
+
 
                     | otherwise = do
 
                     | otherwise = do
 
         i <- rand (0, pred (S.size toAdd))
 
         i <- rand (0, pred (S.size toAdd))
Line 68: Line 95:
 
       connect nodes node = do
 
       connect nodes node = do
 
         used <- readArray m node
 
         used <- readArray m node
         if used > 0
+
         if used == solid
           then do
+
           then do mapM_ addWall nodes
            mapM_ addWall nodes
+
                  return nodes
            return nodes
+
           else do dir <- rand (1,4)
           else do
+
                  writeArray m node dir
            dir <- rand (1,4)
+
                  let node' = op dir (op dir node)
            writeArray m node (negate dir)
+
                      nodes' = if used == blank then (node:nodes) else nodes
            let node' = op dir (op dir node)
+
                  connect nodes' node'
                nodes' = if used == 0 then (node:nodes) else nodes
+
       addWall node = do dir <- readArray m node
            connect nodes' node'
+
                        writeArray m node solid
      op dir (h,w) = case dir of 1 -> (h-1,w)
+
                        writeArray m (op dir node) solid
                                2 -> (h+1,w)
+
                                3 -> (h,w-1)
+
                                4 -> (h,w+1)
+
                                _ -> error (show dir ++ " not a dir error")
+
       addWall node = do
+
        dir <- liftM negate (readArray m node)
+
        writeArray m node 1
+
        writeArray m (op dir node) 1
+
 
   addNodes interior
 
   addNodes interior
    
+
   found <- solveFromTo m iFrom iTo
showMaze :: Maze -> [String]
+
  when (not found) (fail "Solution not found")
showMaze m = let ((hr1,wr1),(hr2,wr2)) = bounds m
+
  return m
                wr = range (wr1,wr2)
+
                row h = concat [ display (m!(h,w)) | w <- wr ]
+
                display 0 = "::"
+
                display 1 = "##"
+
                display _ = "??"  -- this indicates an error
+
            in map row (range (hr1,hr2))
+
  
main = do
+
op dir (h,w) = case dir of
  [h,w] <- fmap (map read) getArgs
+
                1 -> (h-1,w)
   putStr . unlines . showMaze . buildMaze h w =<< newStdGen
+
                2 -> (h+1,w)
 +
                3 -> (h,w-1)
 +
                4 -> (h,w+1)
 +
                _ -> error (show dir ++ " not a dir error")
 +
 
 +
rev 1 = 2; rev 2 = 1; rev 3 = 4; rev 4 = 3
 +
 
 +
solveFromTo m iFrom iTo | iFrom == iTo = writeArray m iTo endAt >> return True
 +
                        | otherwise = do
 +
  writeArray m iFrom startFrom
 +
  writeArray m iTo endAt
 +
  let search point [] = return False
 +
      search point (dir:dirs) = do
 +
        let wall = op dir point
 +
            point' = op dir wall
 +
            dir' = rev dir
 +
        wallValue <- readArray m wall
 +
        if wallValue/=blank
 +
          then search point dirs
 +
          else do writeArray m wall dir'
 +
                  point'Value <- readArray m point'
 +
                  writeArray m point' dir'
 +
                  if point'Value == endAt
 +
                    then return True
 +
                    else do found <- search point' (delete dir' [1..4])
 +
                            if found then return True
 +
                                    else search point dirs
 +
   found <- search iFrom [1..4]
 +
  when found (markSolution m iTo)
 +
  return found
 +
 
 +
markSolution m iTo = do
 +
  let path point = do
 +
        dir <- readArray m point
 +
        if dir == startFrom
 +
          then return ()
 +
          else do writeArray m point onPath
 +
                  path (op dir point)
 +
  path iTo
 +
  writeArray m iTo endAt
 
</haskell>
 
</haskell>

Revision as of 16:06, 9 November 2006

{- for http://haskell.org/haskellwiki/?title=Haskell_Quiz/Amazing_Mazes
 
by Chris Kuklewicz <haskell@list.mightyreason.com> copyright 2006, 3BSD license
 
The algorithm is from http://www.astrolog.org/labyrnth/algrithm.htm
and is the "Wilson's algorithm" in wall adder mode.
 
This array indices are strange: (odd,odd) array entries are the
spaces, the (even,even) are the wall intersections (which I call
nodes), and the (odd,even) and the (even,odd) are the possible wall
locations.  The value is 0 if empty and 1 if filled.  Negative value
are used at nodes only when adding walls to indicate the last
direction taken from that node.
 
This can generate and print a 256x256 maze in about 38 seconds on
1.33GHz G4 powerbook (OS X 10.4.8) using ghc-6.6 and compiling with "-O2".
 
-- Usage:
-- ./mazer height width
-- which defaults to starting at 1 1 and stopping at height width
-- ./mazer height width rowStart colStart rowStop,colStop
-- where row and col are in [1..height] and [1..width] respectively
-}
module Main (main) where
 
import Control.Monad(when)
import Data.Array.ST(runSTUArray,readArray,writeArray,newArray)
import Data.Array.Unboxed(UArray,(!),bounds,range)
import Data.List -- (foldl')
import qualified Data.Set as S(fromDistinctAscList,null,size,toList,delete)
import Data.STRef(newSTRef,readSTRef,writeSTRef)
import System.Environment
import System.Random(StdGen,newStdGen,randomR)
 
type Maze = UArray (Int,Int) Int
 
main = do
  [hw,iFrom,iTo] <- handleArgs
  putStr . unlines . showMaze . buildMaze hw iFrom iTo =<< newStdGen
 
handleArgs = do
  args <- getArgs
  case length args of
    2 -> let [h,w] = map read args
         in return [(h,w),(1,1),(h*2-1,w*2-1)]
    6 -> let [h,w,r1,c1,r2,c2] = map read args
         in return [(h,w),(r1*2-1,c1*2-1),(r2*2-1,c2*2-1)]
    _ -> fail "Incorrect command line args, need 2 or 6 numbers"
 
blank,solid,startFrom,endAt,onPath :: Int
blank = 0; solid = 5; startFrom = 6; endAt = 7; onPath = 8
-- up down left right = 1 2 3 4
 
showMaze :: Maze -> [String]
showMaze m = let ((hr1,wr1),(hr2,wr2)) = bounds m
                 row h = foldr ($) "" [ display (m!(h,w)) | w <- range (wr1,wr2) ]
                 display 0 = (':':).(':':)
                 display 5 = ('#':).('#':)
                 display 6 = ('[':).(']':)
                 display 7 = ('{':).('}':)
                 display 8 = ('<':).('>':)
                 display _ = (':':).(':':) -- default is blank
             in map row (range (hr1,hr2))
 
buildMaze :: (Int,Int) -> (Int,Int) -> (Int,Int) -> StdGen -> Maze
buildMaze hw iFrom iTo g = runSTUArray (buildMazeM hw iFrom iTo g)
 
initMaze (height,width) = do
  let hwBounds@((hr1,wr1),(hr2,wr2)) = ((0,0),(2*height,2*width))
      hr = range (hr1,hr2)
      wr = range (wr1,wr2)
      perimeter = concat [ [(hr1,w) | w <- init $ wr] -- top
                         , [(hr2,w) | w <- tail $ wr] -- bottom
                         , [(h,wr1) | h <- tail $ hr] -- left
                         , [(h,wr2) | h <- init $ hr] ] -- right
      interior = S.fromDistinctAscList [ (h,w) | h <- [2,4..pred hr2], w <- [2,4..pred wr2] ]
  m <- newArray hwBounds blank
  sequence_ [ writeArray m i solid | i <- perimeter ]
  return (m,interior)
 
buildMazeM hw@(height,width) iFrom iTo g = do
  gRef <- newSTRef g
  (m,interior) <- initMaze hw
  let rand lu = do (val,g') <- fmap (randomR lu) (readSTRef gRef)
                   writeSTRef gRef g'
                   return val
      addNodes toAdd | S.null toAdd = return ()
                     | otherwise = do
        i <- rand (0, pred (S.size toAdd))
        let node = (S.toList toAdd) !! i
        added <- connect [] node
        addNodes (foldl' (flip S.delete) toAdd added)
      connect nodes node = do
        used <- readArray m node
        if used == solid
          then do mapM_ addWall nodes
                  return nodes
          else do dir <- rand (1,4)
                  writeArray m node dir
                  let node' = op dir (op dir node)
                      nodes' = if used == blank then (node:nodes) else nodes
                  connect nodes' node'
      addWall node = do dir <- readArray m node
                        writeArray m node solid
                        writeArray m (op dir node) solid
  addNodes interior
  found <- solveFromTo m iFrom iTo
  when (not found) (fail "Solution not found")
  return m
 
op dir (h,w) = case dir of
                 1 -> (h-1,w)
                 2 -> (h+1,w)
                 3 -> (h,w-1)
                 4 -> (h,w+1)
                 _ -> error (show dir ++ " not a dir error")
 
rev 1 = 2; rev 2 = 1; rev 3 = 4; rev 4 = 3
 
solveFromTo m iFrom iTo | iFrom == iTo = writeArray m iTo endAt >> return True
                        | otherwise = do
  writeArray m iFrom startFrom
  writeArray m iTo endAt
  let search point [] = return False
      search point (dir:dirs) = do
        let wall = op dir point
            point' = op dir wall
            dir' = rev dir
        wallValue <- readArray m wall
        if wallValue/=blank
          then search point dirs
          else do writeArray m wall dir'
                  point'Value <- readArray m point'
                  writeArray m point' dir'
                  if point'Value == endAt
                    then return True
                    else do found <- search point' (delete dir' [1..4])
                            if found then return True
                                     else search point dirs
  found <- search iFrom [1..4]
  when found (markSolution m iTo)
  return found
 
markSolution m iTo = do
  let path point = do
        dir <- readArray m point
        if dir == startFrom
          then return ()
          else do writeArray m point onPath
                  path (op dir point)
  path iTo
  writeArray m iTo endAt