Mired in code
Check-in [dcabad86a6]
Not logged in
Public Repositories
mwm's Repositories

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Add the maze program.
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:dcabad86a6ab4d3c2af02405728c62bf6bfd1533
User & Date: mwm 2015-04-18 02:06:57
Context
2015-08-26
12:39
Add the FloatController code. check-in: a6c9466454 user: mwm tags: trunk
2015-04-18
02:06
Add the maze program. check-in: dcabad86a6 user: mwm tags: trunk
2013-03-17
22:47
Update to latest version of the Watch code. check-in: 8c3827ffa1 user: mwm@mired.org tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Added haskell/maze.hs.































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
#!/usr/bin/env runhaskell

{- | A maze generator

This uses the algorithm from rosettacode.org/wiki/Maze_generation

The goal is to demonstrate a "pure" solution. In particular, the maze
(and bookkeeping data structures) should be built by binding new
versions of the maze as we walk the maze. The random number generator
could be done the same way, but is instead handled with the State
monad to show how we can put that plumbing in the walls instead of
having it out in the open.

-}

import Control.Applicative ((<$>))
import Control.Monad.State (State, state, evalState)
import Data.Array (Array, array, bounds, (//), (!))
import Data.List (delete)
import System.Environment (getArgs)
import System.Random (StdGen, newStdGen, randomR)

-- Rendering engines
{- Comment out drawing imports
import Diagrams.Prelude ((#), (|||), hcat, vcat, lwO, scale,   -- Dia drawing
                         fromOffsets, strokeT, unitX, unitY,
                         mempty, phantom, pad, centerXY,
                         Diagram, R2, SizeSpec2D(Absolute))
import Diagrams.Backend.Cairo (renderCairo, B)

import Graphics.OpenSCAD (Model3d, Vector3d, union, box, draw, -- SCAD
                          translate, mirror)
import Data.Semigroup ((<>))
-}

data Wall = Wall | Hall deriving Eq
data Cell = Cell { x, y :: Wall, visited :: Bool }
type Board = Array (Int, Int) Cell

main :: IO ()
main = do
  args <- map read <$> getArgs
  let floats = map fromIntegral args
      drawBoard' =
        case length args of
          2 -> drawBoard charX charY (drop 3 . concat) (putStr . unlines)
{- Comment out drawing argument handling
          4 -> drawBoard (diaX cs) (diaY cs) hcat (diaBoard ww)
               where [_, _, cs, ww] = floats

          6 -> drawBoard (scadX cs ww wh bd) (scadY cs ww wh bd) union
                         (draw . mirror (0, 1, 0) . union)
               where ([_, _, cs, ww, bd, wh]) = floats
-}
          _ -> error "Width Height [CellSize WallWidth | CellSize WallWidth WallHeight BaseDepth]"
  gen <- newStdGen
  drawBoard' $ evalState (walkMaze $ makeBoard (head args) (args !! 1)) gen

walkMaze :: Board -> State StdGen Board
walkMaze origBoard = let
  clearY cell = cell {y = Hall}
  clearX cell = cell {x = Hall}
  visit cell = cell {visited = True}

  allSteps = [(0, 1), (0, -1), (1, 0), (-1, 0)]

  walkCell _ [] b = return b
  walkCell start steps board = do
    step <- (steps !!) <$> (state . randomR) (0, length steps - 1)
    walkCell start (delete step steps)
      =<< doStep start step (board // [(start, visit $ board ! start)])

  doStep from@(i, j) (dX, dY) board
    | visited neighbor = return board
    | dY > 0 = walkCell' $ board // [(from, clearY cell)]
    | dY < 0 = walkCell' $ board // [(new, clearY neighbor)]
    | dX > 0 = walkCell' $ board // [(from, clearX cell)]
    | dX < 0 = walkCell' $ board // [(new, clearX neighbor)]
    where cell = board ! from
          new = (i + dX, j + dY)
          neighbor = board ! new
          walkCell' = walkCell new allSteps 
  in do
    i <- state $ randomR (1, (fst . snd $ bounds origBoard) - 1)
    j <- state $ randomR (1, (snd . snd $ bounds origBoard) - 1)
    walkCell (i, j) allSteps origBoard

-- makeboard w h:  w cells wide, h cells wide. Index is (i, j), with i
-- going in the x direction, and j the y. There are doors at 1,1 and 2, h.
-- We also add a frame of visited cells to make the random walk code simpler.
makeBoard :: Int -> Int -> Board
makeBoard w h = array ((0, 0), (w+1, h+1))
                      [((i, j), makeCell i j) | i <- [0..w+1], j <- [0..h+1]]
  where makeCell i j = Cell (if j == 0 then Hall else Wall)
                       (if i == 0 || i == 1 && j == h || i == w && j == 0
                        then Hall else Wall)
                       $ i == 0 || i > w || j == 0 || j > h

-- Generalized board drawing routine. Takes functions to make walls.
drawBoard :: (Board -> Int -> Int -> a)    -- make X-direction cell walls
             -> (Board -> Int -> Int -> a) -- make Y-direction cell walls
             -> ([a] -> b)                 -- combine [walls] into a row
             -> ([b] -> IO ())             -- Draw the board from [rows]
             -> Board                      -- Board to draw
             -> IO ()
drawBoard makeX makeY makeRow makeMaze board =
  makeMaze . concat $ [firstWall]:[drawCells j | j <- [1 .. height]]
  where height = (snd . snd $ bounds board) - 1
        width = (fst . snd $ bounds board) - 1
        firstWall = makeRow [makeX board i 0 | i <- [0 .. width]]
        drawCells j = [makeRow [makeY  board i j | i <- [0 .. width]],
                       makeRow [makeX board i j | i <- [0 .. width]]]

-- Functions to draw board with character strings
charX, charY :: Board -> Int -> Int -> String
charX board i j = if y (board ! (i, j)) == Wall then "---+" else "   +"
charY board i j = if x (board ! (i, j)) == Wall then "   |" else "    "


{- Comment out the drawing routines
-- Functions to draw a 2D Image
diaX, diaY :: Double -> Board -> Int -> Int -> Diagram B R2
diaX = diaCell y unitX mempty
diaY cellSize = diaCell x unitY (diaSpace unitX cellSize) cellSize

diaSpace :: R2 -> Double -> Diagram B R2
diaSpace unit size = phantom (fromOffsets [unit # scale size] :: Diagram B R2)

diaCell :: (Cell -> Wall) -> R2 -> Diagram B R2 -> Double -> Board -> Int -> Int
           -> Diagram B R2
diaCell side unit space cellSize board i j =
  space ||| make (side (board ! (i, j)))
  where make Wall = strokeT (fromOffsets [unit # scale cellSize])
        make Hall = diaSpace unit cellSize

diaBoard :: Double -> [Diagram B R2] -> IO ()
diaBoard ww rows =
  renderCairo "maze.png" Absolute $ vcat rows # centerXY # pad 1.1 # lwO ww

-- Functions to draw board with Graphics.OpenSCAD primitives
data SCADCell = SCADCell (Cell->Wall)                            -- Wall extractor
                         (Double -> Double -> Double -> Model3d) -- Wall drawing
                         Vector3d                                -- translation

scadX, scadY :: Double -> Double -> Double -> Double -> Board -> Int -> Int
                -> Model3d
scadX cs = scadCell (SCADCell y (flip box) (0, cs, 0)) cs
scadY cs = scadCell (SCADCell x box (cs, 0, 0)) cs

scadCell :: SCADCell -> Double -> Double -> Double -> Double ->
            Board -> Int -> Int -> Model3d
scadCell (SCADCell side box' move) cs ww wh bd board i j =
  make (side $ board ! (i, j))
  # translate (cs * fromIntegral (i - 1), cs * fromIntegral (j - 1), 0)
  where make Wall = box' ww (cs + ww) (bd + wh) # translate move <> base
        make Hall = base
        base = if i == 0 || j == 0 then box 0 0 0
               else box (cs + ww) (cs + ww) bd
-}