Our Maze Jam from Lambda Jam 2013

maze.rkt

#lang racket
(require json)

(define (get-maze-cell maze x y)
  (list-ref 
   (list-ref maze y) 
   x))

(define (neighbors x y)
  (list (list x (sub1 y))
        (list (add1 x) y)        
        (list x (add1 y))
        (list (sub1 x) y)))

(define (remove-carved maze coords)
  (filter (lambda (coord)
            (= 0 (apply get-maze-cell maze coord)))
          coords))

(define (remove-oob coords width height)
  (filter (lambda (coord) 
            (and (>= (car coord) 0)
                 (< (car coord) width)
                 (>= (cadr coord) 0)
                 (< (cadr coord) height)))
          coords))

(define (uncarved-neighbors maze x y)
  (let ((width (length (car maze)))
        (height (length maze)))
    (remove-carved 
     maze
     (remove-oob (neighbors x y) width height))))

(define (random-uncarved-neighbor maze x y)
  (let ((uncarved-neighbors (uncarved-neighbors maze x y)))
    (if (null? uncarved-neighbors)
        '()
        (list-ref uncarved-neighbors
                  (random (length uncarved-neighbors))))))

(define (direction from-coords to-coords)
  (let ((diff (list (- (car to-coords)
                       (car from-coords))
                    (- (cadr to-coords)
                       (cadr from-coords)))))
    (case diff
      [((0 -1)) 'n]
      [((0 1))  's]
      [((-1 0)) 'w]
      [((1 0))  'e]
      [else 'wtf])))

(define (update-list lis idx val)
  (letrec ((upd (lambda (lis idx val cur)
                  (cond
                    ((null? lis) '())
                    ((= cur idx) (cons val (cdr lis)))
                    (else (cons 
                           (car lis) 
                           (upd (cdr lis) idx val (add1 cur))))))))
    (upd lis idx val 0)))

(define (update-maze maze coord val)
  (let* ((x (car coord))
         (y (cadr coord))
         (new-row (update-list (list-ref maze y)
                               x
                               (+ (get-maze-cell maze x y)
                                  val))))
    (update-list maze y new-row)))

(define carve-masks '((n 1) (s 2) (e 4) (w 8)))
(define (dir-inverse dir)
  (let ((dirs '((n s) (s n) (w e) (e w))))
    (cadr (assoc dir dirs))))

(define (carve-mask dir)
  (cadr (assoc dir carve-masks)))

(define (carve-cell maze from-coord to-coord)
  (letrec ((dir (direction from-coord to-coord))
           (carve-cells (lambda (dir)
                          (update-maze 
                           (update-maze maze from-coord (carve-mask dir))
                           to-coord (carve-mask (dir-inverse dir))))))
    (carve-cells dir)))

(define (carve-maze maze)
  (letrec ((carve-maze* (lambda (maze work)
                          (if (null? work)
                              maze
                              (let* ((coord (car work))
                                     (x (car coord))
                                     (y (cadr coord))
                                     (neighbor (random-uncarved-neighbor maze x y)))
                                (if (null? neighbor)
                                    (carve-maze* maze (cdr work))
                                    (carve-maze* (carve-cell maze coord neighbor) (cons neighbor work))))))))
    (carve-maze* maze '((0 0)))))

(define (build-maze width height)
  (build-list
   width
   (lambda _
     (build-list
      height
      (lambda _ 0)))))

(define (generate-maze width height)
  (carve-maze (build-maze width height)))

(define (write-maze x y)
  (jsexpr->string
   (generate-maze x y)))

(write-maze 5 5)
; "[[4,10,6,12,10],[2,3,3,2,3],[3,3,3,3,3],[3,3,3,7,9],[5,13,9,5,8]]"