Difference between revisions of "Haskell Quiz/Amazing Mazes/Solution Kuklewicz"
Jump to navigation
Jump to search
(Add a maze generator) |
m (Use Data.Set and pick from Set.toList) |
||
Line 29: | Line 29: | ||
import Data.Array.ST |
import Data.Array.ST |
||
import Data.Array.Unboxed |
import Data.Array.Unboxed |
||
+ | import Data.List(foldl') |
||
import Data.STRef |
import Data.STRef |
||
+ | import Data.Set(Set) |
||
+ | import qualified Data.Set as S |
||
import System.Environment(getArgs) |
import System.Environment(getArgs) |
||
import System.Random |
import System.Random |
||
Line 46: | Line 49: | ||
, [(h,wr1) | h <- tail $ hr] -- left |
, [(h,wr1) | h <- tail $ hr] -- left |
||
, [(h,wr2) | h <- init $ hr] ] -- right |
, [(h,wr2) | h <- init $ hr] ] -- right |
||
− | interior = [ (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] ] |
− | sizeInterior = (height-1)*(width-1) -- number of unused nodes |
||
m <- newArray hwBounds 0 |
m <- newArray hwBounds 0 |
||
sequence_ [ writeArray m i 1 | i <- perimeter ] |
sequence_ [ writeArray m i 1 | i <- perimeter ] |
||
− | return (m,interior |
+ | return (m,interior) |
buildMazeM height width g = do |
buildMazeM height width g = do |
||
Line 57: | Line 59: | ||
writeSTRef gRef g' |
writeSTRef gRef g' |
||
return val |
return val |
||
− | (m,interior |
+ | (m,interior) <- initMaze height width |
− | let addNodes toAdd | toAdd |
+ | let addNodes toAdd | S.null toAdd = return m |
− | | toAdd==0 = return m |
||
| otherwise = do |
| otherwise = do |
||
− | i <- rand ( |
+ | i <- rand (0, pred (S.size toAdd)) |
− | node |
+ | let node = (S.toList toAdd) !! i |
added <- connect [] node |
added <- connect [] node |
||
− | addNodes (toAdd |
+ | addNodes (foldl' (flip S.delete) 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 |
connect nodes node = do |
||
used <- readArray m node |
used <- readArray m node |
||
Line 79: | Line 71: | ||
then do |
then do |
||
mapM_ addWall nodes |
mapM_ addWall nodes |
||
− | return |
+ | return nodes |
else do |
else do |
||
dir <- rand (1,4) |
dir <- rand (1,4) |
||
Line 95: | Line 87: | ||
writeArray m node 1 |
writeArray m node 1 |
||
writeArray m (op dir node) 1 |
writeArray m (op dir node) 1 |
||
− | addNodes |
+ | addNodes interior |
showMaze :: Maze -> [String] |
showMaze :: Maze -> [String] |
Revision as of 17:16, 6 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 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.List(foldl')
import Data.STRef
import Data.Set(Set)
import qualified Data.Set as S
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 = S.fromDistinctAscList [ (h,w) | h <- [2,4..pred hr2], w <- [2,4..pred wr2] ]
m <- newArray hwBounds 0
sequence_ [ writeArray m i 1 | i <- perimeter ]
return (m,interior)
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) <- initMaze height width
let addNodes toAdd | S.null toAdd = return m
| 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 > 0
then do
mapM_ addWall nodes
return 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 interior
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