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 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