--- a/DOCUMENTATION.markdown Tue Dec 14 19:12:33 2021 -0500
+++ b/DOCUMENTATION.markdown Fri Aug 05 00:04:27 2022 -0400
@@ -18,6 +18,56 @@
+## Package `LOSH.ASTAR`
+
+A★ search in a handy package.
+
+### `ASTAR` (function)
+
+ (ASTAR &KEY START NEIGHBORS GOALP COST HEURISTIC TEST LIMIT GET-SEEN SET-SEEN)
+
+Search for a path from `start` to a goal using A★.
+
+ The following parameters are all required:
+
+ * `start`: the starting state.
+
+ * `neighbors`: a function that takes a state and returns all states reachable
+ from it.
+
+ * `goalp`: a predicate that takes a state and returns whether it is a goal.
+
+ * `cost`: a function that takes two states `a` and `b` and returns the cost
+ to move from `a` to `b`.
+
+ * `heuristic`: a function that takes a state and estimates the distance
+ remaining to the goal.
+
+ * `test`: an equality predicate for comparing nodes. It must be suitable for
+ passing to `make-hash-table`.
+
+ If the heuristic function is admissable (i.e. it never overestimates the
+ remaining distance) the algorithm will find the shortest path. If you don't
+ have a decent heuristic, just use `(constantly 0)` to degrade to Dijkstra.
+
+ Note that `test` is required. The only sensible default would be `eql`, but
+ if you were using states that need a different predicate and forgot to pass it
+ the algorithm would end up blowing the heap, which is unpleasant.
+
+ The following parameters are optional:
+
+ * `limit`: a maximum cost. Any paths that exceed this cost will not be
+ considered.
+
+ * `set-seen`: a function that takes a state and a cost, and records it.
+ If not provided a hash table will be used, but sometimes (depending on what
+ your states are) it can be faster to store visited nodes more efficiently.
+
+ * `get-seen`: a function that takes a state and retrieves the stored cost, or
+ `nil` if the state has not been seen.
+
+
+
## Package `LOSH.ARRAYS`
Utilities related to arrays.
@@ -381,13 +431,14 @@
i.e. anything that can handle `(read-foo stream eof-error-p eof-value)`.
Any keyword arguments other than `:reader` will be passed along to `open`.
+
If `nil` is used for one of the `:if-…` options to `open` and this results
in `open` returning `nil`, no iteration will take place.
An implicit block named `nil` surrounds the iteration, so `return` can be
used to terminate early.
- Returns `nil` by default.
+ Returns `nil`.
Examples:
@@ -2217,10 +2268,10 @@
`predicate-spec` can be one of:
+ * A quoted symbol.
* `(function ...)`
* `(lambda ...)`
- * A list of `(predicate &key key)`.
- * Any other object, which will be treated as a predicate.
+ * A list of `(predicate &key key)`, where `predicate` is any of the above.
If a `key` is specified, it will be called on arguments before passing them to
`predicate`. Note that the `key` only affects the predicate it's consed to,
@@ -2232,7 +2283,7 @@
;; Sort shorter strings first, breaking ties lexicographically:
(define-sorting-predicate fancy<
- (#< :key #'length)
+ (#'< :key #'length)
#'string<)
(sort (list "zz" "abc" "yy") #'fancy<)
@@ -2240,9 +2291,9 @@
;; Sort customers by last name, then first name, then ID number:
(define-sorting-predicate customer<
- (#string< :key #'last-name)
- (#string< :key #'first-name)
- (#< :key #'id))
+ (#'string< :key #'last-name)
+ (#'string< :key #'first-name)
+ (#'< :key #'id))
(sort (find-customers) #'customer<)
--- a/losh.asd Tue Dec 14 19:12:33 2021 -0500
+++ b/losh.asd Fri Aug 05 00:04:27 2022 -0400
@@ -9,12 +9,17 @@
:in-order-to ((asdf:test-op (asdf:test-op :losh/test)))
- :depends-on (:alexandria
- :iterate
+ :depends-on (
+
+ #+sbcl :sb-sprof
+ :alexandria
:cl-ppcre
:external-program
:flexi-streams
- #+sbcl :sb-sprof)
+ :iterate
+ :pileup
+
+ )
:components
((:module "src"
@@ -47,6 +52,8 @@
(:file "control-flow" :depends-on ("queues"))
;; 3 ---------------------------------------------------------
+ (:file "astar" :depends-on ("control-flow"
+ "chili-dogs"))
(:file "iterate" :depends-on ("control-flow"
"hash-sets"))
(:file "math" :depends-on ("control-flow"
--- a/make-docs.lisp Tue Dec 14 19:12:33 2021 -0500
+++ b/make-docs.lisp Fri Aug 05 00:04:27 2022 -0400
@@ -3,6 +3,7 @@
(defparameter *document-packages*
(list "LOSH"
+ "LOSH.ASTAR"
"LOSH.ARRAYS"
"LOSH.BASE"
"LOSH.BITS"
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/astar.lisp Fri Aug 05 00:04:27 2022 -0400
@@ -0,0 +1,96 @@
+(in-package :losh.astar)
+
+(defstruct path
+ state
+ (estimate 0)
+ (cost 0)
+ (previous nil))
+
+(defun path-to-list (path &aux result)
+ (recursively ((path path))
+ (unless (null path)
+ (push (path-state path) result)
+ (recur (path-previous path))))
+ result)
+
+(defun-inlineable astar (&key start neighbors goalp cost heuristic test limit
+ get-seen set-seen)
+ "Search for a path from `start` to a goal using A★.
+
+ The following parameters are all required:
+
+ * `start`: the starting state.
+
+ * `neighbors`: a function that takes a state and returns all states reachable
+ from it.
+
+ * `goalp`: a predicate that takes a state and returns whether it is a goal.
+
+ * `cost`: a function that takes two states `a` and `b` and returns the cost
+ to move from `a` to `b`.
+
+ * `heuristic`: a function that takes a state and estimates the distance
+ remaining to the goal.
+
+ * `test`: an equality predicate for comparing nodes. It must be suitable for
+ passing to `make-hash-table`.
+
+ If the heuristic function is admissable (i.e. it never overestimates the
+ remaining distance) the algorithm will find the shortest path. If you don't
+ have a decent heuristic, just use `(constantly 0)` to degrade to Dijkstra.
+
+ Note that `test` is required. The only sensible default would be `eql`, but
+ if you were using states that need a different predicate and forgot to pass it
+ the algorithm would end up blowing the heap, which is unpleasant.
+
+ The following parameters are optional:
+
+ * `limit`: a maximum cost. Any paths that exceed this cost will not be
+ considered.
+
+ * `set-seen`: a function that takes a state and a cost, and records it.
+ If not provided a hash table will be used, but sometimes (depending on what
+ your states are) it can be faster to store visited nodes more efficiently.
+
+ * `get-seen`: a function that takes a state and retrieves the stored cost, or
+ `nil` if the state has not been seen.
+
+ "
+ (let ((seen (unless get-seen (make-hash-table :test test)))
+ (frontier (pileup:make-heap #'< :key #'path-estimate)))
+ (labels ((set-seen% (path)
+ (if set-seen
+ (funcall set-seen (path-state path) (path-cost path))
+ (setf (gethash (path-state path) seen) (path-cost path))))
+ (get-seen% (state)
+ (if get-seen
+ (funcall get-seen state)
+ (gethash state seen)))
+ (push-path (path)
+ (set-seen% path)
+ (pileup:heap-insert path frontier)))
+ (iterate
+ (initially (push-path (make-path :state start)))
+
+ (for (values current found) = (pileup:heap-pop frontier))
+ (unless found
+ (return (values nil nil)))
+
+ (for current-state = (path-state current))
+
+ (when (funcall goalp current-state)
+ (return (values (path-to-list current) t)))
+
+ (for current-cost = (path-cost current))
+
+ (iterate
+ (for next-state :in (funcall neighbors current-state))
+ (for next-cost = (+ current-cost (funcall cost current-state next-state)))
+ (for seen-cost = (get-seen% next-state))
+ (unless (and limit (> next-cost limit))
+ (when (or (null seen-cost) (< next-cost seen-cost))
+ (for next-estimate = (+ next-cost (funcall heuristic next-state)))
+ (push-path (make-path :state next-state
+ :cost next-cost
+ :estimate next-estimate
+ :previous current)))))))))
--- a/src/control-flow.lisp Tue Dec 14 19:12:33 2021 -0500
+++ b/src/control-flow.lisp Fri Aug 05 00:04:27 2022 -0400
@@ -548,13 +548,14 @@
i.e. anything that can handle `(read-foo stream eof-error-p eof-value)`.
Any keyword arguments other than `:reader` will be passed along to `open`.
+
If `nil` is used for one of the `:if-…` options to `open` and this results
in `open` returning `nil`, no iteration will take place.
An implicit block named `nil` surrounds the iteration, so `return` can be
used to terminate early.
- Returns `nil` by default.
+ Returns `nil`.
Examples:
--- a/src/package.lisp Tue Dec 14 19:12:33 2021 -0500
+++ b/src/package.lisp Fri Aug 05 00:04:27 2022 -0400
@@ -247,6 +247,14 @@
:do-vector))
+(defpackage :losh.astar
+ (:use :cl :iterate :losh.base
+ :losh.chili-dogs
+ :losh.control-flow)
+ (:documentation "A★ search in a handy package.")
+ (:export
+ :astar))
+
(defpackage :losh.math
(:use :cl :iterate :losh.base
:losh.chili-dogs
@@ -459,6 +467,7 @@
:losh.base
:losh.arrays
+ :losh.astar
:losh.bits
:losh.chili-dogs
:losh.clos
--- a/src/sequences.lisp Tue Dec 14 19:12:33 2021 -0500
+++ b/src/sequences.lisp Fri Aug 05 00:04:27 2022 -0400
@@ -462,10 +462,10 @@
`predicate-spec` can be one of:
+ * A quoted symbol.
* `(function ...)`
* `(lambda ...)`
- * A list of `(predicate &key key)`.
- * Any other object, which will be treated as a predicate.
+ * A list of `(predicate &key key)`, where `predicate` is any of the above.
If a `key` is specified, it will be called on arguments before passing them to
`predicate`. Note that the `key` only affects the predicate it's consed to,
@@ -477,7 +477,7 @@
;; Sort shorter strings first, breaking ties lexicographically:
(define-sorting-predicate fancy<
- (#\< :key #'length)
+ (#'< :key #'length)
#'string<)
(sort (list \"zz\" \"abc\" \"yy\") #'fancy<)
@@ -485,43 +485,38 @@
;; Sort customers by last name, then first name, then ID number:
(define-sorting-predicate customer<
- (#\string< :key #'last-name)
- (#\string< :key #'first-name)
- (#\< :key #'id))
+ (#'string< :key #'last-name)
+ (#'string< :key #'first-name)
+ (#'< :key #'id))
(sort (find-customers) #'customer<)
"
- (with-gensyms (x y kx ky)
- (labels
- ((parse-spec (spec)
- (if (consp spec)
- (if (member (first spec) '(function lambda))
- (values spec nil)
- (destructuring-bind (predicate &key key) spec
- (values predicate key)))
- (values spec nil)))
- (expand (spec more-specs)
- (multiple-value-bind (predicate key) (parse-spec spec)
- (once-only (predicate)
- (if (null more-specs)
- `(if ,(if key
- (once-only (key)
- `(funcall ,predicate (funcall ,key ,x) (funcall ,key ,y)))
- `(funcall ,predicate ,x ,y))
- t
- nil)
- (if key
- (once-only (key)
- `(let ((,kx (funcall ,key ,x))
- (,ky (funcall ,key ,y)))
- (cond
- ((funcall ,predicate ,kx ,ky) t)
- ((funcall ,predicate ,ky ,kx) nil)
- (t ,(expand (first more-specs) (rest more-specs))))))
- `(cond
- ((funcall ,predicate ,x ,y) t)
- ((funcall ,predicate ,y ,x) nil)
- (t ,(expand (first more-specs) (rest more-specs))))))))))
+ (with-gensyms (x y)
+ (labels ((parse-spec (spec)
+ "Parse `spec` and return the predicate and key as values."
+ (if (consp spec)
+ (if (member (first spec) '(function lambda quote))
+ (values spec '#'identity)
+ (destructuring-bind (predicate &key (key '#'identity)) spec
+ (values predicate key)))
+ (values spec '#'identity)))
+ (expand (specs)
+ "Expand `specs` into the body code of the new predicate."
+ (destructuring-bind (spec . remaining) specs
+ (multiple-value-bind (predicate key) (parse-spec spec)
+ (once-only (predicate key)
+ (with-gensyms (kx ky)
+ `(let ((,kx (funcall ,key ,x))
+ (,ky (funcall ,key ,y)))
+ ,(if (null remaining)
+ `(if (funcall ,predicate ,kx ,ky)
+ t
+ nil)
+ `(cond
+ ((funcall ,predicate ,kx ,ky) t)
+ ((funcall ,predicate ,ky ,kx) nil)
+ (t ,(expand remaining)))))))))))
`(defun ,name (,x ,y)
- ,(expand predicate-spec more-predicate-specs)))))
+ ,(expand (cons predicate-spec more-predicate-specs))))))
+
--- a/test/sequences.lisp Tue Dec 14 19:12:33 2021 -0500
+++ b/test/sequences.lisp Fri Aug 05 00:04:27 2022 -0400
@@ -62,6 +62,11 @@
(#'< :key #'length)
#'string<)
+(define-sorting-predicate sort-fancy-quoted<
+ ('char< :key (lambda (s) (char s (1- (length s)))))
+ ('< :key #'length)
+ 'string<)
+
(define-test define-sorting-predicate
(flet ((check (original expected pred)
(let ((actual (sort (copy-seq original) pred)))
@@ -80,7 +85,10 @@
#'sort-last-char<)
(check '("az" "by" "aby" "zzy")
'("by" "aby" "zzy" "az")
- #'sort-fancy<)))
+ #'sort-fancy<)
+ (check '("az" "by" "aby" "zzy")
+ '("by" "aby" "zzy" "az")
+ #'sort-fancy-quoted<)))
(defun sortedp (sequence predicate)
;; TODO Should this be a util of its own?