src/utilities: (add partial-order-minima)

diff --git a/doc/SYMBOLS b/doc/SYMBOLS
index c506fcfe1b30c194c1b0e56f634da4e18ad4dfda..4bbe9ac7081004578b654d8a770a2e30f736984c 100644 (file)
--- a/doc/SYMBOLS
+++ b/doc/SYMBOLS
@@ -2243,6 +2243,7 @@ utilities.lisp
   sb-mop:method-specializers                    generic
   once-only                                     macro
   parse-body                                    function
+  partial-order-minima                          function
   print-ugly-stuff                              function
   ref                                           function setf
   symbolicate                                   function

diff --git a/doc/misc.tex b/doc/misc.tex
index f6037e1a49ece74689a14cd52eb959229f4b2341..8b7536c70318e6e3aece7f0546c54c621edf3362 100644 (file)
--- a/doc/misc.tex
+++ b/doc/misc.tex
@@ -150,6 +150,9 @@ These symbols are defined in the @|sod-utilities| package.
      \-\nlret @<value>^*}
 \end{describe}
 
+\begin{describe}{fun}{partial-order-minima @<items> @<order> @> @<list>}
+\end{describe}
+
 \begin{describe}{fun}
     {frob-identifier @<string> \&key :swap-case :swap-hyphen
       @> @<frobbed-string>}

diff --git a/src/utilities.lisp b/src/utilities.lisp
index 46270c47d6509301dfac9d8e1ecd592c586843db..38bb7468ea3236fd7c7be8f5f72a18b4d27b19e8 100644 (file)
--- a/src/utilities.lisp
+++ b/src/utilities.lisp
@@ -573,6 +573,24 @@ (defmacro categorize ((itemvar items &key bind) categories &body body)
                     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.