Difference between revisions of "Haskell Quiz/Amazing Mazes/Solution Kuklewicz"
Jump to navigation
Jump to search
m (Use Data.Set and pick from Set.toList) |
m |
||
(3 intermediate revisions by 3 users not shown) | |||
Line 1: | Line 1: | ||
− | [[Category: |
+ | [[Category:Haskell Quiz solutions|Amazing Mazes]] |
<haskell> |
<haskell> |
||
{- for http://haskell.org/haskellwiki/?title=Haskell_Quiz/Amazing_Mazes |
{- for http://haskell.org/haskellwiki/?title=Haskell_Quiz/Amazing_Mazes |
||
Line 15: | Line 15: | ||
direction taken from that node. |
direction taken from that node. |
||
− | This can generate and print a |
+ | 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". |
1.33GHz G4 powerbook (OS X 10.4.8) using ghc-6.6 and compiling with "-O2". |
||
+ | -- Usage: |
||
− | TODO : add a solver |
||
+ | -- ./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 where |
+ | module Main (main) where |
− | import Control.Monad |
+ | import Control.Monad(when) |
+ | import Data.Array.ST(runSTUArray,readArray,writeArray,newArray) |
||
− | import Control.Monad.ST |
||
− | import Data.Array. |
+ | import Data.Array.Unboxed(UArray,(!),bounds,range) |
− | import Data. |
+ | import Data.List -- (foldl') |
+ | import qualified Data.Set as S(fromDistinctAscList,null,size,toList,delete) |
||
− | import Data.Array.ST |
||
− | import Data. |
+ | import Data.STRef(newSTRef,readSTRef,writeSTRef) |
− | import |
+ | import System.Environment |
+ | import System.Random(StdGen,newStdGen,randomR) |
||
− | 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 |
type Maze = UArray (Int,Int) Int |
||
+ | main = do |
||
− | buildMaze :: Int -> Int -> StdGen -> Maze |
||
+ | [hw,iFrom,iTo] <- handleArgs |
||
− | buildMaze height width g = runSTUArray (buildMazeM height width g) |
||
+ | 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 |
+ | initMaze (height,width) = do |
let hwBounds@((hr1,wr1),(hr2,wr2)) = ((0,0),(2*height,2*width)) |
let hwBounds@((hr1,wr1),(hr2,wr2)) = ((0,0),(2*height,2*width)) |
||
hr = range (hr1,hr2) |
hr = range (hr1,hr2) |
||
Line 50: | Line 77: | ||
, [(h,wr2) | h <- init $ hr] ] -- right |
, [(h,wr2) | h <- init $ hr] ] -- right |
||
interior = S.fromDistinctAscList [ (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] ] |
||
− | m <- newArray hwBounds |
+ | m <- newArray hwBounds blank |
− | sequence_ [ writeArray m i |
+ | sequence_ [ writeArray m i solid | i <- perimeter ] |
return (m,interior) |
return (m,interior) |
||
− | buildMazeM height |
+ | buildMazeM hw@(height,width) iFrom iTo g = do |
gRef <- newSTRef g |
gRef <- newSTRef g |
||
+ | (m,interior) <- initMaze hw |
||
− | let rand lu = do (val,g') <- liftM (randomR lu) (readSTRef gRef) |
||
+ | let rand lu = do (val,g') <- fmap (randomR lu) (readSTRef gRef) |
||
writeSTRef gRef g' |
writeSTRef gRef g' |
||
return val |
return val |
||
+ | addNodes toAdd | S.null toAdd = return () |
||
− | (m,interior) <- initMaze height width |
||
− | let addNodes toAdd | S.null toAdd = return m |
||
| otherwise = do |
| otherwise = do |
||
i <- rand (0, pred (S.size toAdd)) |
i <- rand (0, pred (S.size toAdd)) |
||
Line 68: | Line 95: | ||
connect nodes node = do |
connect nodes node = do |
||
used <- readArray m node |
used <- readArray m node |
||
− | if used |
+ | if used == solid |
− | then do |
+ | 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 |
||
− | writeArray m node (negate dir) |
||
− | + | connect nodes' node' |
|
− | + | addWall node = do dir <- readArray m node |
|
− | + | writeArray m node solid |
|
− | + | writeArray m (op dir node) solid |
|
− | 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 |
addNodes interior |
||
+ | found <- solveFromTo m iFrom iTo |
||
− | |||
+ | when (not found) (fail "Solution not found") |
||
− | showMaze :: Maze -> [String] |
||
+ | return m |
||
− | 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)) |
||
+ | op dir (h,w) = case dir of |
||
− | main = do |
||
+ | 1 -> (h-1,w) |
||
− | [h,w] <- fmap (map read) getArgs |
||
+ | 2 -> (h+1,w) |
||
− | putStr . unlines . showMaze . buildMaze h w =<< newStdGen |
||
+ | 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 |
||
</haskell> |
</haskell> |
Latest revision as of 02:48, 19 February 2010
{- 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