--- 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
)
--- 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
--- 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 ;;;;
--- 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))
--- 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))))
--- 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)))