190 lines
5.4 KiB
Scheme
190 lines
5.4 KiB
Scheme
;; In Emacs, open this file in -*- Scheme -*- mode.
|
|
|
|
(defrec print-n-char
|
|
(fun (n c)
|
|
(if (> n 0)
|
|
(begin
|
|
(char-print c)
|
|
(print-n-char (- n 1) c)))))
|
|
|
|
(defrec contains
|
|
(fun (l elem)
|
|
(and (not (list-empty? l))
|
|
(or (= (list-head l) elem)
|
|
(contains (list-tail l) elem)))))
|
|
|
|
(defrec shuffle
|
|
(fun (l seed)
|
|
(let ((v (list->vector l)))
|
|
(vector-shuffle! v seed)
|
|
(vector->list v))))
|
|
|
|
;; Cells
|
|
|
|
(def cell
|
|
(fun (r c s)
|
|
(+ (* r s) c)))
|
|
|
|
(def atE
|
|
(fun (c s)
|
|
(+ c 1)))
|
|
|
|
(def atW
|
|
(fun (c s)
|
|
(- c 1)))
|
|
|
|
(def atN
|
|
(fun (c s)
|
|
(- c s)))
|
|
|
|
(def atS
|
|
(fun (c s)
|
|
(+ c s)))
|
|
|
|
;; Walls
|
|
;; Represented as a pair of 15-bits integers (cell indices), packed in
|
|
;; a single one.
|
|
|
|
(def wall-make
|
|
(fun (c1 c2)
|
|
(int-bitwise-or (int-shift-left c1 15) c2)))
|
|
|
|
(def wall-cell-1
|
|
(fun (w)
|
|
(int-shift-right w 15)))
|
|
|
|
(def wall-cell-2
|
|
(fun (w)
|
|
(int-bitwise-and w #x7FFF)))
|
|
|
|
(def wall-up?
|
|
(fun (c1 c2 w)
|
|
(contains w (wall-make c1 c2))))
|
|
|
|
|
|
;; Create a maze that has walls everywhere
|
|
(defrec completeMaze-acc
|
|
(fun (r c s acc)
|
|
(if (< r s)
|
|
(if (< c s)
|
|
(let* ((rc (cell r c s))
|
|
(res1 (if (< c (- s 1))
|
|
(list-prepend (wall-make (cell r c s) (atE rc s)) acc)
|
|
acc))
|
|
(res2 (if (< r (- s 1))
|
|
(list-prepend (wall-make (cell r c s) (atS rc s)) res1)
|
|
res1)))
|
|
(completeMaze-acc r (+ c 1) s res2))
|
|
(completeMaze-acc (+ r 1) 0 s acc))
|
|
acc)))
|
|
|
|
(def completeMaze
|
|
(fun (s)
|
|
(completeMaze-acc 0 0 s list-empty)))
|
|
|
|
;; Create a list of singleton lists for each cell of the maze
|
|
(defrec fullyDisconnectedSets-acc
|
|
(fun (r c s acc)
|
|
(if (< r s)
|
|
(if (< c s)
|
|
(let ((res (list-prepend (list-make (cell r c s)) acc)))
|
|
(fullyDisconnectedSets-acc r (+ c 1) s res))
|
|
(fullyDisconnectedSets-acc (+ r 1) 0 s acc))
|
|
acc)))
|
|
|
|
(def fullyDisconnectedSets
|
|
(fun (s)
|
|
(fullyDisconnectedSets-acc 0 0 s list-empty)))
|
|
|
|
(defrec connected
|
|
(fun (sets c1 c2)
|
|
(and (not (= sets list-empty))
|
|
(let ((set (list-head sets)))
|
|
(or (and (contains set c1)
|
|
(contains set c2))
|
|
(connected (list-tail sets) c1 c2))))))
|
|
|
|
;; return the first element that satisfies p
|
|
(def find
|
|
(fun (p l)
|
|
(let ((res (list-filter p l)))
|
|
(if (list-empty? res)
|
|
res
|
|
(list-head res)))))
|
|
|
|
(def connect
|
|
(fun (sets c1 c2)
|
|
(let ((setOfC1 (find (fun (e) (contains e c1)) sets))
|
|
(setOfC2 (find (fun (e) (contains e c2)) sets)))
|
|
(list-prepend (list-append setOfC1 setOfC2)
|
|
(list-filter (fun (e)
|
|
(and (not (contains e c1))
|
|
(not (contains e c2))))
|
|
sets)))))
|
|
|
|
;; execute body for each int between from and to
|
|
(defrec for
|
|
(fun (from to body)
|
|
(if (< from to)
|
|
(begin
|
|
(body from)
|
|
(for (+ from 1) to body))
|
|
0)))
|
|
|
|
(def print-maze
|
|
(fun (s w)
|
|
(let ((space ' ')
|
|
(wall 'X'))
|
|
(print-n-char (+ (* s 2) 1) wall)
|
|
(newline-print)
|
|
(for 0 s
|
|
(fun (r)
|
|
(char-print wall)
|
|
(for 0 s
|
|
(fun (c)
|
|
(char-print space)
|
|
(if (< c (- s 1))
|
|
(let ((rc (cell r c s)))
|
|
(char-print (if (wall-up? rc (atE rc s) w) wall space)))
|
|
0)))
|
|
(char-print wall)
|
|
(newline-print)
|
|
(if (< r (- s 1))
|
|
(begin
|
|
(char-print wall)
|
|
(for 0 s
|
|
(fun (c)
|
|
(let ((rc (cell r c s)))
|
|
(char-print (if (wall-up? rc (atS rc s) w) wall space))
|
|
(if (< c (- s 1))
|
|
(char-print wall)
|
|
0))))
|
|
(char-print wall)
|
|
(newline-print))
|
|
0)))
|
|
(print-n-char (+ (* s 2) 1) wall)
|
|
(newline-print))))
|
|
|
|
(defrec random-maze-acc
|
|
(fun (m c acc)
|
|
(if (list-empty? m)
|
|
acc
|
|
(let ((w (list-head m)))
|
|
(if (connected c (wall-cell-1 w) (wall-cell-2 w))
|
|
(random-maze-acc (list-tail m) c (list-prepend w acc))
|
|
(random-maze-acc (list-tail m) (connect c (wall-cell-1 w) (wall-cell-2 w)) acc))))))
|
|
|
|
|
|
(def random-maze
|
|
(fun (s seed)
|
|
(let ((m (shuffle (completeMaze s) seed))
|
|
(c (fullyDisconnectedSets s)))
|
|
(random-maze-acc m c list-empty))))
|
|
|
|
|
|
(string-print "Size: ") ; T
|
|
(let ((size (int-read)))
|
|
(string-print "Seed: ") ; G
|
|
(let ((seed (int-read)))
|
|
(print-maze size (random-maze size seed))))
|