# HG changeset patch # User Steve Losh # Date 1659672267 14400 # Node ID 461876acdff580f15e4c373bf20a03b3c06e1742 # Parent c2970d9e6ea7ac201406df957989e0b928c65f67 Add astar and tweak a few other things diff -r c2970d9e6ea7 -r 461876acdff5 DOCUMENTATION.markdown --- 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<) diff -r c2970d9e6ea7 -r 461876acdff5 losh.asd --- 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" diff -r c2970d9e6ea7 -r 461876acdff5 make-docs.lisp --- 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" diff -r c2970d9e6ea7 -r 461876acdff5 src/astar.lisp --- /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))))))))) diff -r c2970d9e6ea7 -r 461876acdff5 src/control-flow.lisp --- 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: diff -r c2970d9e6ea7 -r 461876acdff5 src/package.lisp --- 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 diff -r c2970d9e6ea7 -r 461876acdff5 src/sequences.lisp --- 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)))))) + diff -r c2970d9e6ea7 -r 461876acdff5 test/sequences.lisp --- 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?