# HG changeset patch # User Steve Losh # Date 1467329004 0 # Node ID 367e393b0992e676c4512386535d4bcef4b775f4 # Parent e897732c9b7137029867b4933500d188e0aa8557 Add the Hunt and Kill algorithm, and try out iterate diff -r e897732c9b71 -r 367e393b0992 make-quickutils.lisp --- 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 diff -r e897732c9b71 -r 367e393b0992 mazes.asd --- 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) diff -r e897732c9b71 -r 367e393b0992 package.lisp --- 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)) diff -r e897732c9b71 -r 367e393b0992 quickutils.lisp --- 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 ;;;; diff -r e897732c9b71 -r 367e393b0992 src/demo.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)) diff -r e897732c9b71 -r 367e393b0992 src/generation.lisp --- 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) diff -r e897732c9b71 -r 367e393b0992 src/grid.lisp --- 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)