--- a/make-quickutils.lisp Sun Jun 26 17:52:37 2016 +0000
+++ b/make-quickutils.lisp Sun Jun 26 20:19:20 2016 +0000
@@ -14,6 +14,6 @@
:rcurry
; :zip
; :compose
- ; :n-grams
+ :n-grams
)
:package "MAZES.QUICKUTILS")
--- a/package.lisp Sun Jun 26 17:52:37 2016 +0000
+++ b/package.lisp Sun Jun 26 20:19:20 2016 +0000
@@ -16,6 +16,17 @@
#:recursively
#:recur
#:hash-keys
+ #:make-set
+ #:set-contains-p
+ #:set-add
+ #:set-remove
+ #:set-add-all
+ #:set-remove-all
+ #:set-random
+ #:set-pop
+ #:set-empty-p
+ #:hash-set
+ #:set-clear
#:%))
(defpackage #:mazes.fps
@@ -44,6 +55,7 @@
#:cell-linked-east-p
#:cell-linked-west-p
#:cell-neighbors
+ #:cell-random-neighbor
#:cell-north
#:cell-south
#:cell-east
@@ -87,7 +99,9 @@
#:sidewinder
#:sidewinder-generator
#:aldous-broder
- #:aldous-broder-generator)
+ #:aldous-broder-generator
+ #:wilson
+ #:wilson-generator)
(:import-from #:snakes
#:defgenerator
#:do-generator
--- a/quickutils.lisp Sun Jun 26 17:52:37 2016 +0000
+++ b/quickutils.lisp Sun Jun 26 20:19:20 2016 +0000
@@ -2,7 +2,7 @@
;;;; See http://quickutil.org for details.
;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:WHILE :WITH-GENSYMS :ONCE-ONLY :CURRY :RCURRY :ZIP) :ensure-package T :package "MAZES.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:WHILE :WITH-GENSYMS :ONCE-ONLY :CURRY :RCURRY :N-GRAMS) :ensure-package T :package "MAZES.QUICKUTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "MAZES.QUICKUTILS")
@@ -16,7 +16,7 @@
(setf *utilities* (union *utilities* '(:UNTIL :WHILE :STRING-DESIGNATOR
:WITH-GENSYMS :MAKE-GENSYM-LIST
:ONCE-ONLY :ENSURE-FUNCTION :CURRY
- :RCURRY :TRANSPOSE :ZIP))))
+ :RCURRY :TAKE :N-GRAMS))))
(defmacro until (expression &body body)
"Executes `body` until `expression` is true."
@@ -167,17 +167,27 @@
(multiple-value-call fn (values-list more) (values-list arguments)))))
- (defun transpose (lists)
- "Analog to matrix transpose for a list of lists given by `lists`."
- (apply #'mapcar #'list lists))
+ (defun take (n sequence)
+ "Take the first `n` elements from `sequence`."
+ (subseq sequence 0 n))
- (defun zip (&rest lists)
- "Take a tuple of lists and turn them into a list of
-tuples. Equivalent to `unzip`."
- (transpose lists))
+ (defun n-grams (n sequence)
+ "Find all `n`-grams of the sequence `sequence`."
+ (assert (and (plusp n)
+ (<= n (length sequence))))
+
+ (etypecase sequence
+ ;; Lists
+ (list (loop :repeat (1+ (- (length sequence) n))
+ :for seq :on sequence
+ :collect (take n seq)))
+
+ ;; General sequences
+ (sequence (loop :for i :to (- (length sequence) n)
+ :collect (subseq sequence i (+ i n))))))
(eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(while with-gensyms with-unique-names once-only curry rcurry zip)))
+ (export '(while with-gensyms with-unique-names once-only curry rcurry n-grams)))
;;;; END OF quickutils.lisp ;;;;
--- a/src/demo.lisp Sun Jun 26 17:52:37 2016 +0000
+++ b/src/demo.lisp Sun Jun 26 20:19:20 2016 +0000
@@ -9,7 +9,7 @@
(defparameter *center-x* (/ *width* 2))
(defparameter *center-y* (/ *height* 2))
(defparameter *maze-size* 700)
-(defvar *generator* #'sidewinder-generator)
+(defvar *generator* 'sidewinder-generator)
(defvar *instant* nil)
(defvar *show-longest* nil)
(defvar *show-colors* nil)
@@ -148,7 +148,7 @@
(frame 0)
(log " ")
;; Variables
- (grid (make-grid 25 25))
+ (grid (make-grid 15 15))
(gen (funcall *generator* grid))
(finished-generating nil)
(distances nil)
@@ -163,7 +163,7 @@
(with-setup
;; Maze
(when (and (not finished-generating)
- (dividesp frame 5))
+ (dividesp frame 1))
(when *instant*
(while (not (funcall gen))))
(when (funcall gen)
@@ -172,7 +172,7 @@
(draw-maze sketch::instance)
;; UI
(with-font *ui-font*
- (text "algorithm: [a]ldous-broder [b]inary tree [s]idewinder"
+ (text "algorithm: [a]ldous-broder [b]inary tree [s]idewinder [w]ilson"
(+ (- *center-x*) 5) (- *center-y* 40))
(text "display: [C]olor distances [L]ongest path [I]nstant generation"
(+ (- *center-x*) 5) (- *center-y* 22)))
@@ -281,9 +281,10 @@
(:scancode-lalt (setf *option* t))
(:scancode-ralt (setf *option* t))
;;
- (:scancode-s (setf *generator* #'sidewinder-generator))
- (:scancode-b (setf *generator* #'binary-tree-generator))
- (:scancode-a (setf *generator* #'aldous-broder-generator))
+ (:scancode-s (setf *generator* 'sidewinder-generator))
+ (:scancode-b (setf *generator* 'binary-tree-generator))
+ (:scancode-a (setf *generator* 'aldous-broder-generator))
+ (:scancode-w (setf *generator* 'wilson-generator))
(:scancode-l (if *shift*
(zap% *show-longest* #'not %)
nil))
--- a/src/generation.lisp Sun Jun 26 17:52:37 2016 +0000
+++ b/src/generation.lisp Sun Jun 26 20:19:20 2016 +0000
@@ -1,10 +1,21 @@
(in-package #:mazes.generation)
-(defmacro with-cell-active (cell-place &body body)
- `(prog2
- (setf (cell-active ,cell-place) t)
- (progn ,@body)
- (setf (cell-active ,cell-place) nil)))
+(defmacro with-cell-active (cell &body body)
+ (once-only (cell)
+ `(prog2
+ (setf (cell-active ,cell) t)
+ (progn ,@body)
+ (setf (cell-active ,cell) nil))))
+
+(defun clear-active-group (cells)
+ (loop :for c :in cells :do (setf (cell-active-group c) nil)))
+
+(defun set-active-group (cells)
+ (loop :for c :in cells :do (setf (cell-active-group c) t)))
+
+(defun reset-active-group (old-cells new-cells)
+ (clear-active-group old-cells)
+ (set-active-group new-cells))
;;;; Binary Tree
@@ -62,7 +73,7 @@
(cell-link member member-north))
(yield)
(setf (cell-active member) nil)
- (loop :for c :in run :do (setf (cell-active-group c) nil))
+ (clear-active-group run)
(setf run nil))
(progn
(cell-link cell (cell-east cell))
@@ -97,3 +108,42 @@
(defun aldous-broder (grid)
(do-generator (_ (aldous-broder-generator grid)))
grid)
+
+
+;;;; Wilson
+;;;
+
+(defgenerator wilson-generator (grid)
+ (let ((unvisited (make-set :initial-data (grid-map-cells #'identity grid))))
+ (setf (cell-active-group (set-pop unvisited)) t) ; random initial target
+ (loop :with path = nil
+ :with cell = (set-random unvisited)
+ :while cell :do
+ (with-cell-active cell
+ (let ((path-loop (member cell path)))
+ (setf path (cons cell path))
+ (cond
+ ;; If we've made a loop, trim it off.
+ (path-loop
+ (reset-active-group path path-loop)
+ (setf path path-loop
+ cell (cell-random-neighbor cell)))
+
+ ;; If we've hit a visited cell, carve out the path.
+ ((not (set-contains-p unvisited cell))
+ (mapc (curry #'apply #'cell-link)
+ (n-grams 2 path))
+ (set-remove-all unvisited path)
+ (setf path nil
+ cell (set-random unvisited)))
+
+ ;; Otherwise keep going
+ (t
+ (setf (cell-active-group cell) t)
+ (setf cell (cell-random-neighbor cell)))))
+ (yield))))
+ (grid-clear-active grid))
+
+(defun wilson (grid)
+ (do-generator (_ (wilson-generator grid)))
+ grid)
--- a/src/grid.lisp Sun Jun 26 17:52:37 2016 +0000
+++ b/src/grid.lisp Sun Jun 26 20:19:20 2016 +0000
@@ -53,6 +53,9 @@
(with-slots (north south east west) cell
(full-list north south east west)))
+(defun cell-random-neighbor (cell)
+ (random-elt (cell-neighbors cell)))
+
(defmethod print-object ((cell cell) stream)
(print-unreadable-object (cell stream :type t :identity nil)
@@ -83,7 +86,7 @@
(defun grid-map-cells (fn grid)
(with-slots (cells) grid
(loop :for i :from 0 :below (array-total-size cells)
- :do (funcall fn (row-major-aref cells i)))))
+ :collect (funcall fn (row-major-aref cells i)))))
(defun grid-map-rows (fn grid)
(with-slots (rows cols cells) grid
--- a/src/utils.lisp Sun Jun 26 17:52:37 2016 +0000
+++ b/src/utils.lisp Sun Jun 26 20:19:20 2016 +0000
@@ -115,3 +115,64 @@
(defun hash-keys (hash-table)
(loop :for k :being :the hash-keys :of hash-table :collect k))
+
+
+;;;; Sets
+(defclass hash-set ()
+ ((data :initarg :data)))
+
+
+(defun make-set (&key (test #'eql) (initial-data nil))
+ (let ((set (make-instance 'hash-set
+ :data (make-hash-table :test test))))
+ (mapcar (curry #'set-add set) initial-data)
+ set))
+
+
+(defun set-contains-p (set value)
+ (nth-value 1 (gethash value (slot-value set 'data))))
+
+(defun set-empty-p (set)
+ (zerop (hash-table-count (slot-value set 'data))))
+
+(defun set-add (set value)
+ (setf (gethash value (slot-value set 'data)) t)
+ value)
+
+(defun set-add-all (set seq)
+ (map nil (curry #'set-add set) seq))
+
+(defun set-remove (set value)
+ (remhash value (slot-value set 'data))
+ value)
+
+(defun set-remove-all (set seq)
+ (map nil (curry #'set-remove set) seq))
+
+(defun set-clear (set)
+ (clrhash (slot-value set 'data))
+ set)
+
+(defun set-random (set)
+ (if (set-empty-p set)
+ (values nil nil)
+ (loop :with data = (slot-value set 'data)
+ :with target = (random (hash-table-count data))
+ :for i :from 0
+ :for k :being :the :hash-keys :of data
+ :when (= i target)
+ :do (return (values k t)))))
+
+(defun set-pop (set)
+ (multiple-value-bind (val found) (set-random set)
+ (if found
+ (progn
+ (set-remove set val)
+ (values val t))
+ (values nil nil))))
+
+
+(defmethod print-object ((set hash-set) stream)
+ (print-unreadable-object (set stream :type t)
+ (format stream "~{~S~^ ~}"
+ (hash-keys (slot-value set 'data)))))