{- 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
when (dir /= startFrom) $
do writeArray m point onPath
path (op dir point)
path iTo
writeArray m iTo endAt