X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/e8c5a09e2a9f3bd85701a15f25ce4b14cb4ad86a..c5ef873aa2e9ccb3e023efa802780679dc79ed91:/src/utilities.lisp diff --git a/src/utilities.lisp b/src/utilities.lisp index 023fc60..10e95c7 100644 --- a/src/utilities.lisp +++ b/src/utilities.lisp @@ -7,7 +7,7 @@ ;;;----- Licensing notice --------------------------------------------------- ;;; -;;; This file is part of the Sensble Object Design, an object system for C. +;;; This file is part of the Sensible Object Design, an object system for C. ;;; ;;; SOD is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -82,7 +82,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: @@ -273,6 +273,22 @@ "If COND, evaluate BODY as a progn with `it' bound to the value of COND." `(let ((it ,cond)) (when it ,@body))) +(export 'aand) +(defmacro aand (&rest forms) + "Like `and', but anaphoric. + + Each FORM except the first is evaluated with `it' bound to the value of + the previous one. If there are no forms, then the result it `t'; if there + is exactly one, then wrapping it in `aand' is pointless." + (labels ((doit (first rest) + (if (null rest) + first + `(let ((it ,first)) + (if it ,(doit (car rest) (cdr rest)) nil))))) + (if (null forms) + 't + (doit (car forms) (cdr forms))))) + (export 'acond) (defmacro acond (&body clauses &environment env) "Like COND, but with `it' bound to the value of the condition. @@ -417,12 +433,99 @@ (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 '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)) (define-condition inconsistent-merge-error (error) ((candidates :initarg :candidates @@ -430,11 +533,13 @@ (:documentation "Reports an inconsistency in the arguments passed to `merge-lists'.") (:report (lambda (condition stream) - (format stream "Merge inconsistency: failed to decide among ~A." + (format stream "Merge inconsistency: failed to decide between ~ + ~{~#[~;~A~;~A and ~A~:;~ + ~@{~A, ~#[~;and ~A~]~}~]~}" (merge-error-candidates condition))))) (export 'merge-lists) -(defun merge-lists (lists &key pick (test #'eql)) +(defun merge-lists (lists &key pick (test #'eql) (present #'identity)) "Return a merge of the given LISTS. The resulting list contains the items of the given LISTS, with duplicates @@ -442,7 +547,10 @@ the input LISTS in the sense that if A precedes B in some input list then A will also precede B in the output list. If the lists aren't consistent (e.g., some list contains A followed by B, and another contains B followed - by A) then an error of type `inconsistent-merge-error' is signalled. + by A) then an error of type `inconsistent-merge-error' is signalled. The + offending items are filtered for presentation through the PRESENT function + before being attached to the condition, so as to produce a more useful + diagnostic message. Item equality is determined by TEST. @@ -455,9 +563,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)) @@ -484,7 +593,7 @@ candidates)) (winner (cond ((null leasts) (error 'inconsistent-merge-error - :candidates candidates)) + :candidates (mapcar present candidates))) ((null (cdr leasts)) (car leasts)) (pick @@ -552,6 +661,24 @@ 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)) + ;;;-------------------------------------------------------------------------- ;;; Strings and characters. @@ -688,6 +815,17 @@ (reduce #'compose1 more-functions :initial-value function))) ;;;-------------------------------------------------------------------------- +;;; Variables. + +(export 'defvar-unbound) +(defmacro defvar-unbound (var doc) + "Make VAR a special variable with documentation DOC, but leave it unbound." + `(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar ,var) + (setf (documentation ',var 'variable) ',doc) + ',var)) + +;;;-------------------------------------------------------------------------- ;;; Symbols. (export 'symbolicate) @@ -714,6 +852,28 @@ (,print)) (,print))))) +(export 'print-ugly-stuff) +(defun print-ugly-stuff (stream func) + "Print not-pretty things to the stream underlying STREAM. + + The Lisp pretty-printing machinery, notably `pprint-logical-block', may + interpose additional streams between its body and the original target + stream. This makes it difficult to make use of the underlying stream's + special features, whatever they might be." + + ;; This is unpleasant. Hacky hacky. + #.(or #+sbcl '(if (typep stream 'sb-pretty:pretty-stream) + (let ((target (sb-pretty::pretty-stream-target stream))) + (pprint-newline :mandatory stream) + (funcall func target)) + (funcall func stream)) + #+cmu '(if (typep stream 'pp:pretty-stream) + (let ((target (pp::pretty-stream-target stream))) + (pprint-newline :mandatory stream) + (funcall func target)) + (funcall func stream)) + '(funcall func stream))) + ;;;-------------------------------------------------------------------------- ;;; Iteration macros. @@ -790,6 +950,54 @@ (setf (,to object) value)))))) ;;;-------------------------------------------------------------------------- +;;; Condition and error utilities. + +(export 'designated-condition) +(defun designated-condition (default-type datum arguments + &key allow-pointless-arguments) + "Return the condition designated by DATUM and ARGUMENTS. + + DATUM and ARGUMENTS together are a `condition designator' of (some + supertype of) DEFAULT-TYPE; return the condition so designated." + (typecase datum + (condition + (unless (or allow-pointless-arguments (null arguments)) + (error "Argument list provided with specific condition")) + datum) + (symbol + (apply #'make-condition datum arguments)) + ((or string function) + (make-condition default-type + :format-control datum + :format-arguments arguments)) + (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. (export 'default-slot) @@ -825,6 +1033,6 @@ (,classvar (,instance ,class) (,slotvar (eql ',slot))) ,@docs ,@decls (declare (ignore ,classvar)) - (setf (slot-value ,instance ',slot) (progn ,@body)))))) + (setf (slot-value ,instance ',slot) (block ,slot ,@body)))))) ;;;----- That's all, folks --------------------------------------------------