From 42291726898a019030c265b1063eac5d1d7bf173 Mon Sep 17 00:00:00 2001
Message-Id: <42291726898a019030c265b1063eac5d1d7bf173.1715364604.git.mdw@distorted.org.uk>
From: Mark Wooding <mdw@chiark.greenend.org.uk>
Date: Sat, 25 Mar 2017 17:35:03 +0000
Subject: [PATCH] src/utilities: (add partial-order-minima)
Organization: Straylight/Edgeware

From: Mark Wooding <mdw@distorted.org.uk>

---
 doc/SYMBOLS        |  1 +
 doc/misc.tex       |  3 +++
 src/utilities.lisp | 18 ++++++++++++++++++
 3 files changed, 22 insertions(+)

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.
 
-- 
[mdw]