--- a/make-quickutils.lisp Sun May 22 22:20:29 2016 +0000
+++ b/make-quickutils.lisp Wed May 25 14:57:33 2016 +0000
@@ -5,7 +5,7 @@
:utilities '(
; :define-constant
; :switch
- ; :while
+ :while
; :ensure-boolean
:with-gensyms
:once-only
--- a/package.lisp Sun May 22 22:20:29 2016 +0000
+++ b/package.lisp Wed May 25 14:57:33 2016 +0000
@@ -56,7 +56,12 @@
#:grid-loop-cells
#:grid-loop-rows
#:grid-size
- #:grid-random-cell))
+ #:grid-random-cell
+ #:distance-map
+ #:make-dm
+ #:dm-distance
+ #:dm-cells
+ #:cell-distance-map))
(defpackage #:mazes.generation
(:use
--- a/quickutils.lisp Sun May 22 22:20:29 2016 +0000
+++ b/quickutils.lisp Wed May 25 14:57:33 2016 +0000
@@ -2,7 +2,7 @@
;;;; See http://quickutil.org for details.
;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:WITH-GENSYMS :ONCE-ONLY) :ensure-package T :package "MAZES.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:WHILE :WITH-GENSYMS :ONCE-ONLY) :ensure-package T :package "MAZES.QUICKUTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "MAZES.QUICKUTILS")
@@ -13,8 +13,22 @@
(in-package "MAZES.QUICKUTILS")
(when (boundp '*utilities*)
- (setf *utilities* (union *utilities* '(:STRING-DESIGNATOR :WITH-GENSYMS
- :MAKE-GENSYM-LIST :ONCE-ONLY))))
+ (setf *utilities* (union *utilities* '(:UNTIL :WHILE :STRING-DESIGNATOR
+ :WITH-GENSYMS :MAKE-GENSYM-LIST
+ :ONCE-ONLY))))
+
+ (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))
+
(deftype string-designator ()
"A string designator type. A string designator is either a string, a symbol,
@@ -107,6 +121,6 @@
,@forms)))))
(eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(with-gensyms with-unique-names once-only)))
+ (export '(while with-gensyms with-unique-names once-only)))
;;;; END OF quickutils.lisp ;;;;
--- a/src/demo.lisp Sun May 22 22:20:29 2016 +0000
+++ b/src/demo.lisp Wed May 25 14:57:33 2016 +0000
@@ -34,41 +34,48 @@
(defparameter *wall-pen*
(make-pen :weight 3 :stroke (rgb 0.625 0.423 0.399)))
-(defun draw-maze (grid cell-size)
- (in-context
- (translate (/ (* (grid-cols grid) cell-size) -2)
- (/ (* (grid-rows grid) cell-size) -2))
- (with-pen *wall-pen*
- (grid-loop-cells cell grid
- (let ((x1 (* cell-size (cell-col cell)))
- (y1 (* cell-size (cell-row cell)))
- (x2 (* cell-size (1+ (cell-col cell))))
- (y2 (* cell-size (1+ (cell-row cell)))))
- (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)))))))
+(defun draw-maze (grid distances)
+ (let ((cell-size (truncate (/ 700
+ (max (grid-cols grid)
+ (grid-rows grid))))))
+ (in-context
+ (translate (/ (* (grid-cols grid) cell-size) -2)
+ (/ (* (grid-rows grid) cell-size) -2))
+ (with-pen *wall-pen*
+ (with-font (make-font :color (rgb 0.314 0.235 0.325)
+ :size 20)
+ (grid-loop-cells cell grid
+ (let ((x1 (* cell-size (cell-col cell)))
+ (y1 (* cell-size (cell-row cell)))
+ (x2 (* cell-size (1+ (cell-col cell))))
+ (y2 (* cell-size (1+ (cell-row cell))))
+ (dist (dm-distance distances cell)))
+ (when dist
+ (text (princ-to-string dist) (+ 5 x1) (+ 0 y1)))
+ (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)))))))))
(defsketch demo
((width *width*) (height *height*) (y-axis :down) (title "Mazes")
(mouse (cons 0 0))
(frame 0)
;; Variables
- (maze (make-grid 25 25))
- (gen (sidewinder-generator maze))
+ (maze (make-grid 10 10))
+ (gen (sidewinder maze))
+ (distances (cell-distance-map (grid-ref maze 0 0)))
;; Pens
- (simple-pen (make-pen :fill (gray 0.1)))
- (line-pen (make-pen :stroke (gray 0.1) :weight 1))
)
(with-setup
;;
- (draw-maze maze 20)
- (if (dividesp frame 2)
- (funcall gen))
+ (draw-maze maze distances)
+ ; (if (dividesp frame 2)
+ ; (funcall gen))
;;
(incf frame)
))
--- a/src/grid.lisp Sun May 22 22:20:29 2016 +0000
+++ b/src/grid.lisp Wed May 25 14:57:33 2016 +0000
@@ -163,3 +163,43 @@
:do (setf top (cl-strings:insert cell-top top)
bottom (cl-strings:insert cell-bot bottom)))
(format stream "~A~%~A~%" top bottom)))))
+
+
+;;;; Distance Map
+(defclass distance-map ()
+ ((root :initarg :root :accessor dm-root)
+ (distances :initarg :distances :accessor dm-distances)))
+
+
+(defun make-dm (root)
+ (let ((dm (make-instance 'distance-map
+ :root root
+ :distances (make-hash-table))))
+ (setf (gethash root (dm-distances dm)) 0)
+ dm))
+
+
+(defun dm-distance (dm cell)
+ (gethash cell (dm-distances dm)))
+
+(defun (setf dm-distance) (new-value dm cell)
+ (setf (gethash cell (dm-distances dm)) new-value))
+
+(defun dm-cells (dm)
+ (loop :for cell :being :the hash-keys :of dm :collect cell))
+
+
+(defun cell-distance-map (cell)
+ (loop :with dm = (make-dm cell)
+ :for frontier = (list cell)
+ :then (loop :for cell :in frontier
+ :for dist = (dm-distance dm cell)
+ :append
+ (loop :for linked :in (cell-links cell)
+ :when (not (dm-distance dm linked))
+ :collect
+ (progn
+ (setf (dm-distance dm linked) (1+ dist))
+ linked)))
+ :while frontier
+ :finally (return dm)))