external/clem/src/abs.lisp

   1 ;;; abs.lisp
   2 ;;;
   3 ;;; Copyright (c) 2004-2006 Cyrus Harmon (ch-lisp@bobobeach.com)
   4 ;;; All rights reserved.
   5 ;;;
   6 ;;; Redistribution and use in source and binary forms, with or without
   7 ;;; modification, are permitted provided that the following conditions
   8 ;;; are met:
   9 ;;;
  10 ;;;   * Redistributions of source code must retain the above copyright
  11 ;;;     notice, this list of conditions and the following disclaimer.
  12 ;;;
  13 ;;;   * Redistributions in binary form must reproduce the above
  14 ;;;     copyright notice, this list of conditions and the following
  15 ;;;     disclaimer in the documentation and/or other materials
  16 ;;;     provided with the distribution.
  17 ;;;
  18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  21 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  29 ;;;
  30
  31 (in-package :clem)
  32
  33 ;;; slow version
  34
  35 (defmethod mabs ((u matrix))
  36   (map-set-val-copy u #'(lambda (x) (abs x))))
  37
  38 ;;; faster version
  39
  40 (defmacro def-matrix-abs (type-1 accumulator-type &key suffix)
  41   (let ((element-type-1 (element-type (find-class `,type-1)))
  42         (accumulator-element-type (element-type (find-class `,accumulator-type))))
  43     `(progn
  44        (defmethod ,(ch-util:make-intern (concatenate 'string "mat-abs-range" suffix))
  45            ((m ,type-1) startr endr startc endc)
  46          (destructuring-bind (mr mc) (dim m)
  47            (let ((p (make-instance ',accumulator-type :rows mr :cols mc)))
  48              (with-matrix-vals (m ,element-type-1 a)
  49                (with-matrix-vals (p ,accumulator-element-type c)
  50                  (do ((i startr (1+ i)))
  51                      ((> i endr))
  52                    (declare (dynamic-extent i) (type fixnum i))
  53                    (do ((j startc (1+ j)))
  54                        ((> j endc))
  55                      (declare (dynamic-extent j) (type fixnum j))
  56                      (setf (aref c i j)
  57                            (abs (aref a i j)))))))
  58              p)))
  59
  60        (defmethod ,(ch-util:make-intern (concatenate 'string "mat-abs" suffix))
  61            ((m ,type-1))
  62          (destructuring-bind (mr mc) (dim m)
  63            (,(ch-util:make-intern (concatenate 'string "mat-abs-range" suffix))
  64              m 0 (1- mr) 0 (1- mc)))))))
  65
  66 (defmacro def-matrix-abs! (type-1 &key suffix)
  67   (let ((element-type-1 (element-type (find-class `,type-1))))
  68     `(progn
  69        (defmethod ,(ch-util:make-intern (concatenate 'string "mat-abs-range!" suffix))
  70            ((m ,type-1) startr endr startc endc)
  71          (with-matrix-vals (m ,element-type-1 a)
  72            (do ((i startr (1+ i)))
  73                ((> i endr))
  74              (declare (dynamic-extent i) (type fixnum i))
  75              (do ((j startc (1+ j)))
  76                  ((> j endc))
  77                (declare (dynamic-extent j) (type fixnum j))
  78                (setf (aref a i j) (abs (aref a i j))))))
  79          m)
  80
  81        (defmethod ,(ch-util:make-intern (concatenate 'string "mat-abs!" suffix))
  82            ((m ,type-1))
  83          (destructuring-bind (mr mc) (dim m)
  84            (,(ch-util:make-intern (concatenate 'string "mat-abs-range!" suffix))
  85              m 0 (1- mr) 0 (1- mc)))))))
  86
  87 (macrolet ((frob (type-1 type-2 &key suffix)
  88              `(progn
  89                 (def-matrix-abs ,type-1 ,type-2 :suffix ,suffix)
  90                 (def-matrix-abs! ,type-1 :suffix ,suffix))))
  91   (frob double-float-matrix double-float-matrix)
  92   (frob single-float-matrix single-float-matrix)
  93   (frob bit-matrix bit-matrix)
  94   (frob integer-matrix integer-matrix)
  95   (frob t-matrix t-matrix))
  96
  97 (macrolet ((frob (type-1 type-2 &key suffix)
  98              `(progn
  99                 (def-matrix-abs ,type-1 ,type-2 :suffix ,suffix))))
 100   (frob ub8-matrix ub8-matrix)
 101   (frob ub16-matrix ub16-matrix)
 102   (frob ub32-matrix ub32-matrix)
 103   (frob sb8-matrix sb8-matrix)
 104   (frob sb16-matrix sb16-matrix)
 105   (frob sb32-matrix sb32-matrix)
 106   (frob fixnum-matrix fixnum-matrix)
 107   (frob real-matrix real-matrix)
 108   (frob complex-matrix real-matrix)
 109   (frob number-matrix real-matrix)
 110   (frob t-matrix t-matrix))
 111