# HG changeset patch # User Steve Losh # Date 1464805079 0 # Node ID f3924e639076affcf6a2a7305f8de1072bf18dd5 # Parent b85b00c1aff0349fc19497f8e2bfb1efc343f182 Add solving UI diff -r b85b00c1aff0 -r f3924e639076 make-quickutils.lisp --- a/make-quickutils.lisp Wed Jun 01 17:32:40 2016 +0000 +++ b/make-quickutils.lisp Wed Jun 01 18:17:59 2016 +0000 @@ -10,8 +10,8 @@ :with-gensyms :once-only ; :iota - ; :curry - ; :rcurry + :curry + :rcurry ; :compose ; :n-grams ) diff -r b85b00c1aff0 -r f3924e639076 package.lisp --- a/package.lisp Wed Jun 01 17:32:40 2016 +0000 +++ b/package.lisp Wed Jun 01 18:17:59 2016 +0000 @@ -10,6 +10,8 @@ #:randomp #:zap% #:full-list + #:smallest + #:largest #:%)) (defpackage #:mazes.fps @@ -61,7 +63,8 @@ #:make-dm #:dm-distance #:dm-cells - #:cell-distance-map)) + #:cell-distance-map + #:dijkstra)) (defpackage #:mazes.generation (:use diff -r b85b00c1aff0 -r f3924e639076 quickutils.lisp --- a/quickutils.lisp Wed Jun 01 17:32:40 2016 +0000 +++ b/quickutils.lisp Wed Jun 01 18:17:59 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) :ensure-package T :package "MAZES.QUICKUTILS") +;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:WHILE :WITH-GENSYMS :ONCE-ONLY :CURRY :RCURRY) :ensure-package T :package "MAZES.QUICKUTILS") (eval-when (:compile-toplevel :load-toplevel :execute) (unless (find-package "MAZES.QUICKUTILS") @@ -15,7 +15,8 @@ (when (boundp '*utilities*) (setf *utilities* (union *utilities* '(:UNTIL :WHILE :STRING-DESIGNATOR :WITH-GENSYMS :MAKE-GENSYM-LIST - :ONCE-ONLY)))) + :ONCE-ONLY :ENSURE-FUNCTION :CURRY + :RCURRY)))) (defmacro until (expression &body body) "Executes `body` until `expression` is true." @@ -121,6 +122,51 @@ ,@forms))))) (eval-when (:compile-toplevel :load-toplevel :execute) - (export '(while with-gensyms with-unique-names once-only))) + ;;; To propagate return type and allow the compiler to eliminate the IF when + ;;; it is known if the argument is function or not. + (declaim (inline ensure-function)) + + (declaim (ftype (function (t) (values function &optional)) + ensure-function)) + (defun ensure-function (function-designator) + "Returns the function designated by `function-designator`: +if `function-designator` is a function, it is returned, otherwise +it must be a function name and its `fdefinition` is returned." + (if (functionp function-designator) + function-designator + (fdefinition function-designator))) + ) ; eval-when + + (defun curry (function &rest arguments) + "Returns a function that applies `arguments` and the arguments +it is called with to `function`." + (declare (optimize (speed 3) (safety 1) (debug 1))) + (let ((fn (ensure-function function))) + (lambda (&rest more) + (declare (dynamic-extent more)) + ;; Using M-V-C we don't need to append the arguments. + (multiple-value-call fn (values-list arguments) (values-list more))))) + + (define-compiler-macro curry (function &rest arguments) + (let ((curries (make-gensym-list (length arguments) "CURRY")) + (fun (gensym "FUN"))) + `(let ((,fun (ensure-function ,function)) + ,@(mapcar #'list curries arguments)) + (declare (optimize (speed 3) (safety 1) (debug 1))) + (lambda (&rest more) + (apply ,fun ,@curries more))))) + + + (defun rcurry (function &rest arguments) + "Returns a function that applies the arguments it is called +with and `arguments` to `function`." + (declare (optimize (speed 3) (safety 1) (debug 1))) + (let ((fn (ensure-function function))) + (lambda (&rest more) + (declare (dynamic-extent more)) + (multiple-value-call fn (values-list more) (values-list arguments))))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (export '(while with-gensyms with-unique-names once-only curry rcurry))) ;;;; END OF quickutils.lisp ;;;; diff -r b85b00c1aff0 -r f3924e639076 src/demo.lisp --- a/src/demo.lisp Wed Jun 01 17:32:40 2016 +0000 +++ b/src/demo.lisp Wed Jun 01 18:17:59 2016 +0000 @@ -40,30 +40,45 @@ (defparameter *wall-pen* (make-pen :weight 3 :stroke (rgb 0.625 0.423 0.399))) -(defun draw-maze (grid distances) +(defparameter *path-pen* + (make-pen :fill (rgb 0.314 0.235 0.325))) + +(defparameter *end-pen* + (make-pen :fill (rgb 0.429 0.321 0.445))) + + +(defun draw-maze (grid start end path) (let ((cell-size (cell-size 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))))) - (when distances - (text (princ-to-string (dm-distance distances cell)) - (+ 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))))))))) + (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)) + (with-pen *path-pen* + (map nil #'draw-cell path)) + (with-pen *end-pen* + (when start (draw-cell start)) + (when end (draw-cell end))) + (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-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)))))))))) (defsketch demo ((width *width*) (height *height*) (y-axis :down) (title "Mazes") @@ -71,15 +86,18 @@ (frame 0) (log " ") ;; Variables - (grid (make-grid 10 10)) + (grid (make-grid 20 20)) (gen (sidewinder-generator grid)) (distances nil) + (path nil) + (start nil) + (end nil) ;; Pens (log-font (make-font :color (gray 0.8))) ) (with-setup ;; - (draw-maze grid distances) + (draw-maze grid start end path) (if (dividesp frame 1) (funcall gen)) ;; @@ -118,14 +136,25 @@ (defun mousedown-left (instance x y) (declare (ignorable instance x y)) (multiple-value-bind (row col) (cell-clicked instance x y) - (when row - (with-slots (distances grid) instance - (setf distances - (cell-distance-map (grid-ref grid row col))))))) + (with-slots (end grid distances path) instance + (when (and row col distances) + (setf end + (grid-ref grid row col) + path + (dijkstra distances end)))))) (defun mousedown-right (instance x y) (declare (ignorable instance x y)) - ) + (multiple-value-bind (row col) (cell-clicked instance x y) + (when row + (with-slots (start distances grid end path) instance + (setf distances + (cell-distance-map (grid-ref grid row col)) + start + (grid-ref grid row col) + end nil + path nil + ))))) (defun mouseup-left (instance x y) (declare (ignorable instance x y)) diff -r b85b00c1aff0 -r f3924e639076 src/grid.lisp --- a/src/grid.lisp Wed Jun 01 17:32:40 2016 +0000 +++ b/src/grid.lisp Wed Jun 01 18:17:59 2016 +0000 @@ -203,3 +203,18 @@ linked))) :while frontier :finally (return dm))) + + +;;;; Path Finding +(defun dijkstra (distances target) + (let ((root (dm-root distances))) + (labels + ((recur (cell path) + (when cell + (if (eql cell root) + (cons root path) + (recur + (smallest (cell-links cell) + :key (curry #'dm-distance distances)) + (cons cell path)))))) + (recur target nil)))) diff -r b85b00c1aff0 -r f3924e639076 src/utils.lisp --- a/src/utils.lisp Wed Jun 01 17:32:40 2016 +0000 +++ b/src/utils.lisp Wed Jun 01 18:17:59 2016 +0000 @@ -50,3 +50,9 @@ (defun full-list (&rest args) (remove-if #'null args)) + +(defun smallest (list &key (key #'identity)) + (first (sort (copy-list list) #'< :key key))) + +(defun largest (list &key (key #'identity)) + (first (sort (copy-list list) #'> :key key)))