Maze generator

Maze.tq

type rec Tree = Tree((Number, Number), Stack Tree)

let mkFree n =
  for 0 1 (n-1) (Set.empty()) [ps, x ->
    for 0 1 (n-1) ps [ps, y ->
      Set.add (x, y) ps]]

let rec search free (i, j as ij) =
  let moves =
    Random.next 4
    @ [ 0 -> {i-1, j; i, j+1; i+1, j; i, j-1}
      | 1 -> {i, j+1; i+1, j; i, j-1; i-1, j}
      | 2 -> {i+1, j; i, j-1; i-1, j; i, j+1}
      | _ -> {i, j-1; i-1, j; i, j+1; i+1, j} ] in
  Array.fold searchAux (Set.remove ij free, Tree(ij, Stack.empty())) moves
and searchAux ((free, Tree(ij2, trees)), ij) =
  if Set.contains ij free then
    let free, tree = search free ij in
    free, Tree(ij2, Stack.push tree trees)
  else
    free, Tree(ij2, trees)

let rec fill walls (Tree(p0, p1s)) =
  Stack.fold [walls, (Tree(p1, _) as tree) ->
    let wall (x0, y0) (x1, y1) =
      (x1-x0, y1-y0)
      @ [  0,-1 -> (x0, y0), (x0+1, y0)
        |  0, 1 -> (x0, y0+1), (x0+1, y0+1)
        | -1, 0 -> (x0, y0), (x0, y0+1)
        |  1, 0 -> (x0+1, y0), (x0+1, y0+1)
        | _ -> panic "" ] in
    fill (Set.remove (wall p0 p1) walls) tree]
    walls p1s

let mkWalls n =
  let walls =
    for 0 1 n (Set.empty()) [ps, i ->
      for 0 1 n ps [ps, j ->
        let ps = if i < n then Set.add ((i, j), (i+1, j)) ps else ps in
        if j < n then Set.add ((i, j), (i, j+1)) ps else ps]] in
  let _, tree = search (mkFree n) (0, 0) in
  fill walls tree

let walls = mkWalls 8

let line stroke (s, e) =
  Shape(Style(NoFill, Stroke stroke), Path(Open(s, {Line e})))

let () =
  let n = 18 in
  let w = 600 in
  let s (x, y) = ((x+1/2)*w/(n+1), (y+1/2)*w/(n+1)) in
  mkWalls n
  @ Array.ofSet
  @ Array.map [p0, p1 -> line (Black, 3) (s p0, s p1)]
  @ Html.ofSvg (w, w)
  @ yield