add EXTREMUM

  From http://www.cliki.net/EXTREMUM

  A simple version built on top of REDUCE for now.

diff --git a/package.lisp b/package.lisp
index 673ed30..babeb95 100644 (file)
--- a/package.lisp
+++ b/package.lisp
@@ -107,17 +107,19 @@
    #:emptyp
    #:ends-with
    #:ends-with-subseq
+   #:extremum
    #:first-elt
    #:last-elt
+   #:length=
    #:map-combinations
    #:map-derangements
    #:map-permutations
+   #:no-extremum
    #:proper-sequence
    #:random-elt
    #:removef
    #:rotate
    #:sequence-of-length-p
-   #:length=
    #:shuffle
    #:starts-with
    #:starts-with-subseq

diff --git a/sequences.lisp b/sequences.lisp
index 9e4ff74..cb01081 100644 (file)
--- a/sequences.lisp
+++ b/sequences.lisp
@@ -484,3 +484,54 @@ if calling FUNCTION modifies either the derangement or SEQUENCE."
       sequence)))
 
 (declaim (notinline sequence-of-length-p))
+
+(define-condition no-extremum (error)
+  ()
+  (:report (lambda (condition stream)
+             (declare (ignore condition))
+             (format stream "Empty sequence in ~S." 'extremum))))
+
+
+(defun extremum (sequence predicate &key key (start 0) end)
+  "Returns the element of SEQUENCE that would appear first if the subsequence
+bounded by START and END was sorted using PREDICATE and KEY.
+
+EXTREMUM determines the relationship between two elements of SEQUENCE by using
+the PREDICATE function. PREDICATE should return true if and only if the first
+argument is strictly less than the second one (in some appropriate sense). Two
+arguments X and Y are considered to be equal if (FUNCALL PREDICATE X Y)
+and (FUNCALL PREDICATE Y X) are both false.
+
+The arguments to the PREDICATE function are computed from elements of SEQUENCE
+using the KEY function, if supplied. If KEY is not supplied or is NIL, the
+sequence element itself is used.
+
+If SEQUENCE is empty, then the error NO-EXTREMUM is signalled. Invoking the
+CONTINUE restart will cause extremum to return NIL."
+  (let* ((pred-fun (ensure-function predicate))
+         (key-fun (unless (or (not key) (eq key 'identity) (eq key #'identity))
+                    (ensure-function key)))
+         (real-end (or end (length sequence))))
+    (cond ((> real-end start)
+           (if key-fun
+               (flet ((reduce-keys (a b)
+                        (if (funcall pred-fun
+                                     (funcall key-fun a)
+                                     (funcall key-fun b))
+                            a
+                            b)))
+                 (declare (dynamic-extent #'reduce-keys))
+                 (reduce #'reduce-keys sequence :start start :end real-end))
+               (flet ((reduce-elts (a b)
+                        (if (funcall pred-fun a b)
+                            a
+                            b)))
+                 (declare (dynamic-extent #'reduce-elts))
+                 (reduce #'reduce-elts sequence :start start :end real-end))))
+          ((= real-end start)
+           (cerror "Return NIL instead." 'no-extremum))
+          (t
+           (error "Invalid bounding indexes for sequence of length ~S: ~S ~S, ~S ~S"
+                  (length sequence)
+                  :start start
+                  :end end)))))

diff --git a/tests.lisp b/tests.lisp
index d104bda..e218113 100644 (file)
--- a/tests.lisp
+++ b/tests.lisp
@@ -1828,3 +1828,31 @@
   t
   t
   t)
+
+(deftest extremum.1
+    (let ((n 0))
+      (dotimes (i 10)
+       (let ((data (shuffle (coerce (iota 10000 :start i) 'vector)))
+             (ok t))
+         (unless (eql i (extremum data #'<))
+           (setf ok nil))
+         (unless (eql i (extremum (coerce data 'list) #'<))
+           (setf ok nil))
+         (unless (eql (+ 9999 i) (extremum data #'>))
+           (setf ok nil))
+         (unless (eql (+ 9999 i) (extremum (coerce  data 'list) #'>))
+           (setf ok nil))
+         (when ok
+           (incf n))))
+      (when (eql 10 (extremum #(100 1 10 1000) #'> :start 1 :end 3))
+        (incf n))
+      (when (eql -1000 (extremum #(100 1 10 -1000) #'> :key 'abs))
+        (incf n))
+      (let ((err nil))
+        (handler-bind ((no-extremum (lambda (c)
+                                      (setf err c)
+                                      (continue c))))
+          (when (eq nil (extremum "" #'error))
+            (when err
+              (incf n))))))
+  13)