DouKaku?

module Main

import Bool, Int, String, StringCast, Array
import System, Misc, StdIO, OptRandom, MersenneTwister, Trace

:: MazeCell = Cell !Bool !Bool //right, bottom

Start w
  # (t,w) = tickCount w
    (f,w) = stdio w
    (_,f) = writeLine 0 f
    (_,f) = writeMaze (maze n m (genRandInt t)) f
    (_,w) = close f w
  = w
  where
  cmd = getCommandLine
  n = toInt cmd.[1]
  m = toInt cmd.[2]
  get maze row col = maze.[row * n + col]

  writeMaze maze f = writeMaze maze 0 f
    where
    writeMaze maze row f
      | row == m = (PassV, f)
      = f |> write "#"
          $> printRoom 0
          $> write "\r\n#"
          $> printWall 0
          $> write "\r\n"
          $> writeMaze maze (row + 1)
      where
      m = size maze / n
      printWall col f
        | col == n = (PassV, f)
        = case get maze row col of
            Cell _ False = f |> write "##" $> printWall (col + 1)
            _            = f |> write " #" $> printWall (col + 1)

      printRoom col f
        | col == n = (PassV, f)
        = case get maze row col of
            Cell False _ = f |> write " #" $> printRoom (col + 1)
            _            = f |> write "  " $> printRoom (col + 1)

  writeLine col f
    | col == n = f |> write "#\r\n"
    = f |> write "##" $> writeLine (col + 1)

::*CellPool = CellPool !*{!(!Int,!Int)} !Int
isEmptyPool c=:(CellPool _ 0) = (True, c)
isEmptyPool c = (False, c)
getNextCell (CellPool ls sz) [r:rand]
    | sz == 1
      # (e1,ls) = ls![0]
      = (e1, CellPool ls 0, rand)
    # i = (abs r) rem sz
      (e1,ls) = ls![i]
      (e2,ls) = ls![sz-1]
      ls = {ls & [i] = e2}
    = (e1, CellPool ls (sz - 1), rand)
addCell x y (CellPool ls sz)
    # ls = {ls & [sz] = (x,y)}
    = CellPool ls (sz + 1)

maze n m rand =
    let
      sz = n * m
      marks = asUnboxedArray $ createArray sz False
      cells = asStrictArray $ createArray sz (Cell False False)
      pool = addCell 0 0 (CellPool (createArray sz (0,0)) 0)
    in
      expand marks cells pool rand
  where
    get x y arr = arr![x*n+y]
    put e x y arr = {arr & [x*n+y] = e}

    expand marks cells pool rand
      # (b,pool) = isEmptyPool pool
      | b = cells
      # ((x,y), pool, rand) = getNextCell pool rand
        (cand, marks) = filterCells marks [(x-1,y),(x,y-1),(x+1,y),(x,y+1)]
        (sel, rest, rand) = selectCells cand rand
      #! cells = updateCells x y sel cells
         marks = foldl (\marks (x,y) = put True x y marks) marks sel
         pool = foldl (\pool (x,y) = addCell x y pool) pool sel
      = case rest of
          [] = expand marks cells pool rand
          _  # pool = addCell x y pool
             = expand marks cells pool rand

    filterCells marks ls = f [] marks ls where
      f ls marks [] = (ls, marks)
      f ls marks [(x,y):ee]
        | x < 0 || y < 0 || x >= m || y >= n = f ls marks ee
        # (k,marks) = get x y marks
        | k = f ls marks ee
            = f [(x,y):ls] marks ee

    selectCells ls [r:rand] = let (e1,e2) = f ls 1 [] [] in (e1, e2, rand) where
      f [] _ e1 e2 = (e1, e2)
      f [e:ee] t e1 e2
        | r bitand t == 0 = f ee (t << 1) e1 [e:e2]
                          = f ee (t << 1) [e:e1] e2

    updateCells x y ls cells = f ls cells where
      f :: ![(Int,Int)] !*{!MazeCell} -> *{!MazeCell}
      f [] cells = cells
      f [(x1,y1):ls] cells
        # (c0, cells) = get x y cells
          (c1, cells) = get x1 y1 cells
        | x1 < x = let (Cell r b) = c1 in put (Cell r True) x1 y1 cells |> f ls
        | y1 < y = let (Cell r b) = c1 in put (Cell True b) x1 y1 cells |> f ls
        | x1 > x = let (Cell r b) = c0 in put (Cell r True) x y cells |> f ls
        | y1 > y = let (Cell r b) = c0 in put (Cell True b) x y cells |> f ls