Update of /project/cl-utilities/cvsroot/cl-utilities In directory common-lisp.net:/tmp/cvs-serv550 Modified Files: expt-mod.lisp extremum.lisp package.lisp package.sh test.lisp Log Message: Fixed a bug in extremum and added new EXTREMA and N-MOST-EXTREME functions based on feedback from Tobias Rittweiller. Improved docstrings. Added more tests. Added ACL optimization to EXPT-MOD. Date: Mon Nov 28 22:45:49 2005 Author: pscott Index: cl-utilities/expt-mod.lisp diff -u cl-utilities/expt-mod.lisp:1.2 cl-utilities/expt-mod.lisp:1.3 --- cl-utilities/expt-mod.lisp:1.2 Mon May 9 23:51:31 2005 +++ cl-utilities/expt-mod.lisp Mon Nov 28 22:45:49 2005 @@ -5,24 +5,25 @@ (defun expt-mod (n exponent modulus) "As (mod (expt n exponent) modulus), but more efficient." (declare (optimize (speed 3) (safety 0) (space 0) (debug 1))) - ;; It's much faster on SBCL to use the simple method, and trust the - ;; compiler to optimize it. This may be the case on other Lisp - ;; implementations as well. - #+sbcl (mod (expt n exponent) modulus) - #-sbcl (if (some (complement #'integerp) (list n exponent modulus)) - (mod (expt n exponent) modulus) - (loop with result = 1 - for i of-type fixnum from 0 below (integer-length exponent) - for sqr = n then (mod (* sqr sqr) modulus) - when (logbitp i exponent) do - (setf result (mod (* result sqr) modulus)) - finally (return result)))) + ;; It's much faster on SBCL and ACL to use the simple method, and + ;; trust the compiler to optimize it. This may be the case on other + ;; Lisp implementations as well. + #+(or sbcl allegro) (mod (expt n exponent) modulus) + #-(or sbcl allegro) + (if (some (complement #'integerp) (list n exponent modulus)) + (mod (expt n exponent) modulus) + (loop with result = 1 + for i of-type fixnum from 0 below (integer-length exponent) + for sqr = n then (mod (* sqr sqr) modulus) + when (logbitp i exponent) do + (setf result (mod (* result sqr) modulus)) + finally (return result)))) -;; If SBCL is going to expand compiler macros, we should directly -;; inline the simple expansion; this lets SBCL do all sorts of fancy -;; optimizations based on type information that wouldn't be used to -;; optimize the normal EXPT-MOD function. -#+sbcl +;; If the compiler is going to expand compiler macros, we should +;; directly inline the simple expansion; this lets the compiler do all +;; sorts of fancy optimizations based on type information that +;; wouldn't be used to optimize the normal EXPT-MOD function. +#+(or sbcl allegro) (define-compiler-macro expt-mod (n exponent modulus) `(mod (expt ,n ,exponent) ,modulus)) Index: cl-utilities/extremum.lisp diff -u cl-utilities/extremum.lisp:1.7 cl-utilities/extremum.lisp:1.8 --- cl-utilities/extremum.lisp:1.7 Mon Aug 29 22:14:47 2005 +++ cl-utilities/extremum.lisp Mon Nov 28 22:45:49 2005 @@ -48,7 +48,7 @@ (continue () :report "Return NIL instead" nil)) - ,@body))) + (progn ,@body)))) ;; This is an extended version which takes START and END keyword ;; arguments. Any spec-compliant use of EXTREMUM will also work with @@ -56,8 +56,9 @@ (defun extremum (sequence predicate &key (key #'identity) (start 0) end) "Returns the element of SEQUENCE that would appear first if the -sequence were ordered according to SORT using PREDICATE and KEY. See -http://www.cliki.net/EXTREMUM for the full specification." +sequence were ordered according to SORT using PREDICATE and KEY using +an unstable sorting algorithm. See http://www.cliki.net/EXTREMUM for +the full specification." (with-check-length (sequence start end) (reduce (comparator predicate key) sequence :start start :end end))) @@ -89,9 +90,9 @@ (let* ((smallest (elt sequence 0)) (smallest-key (funcall key smallest)) (current-index 0) - (real-end (or end #.(1- most-positive-fixnum)))) - (declare (type (integer 0 #.most-positive-fixnum) - current-index real-end start)) + (real-end (or end (1- most-positive-fixnum)))) + (declare (type (integer 0) current-index real-end start) + (fixnum current-index real-end start)) (map nil #'(lambda (x) (when (<= start current-index real-end) (let ((x-key (funcall key x))) @@ -102,4 +103,64 @@ (setf smallest-key x-key)))) (incf current-index)) sequence) - smallest))) \ No newline at end of file + smallest))) + +;; EXTREMA and N-MOST-EXTREME are based on code and ideas from Tobias +;; C. Rittweiller. They deal with the cases in which you are not +;; looking for a single extreme element, but for the extreme identical +;; elements or the N most extreme elements. + +(defun extrema (sequence predicate &key (key #'identity) (start 0) end) + (with-check-length (sequence start end) + (let* ((sequence (subseq sequence start end)) + (smallest-elements (list (elt sequence 0))) + (smallest-key (funcall key (elt smallest-elements 0)))) + (map nil + #'(lambda (x) + (let ((x-key (funcall key x))) + (cond ((funcall predicate x-key smallest-key) + (setq smallest-elements (list x)) + (setq smallest-key x-key)) + ;; both elements are considered equal if the predicate + ;; returns false for (PRED A B) and (PRED B A) + ((not (funcall predicate smallest-key x-key)) + (push x smallest-elements))))) + (subseq sequence 1)) + ;; We use NREVERSE to make this stable (in the sorting algorithm + ;; sense of the word 'stable'). + (nreverse smallest-elements)))) + + + +(define-condition n-most-extreme-not-enough-elements (warning) + ((n :initarg :n :reader n-most-extreme-not-enough-elements-n + :documentation "The number of elements that need to be returned") + (subsequence :initarg :subsequence + :reader n-most-extreme-not-enough-elements-subsequence + :documentation "The subsequence from which elements +must be taken. This is determined by the sequence and the :start and +:end arguments to N-MOST-EXTREME.")) + (:report (lambda (condition stream) + (with-slots (n subsequence) condition + (format stream "There are not enough elements in the sequence ~S~% to return the ~D most extreme elements" + subsequence n)))) + (:documentation "There are not enough elements in the sequence given +to N-MOST-EXTREME to return the N most extreme elements.")) + +(defun n-most-extreme (n sequence predicate &key (key #'identity) (start 0) end) + "Returns a list of the N elements of SEQUENCE that would appear +first if the sequence were ordered according to SORT using PREDICATE +and KEY with a stable sorting algorithm. If there are less than N +elements in the relevant part of the sequence, this will return all +the elements it can and signal the warning +N-MOST-EXTREME-NOT-ENOUGH-ELEMENTS" + (with-check-length (sequence start end) + ;; This is faster on vectors than on lists. + (let ((sequence (subseq sequence start end))) + (if (> n (length sequence)) + (progn + (warn 'n-most-extreme-not-enough-elements + :n n :subsequence sequence) + (stable-sort (copy-seq sequence) predicate :key key)) + (subseq (stable-sort (copy-seq sequence) predicate :key key) + 0 n))))) \ No newline at end of file Index: cl-utilities/package.lisp diff -u cl-utilities/package.lisp:1.4 cl-utilities/package.lisp:1.5 --- cl-utilities/package.lisp:1.4 Fri Oct 21 23:22:47 2005 +++ cl-utilities/package.lisp Mon Nov 28 22:45:49 2005 @@ -10,6 +10,11 @@ #:extremum #:no-extremum #:extremum-fastkey + #:extrema + #:n-most-extreme + #:n-most-extreme-not-enough-elements + #:n-most-extreme-not-enough-elements-n + #:n-most-extreme-not-enough-elements-subsequence #:read-delimited #:read-delimited-bounds-error Index: cl-utilities/package.sh diff -u cl-utilities/package.sh:1.4 cl-utilities/package.sh:1.5 --- cl-utilities/package.sh:1.4 Mon Aug 29 22:14:47 2005 +++ cl-utilities/package.sh Mon Nov 28 22:45:49 2005 @@ -1,17 +1,17 @@ #!/bin/sh -mkdir cl-utilities-1.1.1 -cp cl-utilities.asd package.sh collecting.lisp expt-mod.lisp package.lisp compose.lisp extremum.lisp read-delimited.lisp test.lisp copy-array.lisp once-only.lisp rotate-byte.lisp with-unique-names.lisp README cl-utilities-1.1.1/ +mkdir cl-utilities-1.2 +cp cl-utilities.asd package.sh collecting.lisp split-sequence.lisp expt-mod.lisp package.lisp compose.lisp extremum.lisp read-delimited.lisp test.lisp copy-array.lisp once-only.lisp rotate-byte.lisp with-unique-names.lisp README cl-utilities-1.2/ rm -f cl-utilities-latest.tar.gz cl-utilities-latest.tar.gz.asc -tar -czvf cl-utilities-1.1.1.tar.gz cl-utilities-1.1.1/ -ln -s ~/hacking/lisp/cl-utilities/cl-utilities-1.1.1.tar.gz ~/hacking/lisp/cl-utilities/cl-utilities-latest.tar.gz -gpg -b -a ~/hacking/lisp/cl-utilities/cl-utilities-1.1.1.tar.gz -ln -s ~/hacking/lisp/cl-utilities/cl-utilities-1.1.1.tar.gz.asc ~/hacking/lisp/cl-utilities/cl-utilities-latest.tar.gz.asc -rm -Rf cl-utilities-1.1.1/ +tar -czvf cl-utilities-1.2.tar.gz cl-utilities-1.2/ +ln -s ~/hacking/lisp/cl-utilities/cl-utilities-1.2.tar.gz ~/hacking/lisp/cl-utilities/cl-utilities-latest.tar.gz +gpg -b -a ~/hacking/lisp/cl-utilities/cl-utilities-1.2.tar.gz +ln -s ~/hacking/lisp/cl-utilities/cl-utilities-1.2.tar.gz.asc ~/hacking/lisp/cl-utilities/cl-utilities-latest.tar.gz.asc +rm -Rf cl-utilities-1.2/ -scp cl-utilities-1.1.1.tar.gz pscott@common-lisp.net:/project/cl-utilities/public_html/cl-utilities-1.1.1.tar.gz -scp cl-utilities-1.1.1.tar.gz.asc pscott@common-lisp.net:/project/cl-utilities/public_html/cl-utilities-1.1.1.tar.gz.asc +scp cl-utilities-1.2.tar.gz pscott@common-lisp.net:/project/cl-utilities/public_html/cl-utilities-1.2.tar.gz +scp cl-utilities-1.2.tar.gz.asc pscott@common-lisp.net:/project/cl-utilities/public_html/cl-utilities-1.2.tar.gz.asc scp cl-utilities-latest.tar.gz pscott@common-lisp.net:/project/cl-utilities/public_html/cl-utilities-latest.tar.gz scp cl-utilities-latest.tar.gz.asc pscott@common-lisp.net:/project/cl-utilities/public_html/cl-utilities-latest.tar.gz.asc Index: cl-utilities/test.lisp diff -u cl-utilities/test.lisp:1.6 cl-utilities/test.lisp:1.7 --- cl-utilities/test.lisp:1.6 Fri Oct 21 23:22:47 2005 +++ cl-utilities/test.lisp Mon Nov 28 22:45:49 2005 @@ -47,6 +47,42 @@ 23)) (is (= (extremum-fastkey '(2/3 2 3 4) #'> :key (lambda (x) (/ 1 x))) 2/3))) +(test extrema + (is (tree-equal (extrema '(3 2 1 1 2 1) #'<) + '(1 1 1))) + (is (tree-equal (extrema #(3 2 1 1 2 1) #'<) + '(1 1 1))) + (is (tree-equal (extrema #(3 2 1 1 2 1) #'< :end 4) + '(1 1))) + (is (tree-equal (extrema '(3 2 1 1 2 1) #'< :end 4) + '(1 1))) + (is (tree-equal (extrema #(3 2 1 1 2 1) #'< :start 3 :end 4) + '(1))) + (is (tree-equal (extrema '((A . 3) (B . 1) (C . 2) (D . 1)) #'< :key #'cdr) + '((B . 1) (D . 1))))) + +(defmacro quietly (&body body) + "Perform BODY quietly, muffling any warnings that may arise" + `(handler-bind ((warning #'muffle-warning)) + ,@body)) + +(test n-most-extreme + (is (tree-equal (n-most-extreme 1 '(3 1 2 1) #'>) + '(3))) + (is (tree-equal (n-most-extreme 2 '(3 1 2 1) #'>) + '(3 2))) + (is (tree-equal (n-most-extreme 2 '(3 1 2 1) #'<) + '(1 1))) + (is (tree-equal (n-most-extreme 1 '((A . 3) (B . 1) (C . 2) (D . 1)) #'> :key #'cdr) + '((A . 3)))) + (is (tree-equal (n-most-extreme 2 '((A . 3) (B . 1) (C . 2) (D . 1)) #'< :key #'cdr) + '((B . 1) (D . 1)))) + (is (tree-equal (quietly (n-most-extreme 20 '((A . 3) (B . 1) (C . 2) (D . 1)) #'< :key #'cdr)) + '((B . 1) (D . 1) (C . 2) (A . 3)))) + (is (tree-equal (quietly (n-most-extreme 2 '((A . 3) (B . 1) (C . 2) (D . 1)) #'< :key #'cdr :start 1 :end 2)) + '((B . 1)))) + (signals n-most-extreme-not-enough-elements (n-most-extreme 2 '((A . 3) (B . 1) (C . 2) (D . 1)) #'< :key #'cdr :start 1 :end 2))) + (defun delimited-test (&key (delimiter #\|) (start 0) end (string "foogo|ogreogrjejgierjijri|bar|baz")) (with-input-from-string (str string)