form))))
(export 'once-only)
-(defmacro once-only (binds &body body)
+(defmacro once-only ((&rest binds) &body body)
"Macro helper for preventing repeated evaluation.
The syntax is actually hairier than shown:
and return the result of appending all of the resulting lists."
(reduce #'append (apply #'mapcar function list more-lists) :from-end t))
-(export '(inconsistent-merge-error merge-error-candidates))
+(export 'distinguished-point-shortest-paths)
+(defun distinguished-point-shortest-paths (root neighbours-func)
+ "Moderately efficient shortest-paths-from-root computation.
+
+ The ROOT is a distinguished vertex in a graph. The NEIGHBOURS-FUNC
+ accepts a VERTEX as its only argument, and returns a list of conses (V .
+ C) for each of the VERTEX's neighbours, indicating that there is an edge
+ from VERTEX to V, with cost C.
+
+ The return value is a list of entries (COST . REV-PATH) for each vertex
+ reachable from the ROOT; the COST is the total cost of the shortest path,
+ and REV-PATH is the path from the ROOT, in reverse order -- so the first
+ element is the vertex itself and the last element is the ROOT.
+
+ The NEIGHBOURS-FUNC is called at most N times, and may take O(N) time to
+ produce its output list. The computation as a whole takes O(N^2) time,
+ where N is the number of vertices in the graph, assuming there is at most
+ one edge between any pair of vertices."
+
+ ;; This is a listish version of Dijkstra's shortest-path algorithm. It
+ ;; could be made more efficient by using a fancy priority queue rather than
+ ;; a linear search for finding the nearest live element (see below), but it
+ ;; still runs pretty well.
+
+ (let ((map (make-hash-table))
+ (dead nil)
+ (live (list (list 0 root))))
+ (setf (gethash root map) (cons :live (car live)))
+ (loop
+ ;; The dead list contains a record, in output format (COST . PATH), for
+ ;; each vertex whose shortest path has been finally decided. The live
+ ;; list contains a record for the vertices of current interest, also in
+ ;; output format; the COST for a live record shows the best cost for a
+ ;; path using only dead vertices.
+ ;;
+ ;; Each time through here, we pull an item off the live list and
+ ;; push it onto the dead list, so we do at most N iterations total.
+
+ ;; If there are no more live items, then we're done; the remaining
+ ;; vertices, if any, are unreachable from the ROOT.
+ (when (null live) (return))
+
+ ;; Find the closest live vertex to the root. The linear scan through
+ ;; the live list costs at most N time.
+ (let* ((best (reduce (lambda (x y) (if (< (car x) (car y)) x y)) live))
+ (best-cost (car best))
+ (best-path (cdr best))
+ (best-vertex (car best-path)))
+
+ ;; Remove the chosen vertex from the LIVE list, and add the
+ ;; appropriate record to the dead list. We must have the shortest
+ ;; path to this vertex now: we have the shortest path using currently
+ ;; dead vertices; any other path must use at least one live vertex,
+ ;; and, by construction, the path through any such vertex must be
+ ;; further than the path we already have.
+ ;;
+ ;; Removal from the live list uses a linear scan which costs N time.
+ (setf live (delete best live))
+ (push best dead)
+ (setf (car (gethash best-vertex map)) :dead)
+
+ ;; Work through the chosen vertex's neighbours, adding each of them
+ ;; to the live list if they're not already there. If a neighbour is
+ ;; already live, and we find a shorter path to it through our chosen
+ ;; vertex, then update the neighbour's record.
+ ;;
+ ;; The chosen vertex obviously has at most N neighbours. There's no
+ ;; more looping in here, so performance is as claimed.
+ (dolist (neigh (funcall neighbours-func best-vertex))
+ (let* ((neigh-vertex (car neigh))
+ (neigh-cost (+ best-cost (cdr neigh)))
+ (neigh-record (gethash neigh-vertex map)))
+ (cond ((null neigh-record)
+ ;; If the neighbour isn't known, then now's the time to
+ ;; make a fresh live record for it.
+ (let ((new-record (list* :live neigh-cost
+ neigh-vertex best-path)))
+ (push (cdr new-record) live)
+ (setf (gethash neigh-vertex map) new-record)))
+ ((and (eq (car neigh-record) :live)
+ (< neigh-cost (cadr neigh-record)))
+ ;; If the neighbour is live, and we've found a better path
+ ;; to it, then update its record.
+ (setf (cadr neigh-record) neigh-cost
+ (cdddr neigh-record) best-path)))))))
+ dead))
+
+(export '(inconsistent-merge-error
+ merge-error-candidates merge-error-present-function))
(define-condition inconsistent-merge-error (error)
((candidates :initarg :candidates
- :reader merge-error-candidates))
+ :reader merge-error-candidates)
+ (present :initarg :present :initform #'identity
+ :reader merge-error-present-function))
(:documentation
"Reports an inconsistency in the arguments passed to `merge-lists'.")
(:report (lambda (condition stream)
(format stream "Merge inconsistency: failed to decide between ~
~{~#[~;~A~;~A and ~A~:;~
~@{~A, ~#[~;and ~A~]~}~]~}"
- (merge-error-candidates condition)))))
+ (mapcar (merge-error-present-function condition)
+ (merge-error-candidates condition))))))
(export 'merge-lists)
(defun merge-lists (lists &key pick (test #'eql) (present #'identity))
candidates list if and only if an occurrence of A appears in an earlier
input list than any occurrence of item B. (This completely determines the
order of the candidates: it is not possible that two candidates appear in
- the same input list would resolve the ambiguity between them.) If PICK is
- omitted then the item chosen is the one appearing in the earliest of the
- input lists: i.e., effectively, the default PICK function is
+ the same input list, since that would resolve the ambiguity between them.)
+ If PICK is omitted then the item chosen is the one appearing in the
+ earliest of the input lists: i.e., effectively, the default PICK function
+ is
(lambda (candidates output-so-far)
(declare (ignore output-so-far))
candidates))
(winner (cond ((null leasts)
(error 'inconsistent-merge-error
- :candidates (mapcar present candidates)))
+ :candidates candidates
+ :present present))
((null (cdr leasts))
(car leasts))
(pick
cat-names cat-vars)
,@body))))
+(export 'partial-order-minima)
+(defun partial-order-minima (items order)
+ "Return a list of minimal items according to the non-strict partial ORDER.
+
+ The ORDER function describes the partial order: (funcall ORDER X Y) should
+ return true if X precedes or is equal to Y in the order."
+ (reduce (lambda (tops this)
+ (let ((new nil) (keep t))
+ (dolist (top tops)
+ (cond ((funcall order top this)
+ (setf keep nil)
+ (push top new))
+ ((not (funcall order this top))
+ (push top new))))
+ (nreverse (if keep (cons this new) new))))
+ items
+ :initial-value nil))
+
+(export 'find-duplicates)
+(defun find-duplicates (report sequence &key (key #'identity) (test #'eql))
+ "Call REPORT on each pair of duplicate items in SEQUENCE.
+
+ Duplicates are determined according to the KEY and TEST funcitons."
+ (when (symbolp test) (setf test (symbol-function test)))
+ (cond ((zerop (length sequence)) nil)
+ ((or (eq test #'eq)
+ (eq test #'eql)
+ (eq test #'equal)
+ (eq test #'equalp))
+ (let ((seen (make-hash-table :test test)))
+ (map nil (lambda (item)
+ (let ((k (funcall key item)))
+ (multiple-value-bind (previous matchp)
+ (gethash k seen)
+ (if matchp (funcall report item previous)
+ (setf (gethash k seen) item)))))
+ sequence)))
+ ((listp sequence)
+ (mapl (lambda (tail)
+ (let* ((item (car tail))
+ (rest (cdr tail))
+ (match (member (funcall key item) rest
+ :test test :key key)))
+ (when match (funcall report item (car match)))))
+ sequence))
+ ((vectorp sequence)
+ (dotimes (i (length sequence))
+ (let* ((item (aref sequence i))
+ (pos (position (funcall key item) sequence
+ :key key :test test :start (1+ i))))
+ (when pos (funcall report item (aref sequence pos))))))
+ (t
+ (error 'type-error :datum sequence :expected-type 'sequence))))
+
;;;--------------------------------------------------------------------------
;;; Strings and characters.
(t
(error "Unexpected condition designator datum ~S" datum))))
+(export 'simple-control-error)
+(define-condition simple-control-error (control-error simple-error)
+ ())
+
+(export 'invoke-associated-restart)
+(defun invoke-associated-restart (restart condition &rest arguments)
+ "Invoke the active RESTART associated with CONDITION, with the ARGUMENTS.
+
+ Find an active restart designated by RESTART; if CONDITION is not nil,
+ then restrict the search to restarts associated with CONDITION, and
+ restarts not associated with any condition. If no such restart is found
+ then signal an error of type `control-error'; otherwise invoke the restart
+ with the given ARGUMENTS."
+ (apply #'invoke-restart
+ (or (find-restart restart condition)
+ (error 'simple-control-error
+ :format-control "~:[Restart ~S is not active~;~
+ No active `~(~A~)' restart~]~
+ ~@[ for condition ~S~]"
+ :format-arguments (list (symbolp restart)
+ restart
+ condition)))
+ arguments))
+
;;;--------------------------------------------------------------------------
;;; CLOS hacking.
~mdw / sod / blobdiff