--- a/.lispwords Wed Jun 08 12:30:15 2016 +0000
+++ b/.lispwords Wed Jun 08 13:35:49 2016 +0000
@@ -2,3 +2,5 @@
(1 make-sketch)
(2 grid-loop-cells grid-loop-rows)
(1 recursively)
+(1 with-cell-active)
+(1 when-let)
--- a/package.lisp Wed Jun 08 12:30:15 2016 +0000
+++ b/package.lisp Wed Jun 08 13:35:49 2016 +0000
@@ -12,6 +12,7 @@
#:full-list
#:smallest
#:largest
+ #:when-let
#:recursively
#:recur
#:hash-keys
@@ -51,11 +52,13 @@
#:cell-row
#:cell-active
#:cell-active-group
+ #:cell-links
#:grid
#:grid-cols
#:grid-rows
#:grid-cells
#:grid-ref
+ #:grid-clear-active
#:make-grid
#:grid-size
#:grid-map-cells
@@ -82,7 +85,9 @@
#:binary-tree
#:binary-tree-generator
#:sidewinder
- #:sidewinder-generator)
+ #:sidewinder-generator
+ #:aldous-broder
+ #:aldous-broder-generator)
(:import-from #:snakes
#:defgenerator
#:do-generator
@@ -97,5 +102,7 @@
#:mazes.generation
#:mazes.quickutils
#:mazes.utils
- #:mazes.fps))
+ #:mazes.fps)
+ (:import-from #:snakes
+ #:do-generator))
--- a/src/demo.lisp Wed Jun 08 12:30:15 2016 +0000
+++ b/src/demo.lisp Wed Jun 08 13:35:49 2016 +0000
@@ -9,8 +9,11 @@
(defparameter *center-x* (/ *width* 2))
(defparameter *center-y* (/ *height* 2))
(defparameter *maze-size* 700)
-(defparameter *generator* #'sidewinder-generator)
-
+(defvar *generator* #'sidewinder-generator)
+(defvar *instant* nil)
+(defvar *show-longest* nil)
+(defvar *show-colors* nil)
+(defvar *cell-size* nil)
;;;; Globals
(defvar *shift* nil)
@@ -51,65 +54,85 @@
(make-pen :fill (rgb 1.000 0.733 0.424)))
(defparameter *active-pen*
- (make-pen :fill (rgb 0.731 0.550 0.758)))
+ (make-pen :fill (rgb 1.000 0.273 0.476)))
(defparameter *active-group-pen*
- (make-pen :fill (rgb 0.427 0.322 0.443)))
+ (make-pen :fill (rgb 1.000 0.512 0.580)))
+
+
+(defun cell-x (cell &optional (offset 0))
+ (* *cell-size* (+ offset (cell-col cell))))
+
+(defun cell-y (cell &optional (offset 0))
+ (* *cell-size* (+ offset (cell-row cell))))
+
+(defun draw-cell (cell)
+ (rect (cell-x cell) (cell-y cell) *cell-size* *cell-size*))
+
+
+(defun draw-colors (instance)
+ (when *show-colors*
+ (let* ((grid (slot-value instance 'grid))
+ (distances (cell-distance-map
+ (or (slot-value instance 'start)
+ (grid-ref grid 0 0))))
+ (max (dm-distance distances (dm-max distances))))
+ (when (plusp max)
+ (grid-loop-cells cell grid
+ (when-let (distance (dm-distance distances cell))
+ (with-pen
+ (make-pen :fill (lerp-color
+ (rgb 0.149 0.141 0.212)
+ (rgb 0.570 0.429 0.591)
+ (/ distance max)))
+ (draw-cell cell))))))))
+
+(defun draw-longest (instance)
+ (when *show-longest*
+ (with-pen *longest-pen*
+ (map nil #'draw-cell (slot-value instance 'longest-path)))))
+
+(defun draw-path (instance)
+ (with-slots (start end path) instance
+ (with-pen *path-pen*
+ (map nil #'draw-cell path))
+ (with-pen *end-pen*
+ (when start (draw-cell start))
+ (when end (draw-cell end)))))
+
+(defun draw-active (instance)
+ (grid-loop-cells cell (slot-value instance 'grid)
+ (when (cell-active-group cell)
+ (with-pen *active-group-pen* (draw-cell cell)))
+ (when (cell-active cell)
+ (with-pen *active-pen* (draw-cell cell)))))
(defun draw-maze (instance)
- (with-slots (grid start end path longest-path show-longest show-colors)
- instance
- (let ((cell-size (cell-size grid)))
- (labels ((cell-x (cell &optional (offset 0))
- (* cell-size (+ offset (cell-col cell))))
- (cell-y (cell &optional (offset 0))
- (* cell-size (+ offset (cell-row cell))))
- (draw-cell (cell)
- (rect (cell-x cell) (cell-y cell) cell-size cell-size)))
- (in-context
- (translate (/ (* (grid-cols grid) cell-size) -2)
- (/ (* (grid-rows grid) cell-size) -2))
- (when (and show-colors start)
- (let* ((distances (cell-distance-map start))
- (max (dm-distance distances (dm-max distances))))
- (grid-loop-cells cell grid
- (with-pen
- (make-pen :fill (lerp-color
- (rgb 0.149 0.141 0.212)
- (rgb 0.570 0.429 0.591)
- (/ (dm-distance distances cell) max)))
- (draw-cell cell)))))
- (when show-longest
- (with-pen *longest-pen*
- (map nil #'draw-cell longest-path)))
- (with-pen *path-pen*
- (map nil #'draw-cell path))
- (with-pen *end-pen*
- (when start (draw-cell start))
- (when end (draw-cell end)))
- (grid-loop-cells cell grid
- (with-pen *active-group-pen*
- (when (cell-active-group cell)
- (draw-cell cell)))
- (with-pen *active-pen*
- (when (cell-active cell)
- (draw-cell cell))))
- (with-pen *wall-pen*
- (grid-loop-cells cell grid
- (let ((x1 (cell-x cell))
- (y1 (cell-y cell))
- (x2 (cell-x cell 1))
- (y2 (cell-y cell 1)))
- (when (not (cell-north cell))
- (line x1 y1 x2 y1))
- (when (not (cell-west cell))
- (line x1 y1 x1 y2))
- (when (not (cell-linked-east-p cell))
- (line x2 y1 x2 y2))
- (when (not (cell-linked-south-p cell))
- (line x1 y2 x2 y2))))))))))
+ (with-slots (grid) instance
+ (in-context
+ (translate (/ (* (grid-cols grid) *cell-size*) -2)
+ (/ (* (grid-rows grid) *cell-size*) -2))
+ (draw-colors instance)
+ (draw-longest instance)
+ (draw-path instance)
+ (draw-active instance)
+ (with-pen *wall-pen*
+ (grid-loop-cells cell grid
+ (let ((x1 (cell-x cell))
+ (y1 (cell-y cell))
+ (x2 (cell-x cell 1))
+ (y2 (cell-y cell 1)))
+ (when (not (cell-north cell))
+ (line x1 y1 x2 y1))
+ (when (not (cell-west cell))
+ (line x1 y1 x1 y2))
+ (when (not (cell-linked-east-p cell))
+ (line x2 y1 x2 y2))
+ (when (not (cell-linked-south-p cell))
+ (line x1 y2 x2 y2))))))))
+(defparameter *ui-font* nil)
(defun find-longest-path (grid)
(let ((distances (-> (grid-ref grid 0 0)
@@ -132,24 +155,27 @@
(longest-path nil)
(start nil)
(end nil)
- (show-longest nil)
- (show-colors nil)
- ;; Pens
- (log-font (make-font :color (gray 0.8)))
)
+ ;; Setup
+ (setf *cell-size* (cell-size grid))
+ (setf *ui-font* (make-font :color (gray 0.8) :size 14))
(with-setup
- ;;
- (draw-maze sketch::instance)
- (if (and (not finished-generating)
- (dividesp frame 4))
+ ;; Maze
+ (when (and (not finished-generating)
+ (dividesp frame 5))
+ (when *instant*
+ (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"
+ (+ (- *center-x*) 5) (- *center-y* 40))
+ (text "display: [C]olor distances [L]ongest path [I]nstant generation"
+ (+ (- *center-x*) 5) (- *center-y* 22)))
;;
- (with-font log-font
- (text log
- (- *center-x*)
- (- *center-y* 22)))
(incf frame)
))
@@ -158,14 +184,13 @@
(defun cell-clicked (instance x y)
;; assume a square grid for now...
(with-slots (log grid) instance
- (let* ((cell-size (cell-size grid))
- (offset (/ (- *width* *maze-size*) 2))
+ (let* ((offset (/ (- *width* *maze-size*) 2))
(x (- x offset))
(y (- y offset)))
(if (and (< -1 x *maze-size*)
(< -1 y *maze-size*))
- (values (truncate (/ y cell-size))
- (truncate (/ x cell-size)))
+ (values (truncate (/ y *cell-size*))
+ (truncate (/ x *cell-size*)))
(values nil nil)))))
@@ -257,11 +282,15 @@
;;
(:scancode-s (setf *generator* #'sidewinder-generator))
(:scancode-b (setf *generator* #'binary-tree-generator))
+ (:scancode-a (setf *generator* #'aldous-broder-generator))
(:scancode-l (if *shift*
- (zap% (slot-value instance 'show-longest) #'not %)
+ (zap% *show-longest* #'not %)
nil))
(:scancode-c (if *shift*
- (zap% (slot-value instance 'show-colors) #'not %)
+ (zap% *show-colors* #'not %)
+ nil))
+ (:scancode-i (if *shift*
+ (zap% *instant* #'not %)
nil))
;;
))
--- a/src/generation.lisp Wed Jun 08 12:30:15 2016 +0000
+++ b/src/generation.lisp Wed Jun 08 13:35:49 2016 +0000
@@ -1,5 +1,12 @@
(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)))
+
+
(defgenerator binary-tree-generator (grid)
(grid-loop-cells cell grid
(setf (cell-active cell) t)
@@ -11,7 +18,8 @@
(setf (cell-active cell) nil)))
(defun binary-tree (grid)
- (do-generator (_ (binary-tree-generator grid))))
+ (do-generator (_ (binary-tree-generator grid)))
+ grid)
(defgenerator sidewinder-generator (grid)
@@ -44,4 +52,24 @@
(setf (cell-active cell) nil)))))
(defun sidewinder (grid)
- (do-generator (_ (sidewinder-generator grid))))
+ (do-generator (_ (sidewinder-generator grid)))
+ grid)
+
+
+(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))))
+ (grid-clear-active grid))
+
+(defun aldous-broder (grid)
+ (do-generator (_ (aldous-broder-generator grid)))
+ grid)
--- a/src/grid.lisp Wed Jun 08 12:30:15 2016 +0000
+++ b/src/grid.lisp Wed Jun 08 13:35:49 2016 +0000
@@ -150,6 +150,12 @@
east (grid-ref grid row (1+ col))))))
+(defun grid-clear-active (grid)
+ (grid-loop-cells cell grid
+ (setf (cell-active cell) nil
+ (cell-active-group cell) nil)))
+
+
(defmethod print-object ((grid grid) stream)
(print-unreadable-object
(grid stream :type t :identity nil)
--- a/src/utils.lisp Wed Jun 08 12:30:15 2016 +0000
+++ b/src/utils.lisp Wed Jun 08 13:35:49 2016 +0000
@@ -43,6 +43,11 @@
(values nil nil)
(values (elt seq (random length)) t))))
+(defmacro when-let ((symbol value) &body body)
+ `(let ((,symbol ,value))
+ (when ,symbol ,@body)))
+
+
(defun randomp ()
(zerop (random 2)))