--- a/make-quickutils.lisp Sun Jun 26 20:19:20 2016 +0000
+++ b/make-quickutils.lisp Thu Jun 30 23:23:24 2016 +0000
@@ -5,7 +5,7 @@
:utilities '(
; :define-constant
; :switch
- :while
+ ; :while
; :ensure-boolean
:with-gensyms
:once-only
--- a/mazes.asd Sun Jun 26 20:19:20 2016 +0000
+++ b/mazes.asd Thu Jun 30 23:23:24 2016 +0000
@@ -11,6 +11,7 @@
#:sketch
#:sb-cga
#:snakes
+ #:iterate
#:cl-strings
#:cl-arrows)
--- a/package.lisp Sun Jun 26 20:19:20 2016 +0000
+++ b/package.lisp Thu Jun 30 23:23:24 2016 +0000
@@ -1,6 +1,7 @@
(defpackage #:mazes.utils
(:use
#:cl
+ #:iterate
#:sketch
#:mazes.quickutils)
(:export
@@ -27,21 +28,27 @@
#:set-empty-p
#:hash-set
#:set-clear
- #:%))
+ #:%)
+ (:shadowing-import-from #:iterate
+ #:in))
(defpackage #:mazes.fps
(:use
#:cl
+ #:iterate
#:sketch
#:mazes.quickutils
#:mazes.utils)
(:export
#:with-fps
- #:draw-fps))
+ #:draw-fps)
+ (:shadowing-import-from #:iterate
+ #:in))
(defpackage #:mazes.grid
(:use
#:cl
+ #:iterate
#:mazes.quickutils
#:mazes.utils)
(:export
@@ -56,6 +63,8 @@
#:cell-linked-west-p
#:cell-neighbors
#:cell-random-neighbor
+ #:cell-random-unlinked-neighbor
+ #:cell-random-linked-neighbor
#:cell-north
#:cell-south
#:cell-east
@@ -90,6 +99,7 @@
(defpackage #:mazes.generation
(:use
#:cl
+ #:iterate
#:mazes.quickutils
#:mazes.utils
#:mazes.grid)
@@ -101,7 +111,9 @@
#:aldous-broder
#:aldous-broder-generator
#:wilson
- #:wilson-generator)
+ #:wilson-generator
+ #:hunt-and-kill
+ #:hunt-and-kill-generator)
(:import-from #:snakes
#:defgenerator
#:do-generator
@@ -111,6 +123,7 @@
(:use
#:cl
#:sketch
+ #:iterate
#:cl-arrows
#:mazes.grid
#:mazes.generation
@@ -118,5 +131,7 @@
#:mazes.utils
#:mazes.fps)
(:import-from #:snakes
- #:do-generator))
+ #:do-generator)
+ (:shadowing-import-from #:iterate
+ #:in))
--- a/quickutils.lisp Sun Jun 26 20:19:20 2016 +0000
+++ b/quickutils.lisp Thu Jun 30 23:23:24 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 :N-GRAMS) :ensure-package T :package "MAZES.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(: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")
@@ -13,23 +13,10 @@
(in-package "MAZES.QUICKUTILS")
(when (boundp '*utilities*)
- (setf *utilities* (union *utilities* '(:UNTIL :WHILE :STRING-DESIGNATOR
- :WITH-GENSYMS :MAKE-GENSYM-LIST
- :ONCE-ONLY :ENSURE-FUNCTION :CURRY
- :RCURRY :TAKE :N-GRAMS))))
-
- (defmacro until (expression &body body)
- "Executes `body` until `expression` is true."
- `(do ()
- (,expression)
- ,@body))
-
-
- (defmacro while (expression &body body)
- "Executes `body` while `expression` is true."
- `(until (not ,expression)
- ,@body))
-
+ (setf *utilities* (union *utilities* '(:STRING-DESIGNATOR :WITH-GENSYMS
+ :MAKE-GENSYM-LIST :ONCE-ONLY
+ :ENSURE-FUNCTION :CURRY :RCURRY :TAKE
+ :N-GRAMS))))
(deftype string-designator ()
"A string designator type. A string designator is either a string, a symbol,
@@ -188,6 +175,6 @@
:collect (subseq sequence i (+ i n))))))
(eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(while with-gensyms with-unique-names once-only curry rcurry n-grams)))
+ (export '(with-gensyms with-unique-names once-only curry rcurry n-grams)))
;;;; END OF quickutils.lisp ;;;;
--- a/src/demo.lisp Sun Jun 26 20:19:20 2016 +0000
+++ b/src/demo.lisp Thu Jun 30 23:23:24 2016 +0000
@@ -148,7 +148,7 @@
(frame 0)
(log " ")
;; Variables
- (grid (make-grid 15 15))
+ (grid (make-grid 20 20))
(gen (funcall *generator* grid))
(finished-generating nil)
(distances nil)
@@ -163,16 +163,16 @@
(with-setup
;; Maze
(when (and (not finished-generating)
- (dividesp frame 1))
+ (dividesp frame 4))
(when *instant*
- (while (not (funcall gen))))
+ (iterate (while (not (funcall gen)))))
(when (funcall gen)
(setf finished-generating t
longest-path (find-longest-path grid))))
(draw-maze sketch::instance)
;; UI
(with-font *ui-font*
- (text "algorithm: [a]ldous-broder [b]inary tree [s]idewinder [w]ilson"
+ (text "algorithm: [a]ldous-broder [b]inary tree [h]unt and kill [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)))
@@ -285,6 +285,7 @@
(:scancode-b (setf *generator* 'binary-tree-generator))
(:scancode-a (setf *generator* 'aldous-broder-generator))
(:scancode-w (setf *generator* 'wilson-generator))
+ (:scancode-h (setf *generator* 'hunt-and-kill-generator))
(:scancode-l (if *shift*
(zap% *show-longest* #'not %)
nil))
--- a/src/generation.lisp Sun Jun 26 20:19:20 2016 +0000
+++ b/src/generation.lisp Thu Jun 30 23:23:24 2016 +0000
@@ -1,17 +1,21 @@
(in-package #:mazes.generation)
-(defmacro with-cell-active (cell &body body)
+(defmacro with-cell-active ((cell &rest options) &body body)
(once-only (cell)
`(prog2
- (setf (cell-active ,cell) t)
+ (progn (setf (cell-active ,cell) t)
+ ,(when (member :mark-group options)
+ `(setf (cell-active-group ,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)))
+ (iterate (for c :in cells)
+ (setf (cell-active-group c) nil)))
(defun set-active-group (cells)
- (loop :for c :in cells :do (setf (cell-active-group c) t)))
+ (iterate (for c :in cells)
+ (setf (cell-active-group c) t)))
(defun reset-active-group (old-cells new-cells)
(clear-active-group old-cells)
@@ -28,7 +32,7 @@
(defgenerator binary-tree-generator (grid)
(grid-loop-cells cell grid
- (with-cell-active cell
+ (with-cell-active (cell)
(let ((other (random-elt (full-list (cell-north cell)
(cell-east cell)))))
(when other
@@ -54,30 +58,29 @@
(defgenerator sidewinder-generator (grid)
(grid-loop-rows row grid
- (loop :with run = nil
- :for cell :across row
- :for at-east-bound = (null (cell-east cell))
- :for at-north-bound = (null (cell-north cell))
- :for should-close = (or at-east-bound
- (and (not at-north-bound)
- (randomp)))
- :do
- (with-cell-active cell
- (setf (cell-active-group cell) t)
- (push cell run)
- (if should-close
- (let* ((member (random-elt run))
- (member-north (cell-north member)))
- (when member-north
- (setf (cell-active member) t)
- (cell-link member member-north))
- (yield)
- (setf (cell-active member) nil)
- (clear-active-group run)
- (setf run nil))
- (progn
- (cell-link cell (cell-east cell))
- (yield)))))))
+ (iterate
+ (with run = nil)
+ (for cell :in-vector row)
+ (for at-east-bound = (null (cell-east cell)))
+ (for at-north-bound = (null (cell-north cell)))
+ (for should-close = (or at-east-bound
+ (and (not at-north-bound)
+ (randomp))))
+ (with-cell-active (cell :mark-group)
+ (push cell run)
+ (if should-close
+ (let* ((member (random-elt run))
+ (member-north (cell-north member)))
+ (when member-north
+ (with-cell-active (member-north)
+ (cell-link member member-north)
+ (yield)))
+ (yield)
+ (clear-active-group run)
+ (setf run nil))
+ (progn
+ (cell-link cell (cell-east cell))
+ (yield)))))))
(defun sidewinder (grid)
(do-generator (_ (sidewinder-generator grid)))
@@ -94,15 +97,15 @@
(defgenerator aldous-broder-generator (grid)
(let ((cell (grid-random-cell grid))
(unvisited (1- (grid-size grid))))
- (while (plusp unvisited)
- (setf (cell-active-group cell) t)
- (let ((neighbor (random-elt (cell-neighbors cell))))
- (with-cell-active cell
- (when (null (cell-links neighbor))
- (cell-link cell neighbor)
- (decf unvisited))
- (yield))
- (setf cell neighbor))))
+ (iterate (while (plusp unvisited))
+ (setf (cell-active-group cell) t)
+ (let ((neighbor (random-elt (cell-neighbors cell))))
+ (with-cell-active (cell)
+ (when (null (cell-links neighbor))
+ (cell-link cell neighbor)
+ (decf unvisited))
+ (yield))
+ (setf cell neighbor))))
(grid-clear-active grid))
(defun aldous-broder (grid)
@@ -111,39 +114,83 @@
;;;; Wilson
+;;; Wilson's algorithm works by initializing one random cell to be visited, then
+;;; starting at some *other* random cell and walking randomly. Once the path
+;;; hits the visited cell, it is linked together and another random unvisited
+;;; cell is chosed.
;;;
+;;; If a loop in the path is formed before the path manages to hit a visited
+;;; cell, the loop is "erased" and the walk restarts from the looping point.
(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)))
+ (iterate
+ (with unvisited = (make-set :initial-data (grid-map-cells #'identity grid)))
+ (initially (setf (cell-active-group (set-pop unvisited)) t))
+ (with path = nil)
+ (with cell = (set-random unvisited))
+ (while cell)
+ (with-cell-active (cell :mark-group)
+ (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)))
+ ;; 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))))
+ ;; Otherwise keep going
+ (t
+ (setf cell (cell-random-neighbor cell)))))
+ (yield)))
(grid-clear-active grid))
(defun wilson (grid)
(do-generator (_ (wilson-generator grid)))
grid)
+
+
+;;;; Hunt and Kill
+;;;
+
+(defgenerator hunt-and-kill-generator (grid)
+ (labels ((visited-p (cell)
+ (not (null (cell-links cell))))
+ (random-visited-neighbor (cell)
+ (random-elt (remove-if-not #'visited-p (cell-neighbors cell))))
+ (random-unvisited-neighbor (cell)
+ (random-elt (remove-if #'visited-p (cell-neighbors cell))))
+ (hunt ()
+ (grid-loop-cells cell grid
+ (when (and (not (visited-p cell))
+ (some #'visited-p (cell-neighbors cell)))
+ (return cell)))))
+ (iterate
+ (with cell = (grid-ref grid 0 0))
+ (initially (setf (cell-active-group cell) t))
+ (for next = (random-unvisited-neighbor cell))
+ (if next
+ (with-cell-active (next :mark-group)
+ (cell-link cell next)
+ (setf cell next)
+ (yield))
+ (let ((new-cell (hunt)))
+ (if (null new-cell)
+ (finish)
+ (with-cell-active (new-cell :mark-group)
+ (cell-link new-cell (random-visited-neighbor new-cell))
+ (setf cell new-cell)
+ (yield)))))))
+ (grid-clear-active grid))
+
+(defun hunt-and-kill (grid)
+ (do-generator (_ (hunt-and-kill-generator grid)))
+ grid)
--- a/src/grid.lisp Sun Jun 26 20:19:20 2016 +0000
+++ b/src/grid.lisp Thu Jun 30 23:23:24 2016 +0000
@@ -56,6 +56,13 @@
(defun cell-random-neighbor (cell)
(random-elt (cell-neighbors cell)))
+(defun cell-random-unlinked-neighbor (cell)
+ (random-elt (set-difference (cell-neighbors cell)
+ (cell-links cell))))
+
+(defun cell-random-linked-neighbor (cell)
+ (random-elt (cell-links cell)))
+
(defmethod print-object ((cell cell) stream)
(print-unreadable-object (cell stream :type t :identity nil)