# HG changeset patch # User Steve Losh # Date 1464188253 0 # Node ID efe822c4468f53c0b1fb6e522cead5a218080c72 # Parent 155ad4c670c8cd5dc11eb76b81407f226dd323c9 Add Dijkstra's algorithm diff -r 155ad4c670c8 -r efe822c4468f make-quickutils.lisp --- 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 diff -r 155ad4c670c8 -r efe822c4468f package.lisp --- 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 diff -r 155ad4c670c8 -r efe822c4468f quickutils.lisp --- 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 ;;;; diff -r 155ad4c670c8 -r efe822c4468f src/demo.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) )) diff -r 155ad4c670c8 -r efe822c4468f src/grid.lisp --- 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)))