# HG changeset patch # User Steve Losh # Date 1466972360 0 # Node ID e897732c9b7137029867b4933500d188e0aa8557 # Parent cf49d1035bcd22025ddb5db643bffa7494a8de00 Add Wilson's algorithm (and some basic sets) diff -r cf49d1035bcd -r e897732c9b71 make-quickutils.lisp --- 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") diff -r cf49d1035bcd -r e897732c9b71 package.lisp --- 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 diff -r cf49d1035bcd -r e897732c9b71 quickutils.lisp --- 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 ;;;; diff -r cf49d1035bcd -r e897732c9b71 src/demo.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)) diff -r cf49d1035bcd -r e897732c9b71 src/generation.lisp --- 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) diff -r cf49d1035bcd -r e897732c9b71 src/grid.lisp --- 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 diff -r cf49d1035bcd -r e897732c9b71 src/utils.lisp --- 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)))))