;; -*- Mode: Irken -*-

(include "lib/basis.scm")
(include "lib/map.scm")
(include "lib/mtwist.scm")

;;  0  1  2  3 ...
;; 24 25 26 27 ...
;; 48 49 50 51 ...
;; ...

;; bits: UDLR
;;       3210
;; i.e., R is bit 0, L is bit 1...

;; create a fully-populated grid of walls.
(define (make-grid m n)
  ;; convert from (x,y) to node number.
  (define (N x y) (+ x (* m y)))
  (let ((G (make-vector (* m n) 0)))
    (for-range x m
      (for-range y n
        (let ((edges 0))
          (define (add n)
            (set! edges (logior n edges)))
          (when (> x 0)       (add #b0010))
          (when (> y 0)       (add #b1000))
          (when (< x (- m 1)) (add #b0001))
          (when (< y (- n 1)) (add #b0100))
          (set! G[(N x y)] edges)
          )))
    G
    ))

(define (dump-graph G)
  (for-range i (vector-length G)
    (printf (lpad 4 (int i)) " " (zpad 4 (bin G[i])) "\n")))

(define rand-range
  (let ((rng (mt19937 (read-cycle-counter))))
    (lambda (n)
      (mod (rng) n))))

(define (bit-set? n i)
  (> (logand n (<< 1 i)) 0))

;; assumes <s> is non-zero!
(define choose-random-edge
  (let ((rng (generate-random-bits 2 (read-cycle-counter))))
    (lambda (s)
      (let loop ((mn (rng)))
        (match mn with
          (maybe:yes n)
          -> (if (bit-set? s n) n (loop (rng)))
          (maybe:no)
          -> (impossible)
          )))))

;; depth-first-search.
(define (DFS G m n)
  (let ((size (vector-length G))
        (start (rand-range size))
        (fifo (queue/make))
        ;; XXX bitfield if we really cared.
        (visited (make-vector size #f)))

    ;; return the node in a given direction.
    ;; UDLR
    (define move
      x #b0001 -> (+ x 1)
      x #b0010 -> (- x 1)
      x #b0100 -> (+ x m)
      x #b1000 -> (- x m)
      x _      -> (impossible)
      )

    ;; which walls lead to unvisited nodes?
    (define (unvisited-from node)
      (let ((edges G[node])
            (r 0))
        (for-range i 4
          (when (bit-set? edges i)
            (let ((next (move node (<< 1 i))))
              (when (not visited[next])
                (set! r (logior r (<< 1 i)))))))
        r))                             ;

    ;; remove the wall[s] between `a` and `b`
    (define (remove-wall! a b)
      (define (remove a b)
        (let ((walls G[a]))
          (cond ((= b (- a m)) ;; U
                 (set! walls (logxor #b1000 walls)))
                ((= b (+ a m)) ;; D
                 (set! walls (logxor #b0100 walls)))
                ((= b (- a 1)) ;; L
                 (set! walls (logxor #b0010 walls)))
                ((= b (+ a 1)) ;; R
                 (set! walls (logxor #b0001 walls)))
                )
          (set! G[a] walls)))
      (remove a b)
      (remove b a)
      )

    (define (search current)
      (match (unvisited-from current) with
        0 -> (match (queue/pop! fifo) with
               (maybe:yes node) -> (search node)
               (maybe:no)       -> #u)
        n -> (let ((dir (choose-random-edge n))
                   (next (move current (<< 1 dir))))
               (queue/add! fifo current)
               (remove-wall! current next)
               (set! visited[next] #t)
               (search next))
        ))

    (search start)
    G
    ))

(define (graph->svg G m n S)

  ;; translate & scale
  (define (T n)
    ;; S = scale factor
    (+ S (* S n)))

  (define (wall a b)
    ;; walls are stored twice (i.e. a->b, b->a).
    ;; this way we only render each wall once.
    (when (< a b)
      (let (((y0 x0) (divmod a m)) ;; convert from node number to (x,y)
            ((y1 x1) (divmod b m))
            ;; translate all the coordinates.
            (x2 (T x0))
            (y2 (T y0))
            (x3 (T x1))
            (y3 (T y1)))
        (cond ((= x2 x3) ;; vertical connection, horizontal wall
               (line x2 (+ y2 S) (+ x2 S) (+ y2 S)))
              ((= y2 y3) ;; horizontal connection, vertical wall
               (line (+ x2 S) y2 (+ x2 S) (+ y2 S)))
              ))))

  (define (line x0 y0 x1 y1)
    (printf "<line x1=\"" (int x0)
            "\" x2=\"" (int x1)
            "\" y1=\"" (int y0)
            "\" y2=\"" (int y1)
            "\" stroke=\"black\" stroke-width=\"2\"/>\n"))

  (define (line* x0 y0 x1 y1)
    (line (T x0) (T y0) (T x1) (T y1)))

  (define move
    x #b0001 -> (+ x 1)
    x #b0010 -> (- x 1)
    x #b0100 -> (+ x m)
    x #b1000 -> (- x m)
    x _      -> (impossible)
    )

  (printf "<svg version=\"1.1\" width=\"" (int (+ 10 (T m)))
          "\" height=\"" (int (+ 10 (T n)))
          "\" xmlns=\"http://www.w3.org/2000/svg\""
          ">")
  ;; draw the boundary
  (line* 0 0 m 0)
  (line* m 0 m n)
  (line* m n 0 n)
  (line* 0 n 0 0)
  (for-range x m
    (for-range y n
      (let ((node (+ x (* m y)))
            (walls G[node]))
        (for-range i 4
          (when (bit-set? walls i)
            (wall node (move node (<< 1 i))))))))
  (printf "</svg>\n")
  )

(define (make-maze m n)
  (let ((G (make-grid m n))
        (G0 (DFS G m n)))
    (graph->svg G0 m n 10)
    ))

(make-maze 1000 700)