[cl-utilities-cvs] CVS update: cl-utilities/expt-mod.lisp cl-utilities/extremum.lisp cl-utilities/package.lisp cl-utilities/package.sh cl-utilities/test.lisp
Peter Scott
pscott at common-lisp.net
Mon Nov 28 21:45:54 UTC 2005
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))
- , at body)))
+ (progn , at 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 at 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 at common-lisp.net:/project/cl-utilities/public_html/cl-utilities-1.1.1.tar.gz.asc
+scp cl-utilities-1.2.tar.gz pscott at common-lisp.net:/project/cl-utilities/public_html/cl-utilities-1.2.tar.gz
+scp cl-utilities-1.2.tar.gz.asc pscott at common-lisp.net:/project/cl-utilities/public_html/cl-utilities-1.2.tar.gz.asc
scp cl-utilities-latest.tar.gz pscott at common-lisp.net:/project/cl-utilities/public_html/cl-utilities-latest.tar.gz
scp cl-utilities-latest.tar.gz.asc pscott at 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))
+ , at 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)
More information about the Cl-utilities-cvs
mailing list