;; -*- 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 ...
;; ...

(define (make-grid m n)
  (define (N x y) (+ x (* m y)))
  (define (R x y) (N (+ x 1) y))
  (define (L x y) (N (- x 1) y))
  (define (U x y) (N x (- y 1)))
  (define (D x y) (N x (+ y 1)))
  (let ((G (tree/empty)))
    (for-range x m
      (for-range y n
        (let ((edges (set/empty)))
          (define (add-edge n)
            (set/add! edges int-cmp n))
          (when (> x 0) (add-edge (L x y)))
          (when (> y 0) (add-edge (U x y)))
          (when (< x (- m 1)) (add-edge (R x y)))
          (when (< y (- n 1)) (add-edge (D x y)))
          (tree/insert! G int-cmp (N x y) {v=edges})
          )))
    ;; (dump-graph G)
    G
    ))

(define (dump-graph G)
  (for-map k v G
    (printf (int k) " (" (join int->string " " (set->list v.v)) ")\n")
    ))

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

;; this is ridiculous.
;; (define (nth-item n set)
;;   (let ((g (set/make-generator set)))
;;     (let loop ((n n))
;;       (cond ((= n 0)
;;              (match (g) with
;;                (maybe:yes item) -> item
;;                (maybe:no) -> (impossible)))
;;             (else
;;              (g)
;;              (loop (- n 1)))))))

(define (nth-item n set)
  (let ((ls (set->list set))
        (len (length ls))
        (choice (rand-range len)))
    (nth ls choice)))

(define (choose-random-edge s)
  (nth-item (rand-range (set/size s)) s))

(define (DFS G)
  (let ((size (tree/size G)) ;; assumes nodes numbered 0..n
        (start (rand-range size))
        (fifo (queue/make))
        (visited (set/empty)))

    (define (remove-edge! a b)
      (define (remove a b)
        (match (tree/member G int-cmp a) with
          (maybe:yes cell)
          -> (set/delete! cell.v int-cmp b)
          (maybe:no)
          -> (impossible)))
      (remove a b)
      (remove b a))

    (define (unvisited-from n)
      (match (tree/member G int-cmp n) with
        (maybe:yes {v=(set:empty)})
        -> (maybe:no)
        (maybe:yes cell)
        -> (let ((diff (set/difference int-cmp cell.v visited)))
             (match diff with
               (set:empty) -> (maybe:no)
               s           -> (maybe:yes s)
               ))
        (maybe:no)
        -> (maybe:no)
        ))

    (define (search current)
      (match (unvisited-from current) with
        (maybe:yes s)
        -> (let ((choice (choose-random-edge s)))
             (queue/add! fifo current)
             (remove-edge! current choice)
             (set/insert! visited int-cmp choice)
             (search choice))
        (maybe:no)
        -> (match (queue/pop! fifo) with
             (maybe:yes node) -> (search node)
             (maybe:no)       -> #u
             )
        ))

    (search start)
    G
    ))

;; this sucks
(define (print-graph G m n)
  (define (N x y) (+ x (* m y)))

  (printf "+-" (repeat m "--") "+\n")
  (for-range x m
    (printf "|")
    (for-range y n
      (let ((node (+ x (* m y))))
        (match (tree/member G int-cmp node) with
          (maybe:yes {v=(set:empty)})
          -> (printf "  ")
          (maybe:yes {v=s})
          -> (match (set/member? s int-cmp (+ 1 node)) (set/member? s int-cmp (+ m node)) with
               #t #t -> (printf "_|")
               #t #f -> (printf " |")
               #f #t -> (printf "__")
               #f #f -> (printf "  ")
               )
          (maybe:no)
          -> (impossible)
          )))
    (printf " |\n")
    )
  (printf "+-" (repeat m "--") "+\n")
  )

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

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

  (define (R a b)
    (if (> a b)
        (R b a)
        (let (((y0 x0) (divmod a m))
              ((y1 x1) (divmod b m))
              (s2 (/ S 2))
              (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 (grid-line a b)
  ;;   (let (((y0 x0) (divmod a m))
  ;;         ((y1 x1) (divmod b m)))
  ;;     (line x0 y0 x1 y1)))

  (printf "<svg version=\"1.1\" width=\"" (int (T m))
          "\" height=\"" (int (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-map fnode v G
    (match v with
      {v=(set:empty)} -> #u
      {v=s}
      -> (for-set tnode s
           (R fnode tnode))))
  (printf "</svg>\n")
  )

(define stderr (stdio/fdopen 2 (cstring "wb")))

(defmacro DBG
  (DBG x ...)
  -> (stdio/write stderr (format x ...)))

(let ((G (make-grid 200 120))
      (_ (DBG "made\n"))
      (G0 (DFS G)))
  (DBG "searched\n")
  ;;(print-graph (DFS G) 20 20)
  ;; (dump-graph G0)
  (graph->svg G0 200 120 10)
  (DBG "to svg\n")
  )