Maze generation in Scheme

maze-generation.scm

;;; based on https://rosettacode.org/wiki/Maze_generation#Racket
;;; (translated to Scheme)
;;;
;;; Currently works with Chicken Scheme 5.1.0, Guile 3.0.1,
;;; MIT Scheme 10.1.10, and SISC 1.16.6:
;;;   csi -s maze-generation.scm
;;;   guile -s maze-generation.scm
;;;   mit-scheme --batch-mode --load maze-generation.scm --eval '(exit)'
;;;   sisc -x maze-generation.scm
;;;
;;; (Fun fact, Chicken Scheme and Guile produce one maze, while
;;; MIT Scheme and SISC produce a different maze, even though the
;;; sequence of pseudo-random numbers should be the same.)
;;;
;;; Currently fails with Husk 3.20:
;;;   huski maze-generation.scm
;;;
;;; The error message is:
;;;   Invalid type: expected variable, found (vector-ref tbl (car c))

;; simple random number generator
(define *seed* 37619)

(define (rand n)
  (set! *seed* (modulo (* 48271 *seed*) 2147483647))
  (modulo *seed* n))

;; managing cell properties
(define (connections tbl c)
  (let ((i (car  c))
        (j (cadr c)))
    (if (< -1 i (vector-length tbl))
        (let ((vec (vector-ref tbl i)))
          (if (< -1 j (vector-length vec))
              (vector-ref vec j)
              '()))
        '())))

(define (add-neighbor! tbl c n)
  (vector-set! (vector-ref tbl (car c)) (cadr c)
               (cons n (connections tbl c))))

(define (connect! tbl c n)
  (add-neighbor! tbl c n)
  (add-neighbor! tbl n c))

(define (connected? tbl a b) (member a (connections tbl b)))

(define (filt-neighbors c pred dirs)
  (if (null? dirs)
      '()
      (let* ((d    (car dirs))
             (rest (cdr dirs))
             (n    (map + c d))
             (r    (filt-neighbors c pred rest)))
        (if (pred n) (cons n r) r))))

(define (make-table N M)
  (if (<= N 0)
      '()
      (cons (make-vector M '()) (make-table (- N 1) M))))

(define (shuf lst)
  (define vec (list->vector lst))
  (define (shuf1 n)
    (if (<= n 0)
        '()
        (let* ((n1 (- n 1))
               (k  (rand n))
               (x  (vector-ref vec k))
               (y  (vector-ref vec n1)))
          (vector-set! vec k y)
          (cons x (shuf1 n1)))))
  (shuf1 (vector-length vec)))

(define (range-list n)
  (define (rl1 m)
    (if (>= m n)
        '()
        (cons m (rl1 (+ m 1)))))
  (rl1 0))

(define (for-range n f)
  (for-each f (range-list n)))

;; Returns a maze of a given size
;; build-maze :: Index Index -> Maze
(define (build-maze N M)
  (define tbl (list->vector (make-table N M)))
  (define (visited? tbl c) (not (null? (connections tbl c))))
  (define (neighbors c)
    (filt-neighbors c (lambda (x) (and (<= 0 (car  x) (- N 1))
                                       (<= 0 (cadr x) (- M 1))))
                    '((0 1) (0 -1) (-1 0) (1 0))))
  (define (move-to-cell c)
    (for-each (lambda (x)
                (if (not (visited? tbl x))
                    (begin
                      (connect! tbl c x)
                      (move-to-cell x))))
              (shuf (neighbors c))))
  ; generate the maze
  (move-to-cell (list (rand N) (rand M)))
  ; return the result
  (list N M tbl))

;; Shows a maze
(define (show-maze m)
  (let ((N   (car   m))
        (M   (cadr  m))
        (tbl (caddr m)))
    (for-range N (lambda (i) (display "+---")))
    (display "+")
    (newline)
    (for-range M (lambda (j)
                   (display "|")
                   (for-range (- N 1)
                              (lambda (i)
                                (if (connected? tbl (list i j)
                                                (list (+ 1 i) j))
                                    (display "    ")
                                    (display "   |"))))
                   (display "   |")
                   (newline)
                   (for-range N (lambda (i)
                                  (if (connected? tbl (list i j)
                                                  (list i (+ j 1)))
                                      (display "+   ")
                                      (display "+---"))))
                   (display "+")
                   (newline)))
    (newline)))

(define m (build-maze 10 7))
(show-maze m)