maze.rkt

#lang racket/base

;; Growing Tree Algorithm
;; http://weblog.jamisbuck.org/2011/1/27/maze-generation-growing-tree-algorithm

(require racket/class
         racket/draw
         racket/format
         racket/list
         racket/match
         pict)

(struct cell (x y) #:transparent)
(struct edge (from to) #:transparent)
(struct maze (width height edges))

(define (generate-maze width height)
  (define visited (make-vector (* width height) #f))  

  (define (add-edge edges from to)
    (list* (edge from to) edges))

  (define (cell->index c)
    (match-define (cell x y) c)
    (+ x (* width y)))

  (define (visit! c)
    (vector-set! visited (cell->index c) #t))

  (define (visited? c)
    (vector-ref visited (cell->index c)))

  (define (unvisited? c)
    (not (visited? c)))

  (define (neighbors c)
    (match-define (cell x y) c)
    (for*/list ([dy (in-range -1 2 1)]
                [dx (in-range -1 2 1)]
                #:unless
                (or (and (zero? dx) (zero? dy))
                    (< 1 (+ (abs dx) (abs dy))))
                [y (in-value (+ dy y))]
                [x (in-value (+ dx x))]
                #:when
                (and (<= 0 x) (< x width)
                     (<= 0 y) (< y height)))
      (cell x y)))

  (define (unvisited-neighbors c)
    (filter unvisited? (neighbors c)))

  ;; default pick favors N W E S
  #;(define pick-neighbor stream-first)

  (define (pick-neighbor n*)
    (for/fold ([sel #f]) ([i (in-naturals 1)]
                          [n n*])
      (if (< (* i (random)) 1) n sel)))

  (define (once edges to-explore)
    (define cur (first to-explore))
    (define n* (unvisited-neighbors cur))    
    (cond
      [(pick-neighbor n*)
       =>
       (lambda (next)
         (visit! next)
         (values (add-edge edges cur next)
                 (list* next to-explore)))]
      [else
       (values edges (rest to-explore))]))       
  
  (define (generate edges to-explore)    
    (if (empty? to-explore)
        edges
        (call-with-values
         (lambda () (once edges to-explore))
         generate)))

  (define initial-cell
    (cell (random width) (random height)))
  (visit! initial-cell)
  (define edges
    (generate null (list initial-cell)))
  (maze width height edges))

(define (draw-maze m)
  (match-define (maze width height edges) m)
  (freeze
   (dc (lambda (dc x0 y0)
         (define-syntax-rule (tx v) (+ 3 (* 5 v)))
         (send dc set-background "black")
         (send dc clear)
         (define old-pen (send dc get-pen))
         (define old-transform (send dc get-transformation))
         (send dc set-pen (make-pen #:color "white" #:width 2 #:cap 'butt))
         (send dc translate x0 y0)
         (for ([an-edge (in-list edges)])
           (match-define
             (edge (cell x1 y1) (cell x2 y2))
             an-edge)
           (send dc draw-point (tx x1) (tx y1))
           (send dc draw-point (tx x2) (tx y2))
           (send dc draw-line (tx x1) (tx y1) (tx x2) (tx y2)))
         (send dc set-pen old-pen)
         (send dc set-transformation old-transform))
       (* 5 width) (* 5 height))))

(define (prune-maze m)
  (match-define (maze width height edges) m)
  (define connections (make-vector (* width height) 0))
  (define-syntax-rule (incr! c)
    (match-let ([(cell x y) c])
      (let ([o (+ x (* 50 y))])
        (vector-set! connections o (add1 (vector-ref connections o))))))
  (for ([e (in-list edges)])
    (incr! (edge-from e))
    (incr! (edge-to e)))

  (displayln (~r #:precision '(= 2)
                 (/ (+ 0.0 (for/sum ([v (in-vector connections)]) v))
                    (vector-length connections))))

  (define dead-cells
    (for*/list ([y (in-range 50)]
                [x (in-range 50)]
                #:when (= 1 (vector-ref connections (+ x (* 50 y)))))
      (cell x y)))

  (for/fold ([edges edges]) ([c (in-list dead-cells)])
    (for/list ([e (in-list edges)]
               #:unless (or (equal? (first e) c)
                            (equal? (rest e) c)))
      e)))