Haskell Quiz/Amazing Mazes/Solution Kuklewicz
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.
{- 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 100x100 maze in about 21 seconds on
1.33GHz G4 powerbook (OS X 10.4.8) using ghc-6.6 and compiling with "-O2".
TODO : add a solver
-}
module Main where
import Control.Monad
import Control.Monad.ST
import Data.Array.IArray
import Data.Array.MArray
import Data.Array.ST
import Data.Array.Unboxed
import Data.STRef
import System.Environment(getArgs)
import System.Random
type Maze = UArray (Int,Int) Int
buildMaze :: Int -> Int -> StdGen -> Maze
buildMaze height width g = runSTUArray (buildMazeM height width 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 = [ (h,w) | h <- [2,4..pred hr2], w <- [2,4..pred wr2] ]
sizeInterior = (height-1)*(width-1) -- number of unused nodes
m <- newArray hwBounds 0
sequence_ [ writeArray m i 1 | i <- perimeter ]
return (m,interior,sizeInterior)
buildMazeM height width g = do
gRef <- newSTRef g
let rand lu = do (val,g') <- liftM (randomR lu) (readSTRef gRef)
writeSTRef gRef g'
return val
(m,interior,sizeInterior) <- initMaze height width
let addNodes toAdd | toAdd<0 = error (show toAdd ++ " < 0 toAdd error")
| toAdd==0 = return m
| otherwise = do
i <- rand (1,toAdd)
node <- findNode i interior
added <- connect [] node
addNodes (toAdd-added)
findNode i [] = error (show i ++ " [] error")
findNode i (x:xs) | i < 1 = error (show i ++ " < 1 error")
| otherwise = do
used <- readArray m x
case used of
1 -> findNode i xs
0 -> if i==1 then return x
else findNode (pred i) xs
e -> error (show (i,x,e) ++ " was found error")
connect nodes node = do
used <- readArray m node
if used > 0
then do
mapM_ addWall nodes
return (length nodes)
else do
dir <- rand (1,4)
writeArray m node (negate dir)
let node' = op dir (op dir node)
nodes' = if used == 0 then (node:nodes) else nodes
connect nodes' node'
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")
addWall node = do
dir <- liftM negate (readArray m node)
writeArray m node 1
writeArray m (op dir node) 1
addNodes sizeInterior
showMaze :: Maze -> [String]
showMaze m = let ((hr1,wr1),(hr2,wr2)) = bounds 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
[h,w] <- fmap (map read) getArgs
putStr . unlines . showMaze . buildMaze h w =<< newStdGen