From: Mark Wooding <mdw@distorted.org.uk>
Date: Sat, 25 Mar 2017 17:35:03 +0000 (+0000)
Subject: src/utilities: (add partial-order-minima)
X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/sod/commitdiff_plain/42291726898a019030c265b1063eac5d1d7bf173

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

diff --git a/doc/SYMBOLS b/doc/SYMBOLS
index c506fcf..4bbe9ac 100644
--- 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 f6037e1..8b7536c 100644
--- 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 46270c4..38bb746 100644
--- 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.