From 2d1abfffec61a842c734ec6acb64c49c847f02fb Mon Sep 17 00:00:00 2001 From: "Thomas M. Hermann" Date: Mon, 15 Oct 2012 22:45:24 -0500 Subject: [PATCH] Unpdated norms with internal unit tests. --- README.md | 2 +- extensions/floating-point.lisp | 90 +++++++++++++++-------------- internal-test/floating-point.lisp | 115 ++++++++++++++++++++++++++++++++++++++ 3 files changed, 163 insertions(+), 44 deletions(-) create mode 100644 internal-test/floating-point.lisp diff --git a/README.md b/README.md index f468fd8..b215a87 100644 --- a/README.md +++ b/README.md @@ -18,7 +18,7 @@ loaded using either [Quicklisp][] or [ASDF][]. 2. Load using [Quicklisp][] : `(ql:quickload :lisp-unit)`. 3. Load using [ASDF][] : `(asdf:load-system :lisp-unit)`. -## Version 0.9.0 Features +## Version 0.9.2 Features ### Simplified Interface diff --git a/extensions/floating-point.lisp b/extensions/floating-point.lisp index ac0b341..9d0cf42 100644 --- a/extensions/floating-point.lisp +++ b/extensions/floating-point.lisp @@ -372,65 +372,69 @@ comparison of the relative error is less than epsilon." p)) ;;; (NORM data) => float -(defun %seq-1-norm (data) - "Return the Taxicab norm of the sequence." - ;; FIXME : Use the LOOP. - (reduce (lambda (x y) (+ x (abs y))) - data :initial-value 0)) - -(defun %seq-2-norm (data) - "Return the Euclidean norm of the sequence." + +(defgeneric %norm (data measure) + (:documentation + "Return the norm of the data according to measure.")) + +(defmethod %norm ((data list) (measure (eql 1))) + "Return the Taxicab norm of the list." + (loop for item in data sum (abs item))) + +(defmethod %norm ((data vector) (measure (eql 1))) + "Return the Taxicab norm of the vector." + (loop for item across data sum (abs item))) + +(defmethod %norm ((data list) (measure (eql 2))) + "Return the Euclidean norm of the list." + (multiple-value-bind (scale sumsq) + (sumsq (map-into (make-array (length data)) #'abs data)) + (* scale (sqrt sumsq)))) + +(defmethod %norm ((data vector) (measure (eql 2))) + "Return the Euclidean norm of the vector." (multiple-value-bind (scale sumsq) (sumsq (map-into (make-array (length data)) #'abs data)) (* scale (sqrt sumsq)))) -(defun %seq-p-norm (data p) - "Return the p norm of the sequence." +(defmethod %norm ((data list) (measure integer)) + "Return the Euclidean norm of the list." (multiple-value-bind (scale sump) - (sump (map-into (make-array (length data)) #'abs data) p) - (* scale (expt sump (/ p))))) + (sump (map-into (make-array (length data)) #'abs data) + measure) + (* scale (expt sump (/ measure))))) -(defun %seq-inf-norm (data) - "Return the infinity, or maximum, norm of the sequence." - ;; FIXME : Use the LOOP. - (reduce (lambda (x y) (max x (abs y))) - data :initial-value 0)) +(defmethod %norm ((data vector) (measure integer)) + "Return the Euclidean norm of the vector." + (multiple-value-bind (scale sump) + (sump (map-into (make-array (length data)) #'abs data) + measure) + (* scale (expt sump (/ measure))))) -(defun %seq-norm (data measure) - "Return the norm of the sequence according to the measure." - (cond - ((equalp measure 1) - (%seq-1-norm data)) - ((equalp measure 2) - (%seq-2-norm data)) - ((numberp measure) - (%seq-p-norm data measure)) - ((equalp measure :infinity) - (%seq-inf-norm data)) - (t (error "Unrecognized norm, ~A." measure)))) +(defmethod %norm ((data list) (measure (eql :infinity))) + "Return the infinity, or maximum, norm of the list." + (loop for item in data maximize (abs item))) + +(defmethod %norm ((data vector) (measure (eql :infinity))) + "Return the infinity, or maximum, norm of the vector." + (loop for item across data maximize (abs item))) (defmethod norm ((data list) &optional (measure *measure*)) "Return the norm of the list according to the measure." - (%seq-norm data measure)) + (%norm data measure)) (defmethod norm ((data vector) &optional (measure *measure*)) "Return the norm of the vector according to the measure." - (%seq-norm data measure)) + (%norm data measure)) (defmethod norm ((data array) &optional (measure *measure*)) "Return the entrywise norm of the array according to the measure." - (let ((flat-data (make-array (array-total-size data) - :element-type (array-element-type data) - :displaced-to data))) - (cond - ((and (numberp measure) (< 0 measure)) - (warn "Measure ~D results in an entrywise p-norm." measure) - (%seq-p-norm flat-data measure)) - ((equalp measure :frobenius) - (%seq-2-norm flat-data)) - ((equalp measure :max) - (%seq-inf-norm flat-data)) - (t (error "Unrecognized norm, ~A." measure))))) + (%norm + (make-array + (array-total-size data) + :element-type (array-element-type data) + :displaced-to data) + measure)) ;;; (RELATIVE-ERROR-NORM exact approximate measure) => float (defun %relative-error-norm (exact approximate measure) diff --git a/internal-test/floating-point.lisp b/internal-test/floating-point.lisp new file mode 100644 index 0000000..2c89e58 --- /dev/null +++ b/internal-test/floating-point.lisp @@ -0,0 +1,115 @@ +#| + + LISP-UNIT Floating Point Tests + + Copyright (c) 2010-2012, Thomas M. Hermann + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are + met: + + o Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + o Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + o The names of the contributors may not be used to endorse or promote + products derived from this software without specific prior written + permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +|# + +(in-package :lisp-unit) + +;;; List norms + +(define-test %norm-list + "Internal test of %norm on lists." + (:tag :norm) + ;; Taxicab norm + (assert-rational-equal + 36 (%norm '(-6 -5 -4 -3 -2 -1 0 1 2 3 4 5) 1)) + (assert-float-equal + 19.535658 + (%norm + '(#C(1 0) #C(3 1) #C(2 3) #C(0 4) + #C(-2 3) #C(-3 1) #C(-1 0)) + 1)) + ;; Euclidean norm + (assert-float-equal + 12.083046 + (%norm '(-6 -5 -4 -3 -2 -1 0 1 2 3 4 5) 2)) + (assert-float-equal + 8.0 + (%norm + '(#C(1 0) #C(3 1) #C(2 3) #C(0 4) + #C(-2 3) #C(-3 1) #C(-1 0)) 2)) + ;; P-norm + (let ((data '(-6 -5 -4 -3 -2 -1 0 1 2 3 4 5)) + (zdata '(#C(1 0) #C(3 1) #C(2 3) #C(0 4) + #C(-2 3) #C(-3 1) #C(-1 0)))) + (assert-float-equal 8.732892 (%norm data 3)) + (assert-float-equal 6.064035 (%norm zdata 3))) + ;; Infinity norm + (assert-rational-equal + 6 (%norm + '(-6 -5 -4 -3 -2 -1 0 1 2 3 4 5) + :infinity)) + (assert-float-equal + 4.0 (%norm + '(#C(1 0) #C(3 1) #C(2 3) #C(0 4) + #C(-2 3) #C(-3 1) #C(-1 0)) + :infinity))) + +;;; Vector norms + +(define-test %norm-vector + "Internal test of %norm on vectors" + (:tag :norm) + ;; Taxicab norm + (assert-rational-equal + 36 (%norm #(-6 -5 -4 -3 -2 -1 0 1 2 3 4 5) 1)) + (assert-float-equal + 19.535658 + (%norm + #(#C(1 0) #C(3 1) #C(2 3) #C(0 4) + #C(-2 3) #C(-3 1) #C(-1 0)) + 1)) + ;; Euclidean norm + (assert-float-equal + 12.083046 + (%norm #(-6 -5 -4 -3 -2 -1 0 1 2 3 4 5) 2)) + (assert-float-equal + 8.0 + (%norm + #(#C(1 0) #C(3 1) #C(2 3) #C(0 4) + #C(-2 3) #C(-3 1) #C(-1 0)) + 2)) + ;; P-norm + (let ((data #(-6 -5 -4 -3 -2 -1 0 1 2 3 4 5)) + (zdata #(#C(1 0) #C(3 1) #C(2 3) #C(0 4) + #C(-2 3) #C(-3 1) #C(-1 0)))) + (assert-float-equal 8.732892 (%norm data 3)) + (assert-float-equal 6.064035 (%norm zdata 3))) + ;; Infinity norm + (assert-rational-equal + 6 (%norm #(-6 -5 -4 -3 -2 -1 0 1 2 3 4 5) :infinity)) + (assert-float-equal + 4.0 (%norm + #(#C(1 0) #C(3 1) #C(2 3) #C(0 4) + #C(-2 3) #C(-3 1) #C(-1 0)) + :infinity))) -- 2.11.4.GIT