X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/c34b237da0bb4bf08a3531a2e11442623df7e9d4..12949379840101e2d65883f29c5e8f0f6de49e9c:/src/utilities.lisp diff --git a/src/utilities.lisp b/src/utilities.lisp index 72af8b3..25733e8 100644 --- a/src/utilities.lisp +++ b/src/utilities.lisp @@ -23,17 +23,29 @@ ;;; along with SOD; if not, write to the Free Software Foundation, ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -(cl:defpackage #:sod-utilities - (:use #:common-lisp +(eval-when (:compile-toplevel :load-toplevel :execute) + (handler-bind ((warning #'muffle-warning)) + (cl:defpackage #:sod-utilities + (:use #:common-lisp - ;; MOP from somewhere. - #+sbcl #:sb-mop - #+(or cmu clisp) #:mop - #+ecl #:clos)) + ;; MOP from somewhere. + #+sbcl #:sb-mop + #+(or cmu clisp) #:mop + #+ecl #:clos)))) (cl:in-package #:sod-utilities) ;;;-------------------------------------------------------------------------- +;;; Common symbols. +;;; +;;; Sometimes, logically independent packages will want to use the same +;;; symbol, and these uses (by careful design) don't conflict with each +;;; other. If we export the symbols here, then the necessary sharing will +;;; happen automatically. + +(export 'int) ; used by c-types and optparse + +;;;-------------------------------------------------------------------------- ;;; Macro hacks. (export 'with-gensyms) @@ -82,7 +94,7 @@ 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: @@ -433,23 +445,133 @@ (export 'mappend) (defun mappend (function list &rest more-lists) - "Like a nondestructive MAPCAN. + "Like a nondestructive `mapcan'. Map FUNCTION over the the corresponding elements of LIST and MORE-LISTS, 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 'cross-product) +(defun cross-product (&rest pieces) + "Return the cross product of the PIECES. + + Each arguments may be a list, or a (non-nil) atom, which is equivalent to + a singleton list containing just that atom. Return a list of all possible + lists which can be constructed by taking one item from each argument list + in turn, in an arbitrary order." + (reduce (lambda (piece tails) + (mapcan (lambda (tail) + (mapcar (lambda (head) + (cons head tail)) + (if (listp piece) piece + (list piece)))) + tails)) + pieces + :from-end t + :initial-value '(nil))) + +(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)) @@ -476,9 +598,10 @@ 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)) @@ -505,7 +628,8 @@ candidates)) (winner (cond ((null leasts) (error 'inconsistent-merge-error - :candidates (mapcar present candidates))) + :candidates candidates + :present present)) ((null (cdr leasts)) (car leasts)) (pick @@ -558,21 +682,76 @@ (symbol-name name) "-"))) cat-names)) (items-var (gensym "ITEMS-"))) - `(let ((,items-var ,items) - ,@(mapcar (lambda (cat-var) (list cat-var nil)) cat-vars)) - (dolist (,itemvar ,items-var) - (let* ,bind - (cond ,@(mapcar (lambda (cat-match-form cat-var) - `(,cat-match-form - (push ,itemvar ,cat-var))) - cat-match-forms cat-vars) - ,@(and (not (member t cat-match-forms)) - `((t (error "Failed to categorize ~A" ,itemvar))))))) + `(let (,@(mapcar (lambda (cat-var) (list cat-var nil)) cat-vars)) + (let ((,items-var ,items)) + (dolist (,itemvar ,items-var) + (let* ,bind + (cond ,@(mapcar (lambda (cat-match-form cat-var) + `(,cat-match-form + (push ,itemvar ,cat-var))) + cat-match-forms cat-vars) + ,@(and (not (member t cat-match-forms)) + `((t (error "Failed to categorize ~A" + ,itemvar)))))))) (let ,(mapcar (lambda (name var) `(,name (nreverse ,var))) 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) + (do ((tail sequence (cdr tail)) + (i 0 (1+ i))) + ((endp tail)) + (let* ((item (car tail)) + (match (find (funcall key item) sequence + :test test :key key :end i))) + (when match (funcall report item match))))) + ((vectorp sequence) + (dotimes (i (length sequence)) + (let* ((item (aref sequence i)) + (pos (position (funcall key item) sequence + :key key :test test :end i))) + (when pos (funcall report item (aref sequence pos)))))) + (t + (error 'type-error :datum sequence :expected-type 'sequence)))) + ;;;-------------------------------------------------------------------------- ;;; Strings and characters. @@ -695,7 +874,7 @@ ;;; Functions. (export 'compose) -(defun compose (function &rest more-functions) +(defun compose (&rest functions) "Composition of functions. Functions are applied left-to-right. This is the reverse order of the usual mathematical notation, but I find @@ -706,7 +885,9 @@ (labels ((compose1 (func-a func-b) (lambda (&rest args) (multiple-value-call func-b (apply func-a args))))) - (reduce #'compose1 more-functions :initial-value function))) + (if (null functions) #'values + (reduce #'compose1 (cdr functions) + :initial-value (car functions))))) ;;;-------------------------------------------------------------------------- ;;; Variables. @@ -786,8 +967,9 @@ The loop is surrounded by an anonymous BLOCK and the loop body forms an implicit TAGBODY, as is usual. There is no result-form, however." - (once-only (:environment env seq start end) - (with-gensyms ((ivar "INDEX-") (endvar "END-") (bodyfunc "BODY-")) + (once-only (:environment env start end) + (with-gensyms ((seqvar "SEQ-") (ivar "INDEX-") + (endvar "END-") (bodyfunc "BODY-")) (multiple-value-bind (docs decls body) (parse-body body :docp nil) (declare (ignore docs)) @@ -796,13 +978,13 @@ (let* ((do-vars nil) (end-condition (if endvar `(>= ,ivar ,endvar) - `(endp ,seq))) + `(endp ,seqvar))) (item (if listp - `(car ,seq) - `(aref ,seq ,ivar))) + `(car ,seqvar) + `(aref ,seqvar ,ivar))) (body-call `(,bodyfunc ,item))) (when listp - (push `(,seq (nthcdr ,start ,seq) (cdr ,seq)) + (push `(,seqvar (nthcdr ,start ,seqvar) (cdr ,seqvar)) do-vars)) (when indexp (push `(,ivar ,start (1+ ,ivar)) do-vars)) @@ -811,17 +993,18 @@ `(do ,do-vars (,end-condition) ,body-call)))) `(block nil - (flet ((,bodyfunc (,var ,@(and indexvar `(,indexvar))) - ,@decls - (tagbody ,@body))) - (etypecase ,seq - (vector - (let ((,endvar (or ,end (length ,seq)))) - ,(loopguts t nil endvar))) - (list - (if ,end - ,(loopguts t t end) - ,(loopguts indexvar t nil))))))))))) + (let ((,seqvar ,seq)) + (flet ((,bodyfunc (,var ,@(and indexvar `(,indexvar))) + ,@decls + (tagbody ,@body))) + (etypecase ,seqvar + (vector + (let ((,endvar (or ,end (length ,seqvar)))) + ,(loopguts t nil endvar))) + (list + (if ,end + ,(loopguts t t end) + ,(loopguts indexvar t nil)))))))))))) ;;;-------------------------------------------------------------------------- ;;; Structure accessor hacks. @@ -867,6 +1050,85 @@ (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)) + +(export '(enclosing-condition enclosed-condition)) +(define-condition enclosing-condition (condition) + ((%enclosed-condition :initarg :condition :type condition + :reader enclosed-condition)) + (:documentation + "A condition which encloses another condition + + This is useful if one wants to attach additional information to an + existing condition. The enclosed condition can be obtained using the + `enclosed-condition' function.") + (:report (lambda (condition stream) + (princ (enclosed-condition condition) stream)))) + +(export 'information) +(define-condition information (condition) + ()) + +(export 'simple-information) +(define-condition simple-information (simple-condition information) + ()) + +(export 'info) +(defun info (datum &rest arguments) + "Report some useful diagnostic information. + + Establish a simple restart named `noted', and signal the condition of type + `information' designated by DATUM and ARGUMENTS. Return non-nil if the + restart was invoked, otherwise nil." + (restart-case + (signal (designated-condition 'simple-information datum arguments)) + (noted () :report "Noted." t))) + +(export 'noted) +(defun noted (&optional condition) + "Invoke the `noted' restart, possibly associated with the given CONDITION." + (invoke-associated-restart 'noted condition)) + +(export 'promiscuous-cerror) +(defun promiscuous-cerror (continue-string datum &rest arguments) + "Like standard `cerror', but robust against sneaky changes of conditions. + + It seems that `cerror' (well, at least the version in SBCL) is careful + to limit its restart to the specific condition it signalled. But that's + annoying, because `sod-parser:with-default-error-location' substitutes + different conditions carrying the error-location information." + (restart-case (apply #'error datum arguments) + (continue () + :report (lambda (stream) + (apply #'format stream continue-string datum arguments)) + nil))) + +(export 'cerror*) +(defun cerror* (datum &rest arguments) + (apply #'promiscuous-cerror "Continue" datum arguments)) + ;;;-------------------------------------------------------------------------- ;;; CLOS hacking.