X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/3a774b55edfea441c1715994924c2999e9202143..12949379840101e2d65883f29c5e8f0f6de49e9c:/src/utilities.lisp diff --git a/src/utilities.lisp b/src/utilities.lisp index 0f6a54b..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: @@ -439,6 +451,25 @@ and return the result of appending all of the resulting lists." (reduce #'append (apply #'mapcar function list more-lists) :from-end t)) +(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. @@ -526,17 +557,21 @@ (cdddr neigh-record) best-path))))))) dead)) -(export '(inconsistent-merge-error merge-error-candidates)) +(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)) @@ -563,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)) @@ -592,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 @@ -645,16 +682,17 @@ (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) @@ -678,6 +716,42 @@ 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. @@ -800,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 @@ -811,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. @@ -891,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)) @@ -901,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)) @@ -916,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. @@ -996,6 +1074,61 @@ 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.