Personal tools

Haskell Quiz/Amazing Mazes/Solution Kuklewicz

From HaskellWiki

< Haskell Quiz | Amazing Mazes(Difference between revisions)
Jump to: navigation, 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,sizeInterior)
+
return (m,interior)
   
 
buildMazeM height width g = do
 
buildMazeM height width g = do
Line 56: Line 59:
 
writeSTRef gRef g'
 
writeSTRef gRef g'
 
return val
 
return val
(m,interior,sizeInterior) <- initMaze height width
+
(m,interior) <- initMaze height width
let addNodes toAdd | toAdd<0 = error (show toAdd ++ " < 0 toAdd error")
+
let addNodes toAdd | S.null toAdd = return m
| toAdd==0 = return m
 
 
| otherwise = do
 
| otherwise = do
i <- rand (1,toAdd)
+
i <- rand (0, pred (S.size toAdd))
node <- findNode i interior
+
let node = (S.toList toAdd) !! i
 
added <- connect [] node
 
added <- connect [] node
addNodes (toAdd-added)
+
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 68: Line 71:
 
then do
 
then do
 
mapM_ addWall nodes
 
mapM_ addWall nodes
return (length nodes)
+
return nodes
 
else do
 
else do
 
dir <- rand (1,4)
 
dir <- rand (1,4)
Line 84: Line 87:
 
writeArray m node 1
 
writeArray m node 1
 
writeArray m (op dir node) 1
 
writeArray m (op dir node) 1
addNodes sizeInterior
+
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