external/clem/src/add.lisp

   1 ;;; add.lisp
   2 ;;; macros, functions and methods for matrix addition
   3 ;;;
   4 ;;; Copyright (c) 2004-2006 Cyrus Harmon (ch-lisp@bobobeach.com)
   5 ;;; All rights reserved.
   6 ;;;
   7 ;;; Redistribution and use in source and binary forms, with or without
   8 ;;; modification, are permitted provided that the following conditions
   9 ;;; are met:
  10 ;;;
  11 ;;;   * Redistributions of source code must retain the above copyright
  12 ;;;     notice, this list of conditions and the following disclaimer.
  13 ;;;
  14 ;;;   * Redistributions in binary form must reproduce the above
  15 ;;;     copyright notice, this list of conditions and the following
  16 ;;;     disclaimer in the documentation and/or other materials
  17 ;;;     provided with the distribution.
  18 ;;;
  19 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  20 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  21 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  22 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  23 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  24 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  25 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  26 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  27 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  28 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  29 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  30 ;;;
  31
  32 (in-package :clem)
  33
  34 ;;; slow version
  35 (defmethod mat-add ((a matrix) (b matrix) &key in-place)
  36   (if in-place
  37       (error "not yet supported")
  38       (mat-scalar-op a b #'+)))
  39
  40 ;;; faster version
  41 (defmacro def-matrix-add-range (type-1 type-2 accumulator-type &key suffix)
  42   (let ((element-type-1 (element-type (find-class `,type-1)))
  43         (element-type-2 (element-type (find-class `,type-2)))
  44         (accumulator-element-type (element-type (find-class `,accumulator-type))))
  45     `(progn
  46        (defmethod ,(ch-util:make-intern (concatenate 'string "mat-add-range" suffix))
  47            ((m ,type-1) (n ,type-2) startr endr startc endc &key in-place)
  48          (destructuring-bind (mr mc) (dim m)
  49            (if in-place
  50                (progn
  51                  (clem::mloop-range (((m ,element-type-1 a)
  52                                       (n ,element-type-2 b))
  53                                      startr endr startc endc i j)
  54                    (setf (aref a i j) (+ (aref a i j) (aref b i j))))
  55                  m)
  56                (let ((p (make-instance ',accumulator-type :rows mr :cols mc)))
  57                  (clem::mloop-range (((m ,element-type-1 a)
  58                                       (n ,element-type-2 b)
  59                                       (p ,accumulator-element-type c))
  60                                      startr endr startc endc i j)
  61                    (setf (aref c i j) (+ (aref a i j) (aref b i j))))
  62                  p)))))))
  63
  64
  65 (macrolet ((frob (type-1 type-2 type-3 &key suffix)
  66              `(progn
  67                 (def-binary-op "mat-add" + ,type-1 ,type-2 ,type-3)
  68                 (def-matrix-add-range ,type-1 ,type-2 ,type-3 :suffix ,suffix))))
  69
  70   (frob double-float-matrix double-float-matrix double-float-matrix)
  71   (frob double-float-matrix single-float-matrix double-float-matrix)
  72   (frob double-float-matrix ub8-matrix double-float-matrix)
  73   (frob double-float-matrix ub16-matrix double-float-matrix)
  74   (frob double-float-matrix ub32-matrix double-float-matrix)
  75   (frob double-float-matrix sb8-matrix double-float-matrix)
  76   (frob double-float-matrix sb16-matrix double-float-matrix)
  77   (frob double-float-matrix sb32-matrix double-float-matrix)
  78   (frob double-float-matrix bit-matrix double-float-matrix)
  79   (frob double-float-matrix fixnum-matrix double-float-matrix)
  80
  81   (frob single-float-matrix single-float-matrix single-float-matrix)
  82   (frob single-float-matrix ub8-matrix single-float-matrix)
  83   (frob single-float-matrix ub16-matrix single-float-matrix)
  84   (frob single-float-matrix ub32-matrix single-float-matrix)
  85   (frob single-float-matrix sb8-matrix single-float-matrix)
  86   (frob single-float-matrix sb16-matrix single-float-matrix)
  87   (frob single-float-matrix sb32-matrix single-float-matrix)
  88   (frob single-float-matrix bit-matrix single-float-matrix)
  89   (frob single-float-matrix fixnum-matrix single-float-matrix)
  90
  91   (frob ub8-matrix ub8-matrix ub8-matrix)
  92   (frob ub16-matrix ub16-matrix ub16-matrix)
  93   (frob ub32-matrix ub8-matrix ub32-matrix)
  94   (frob ub32-matrix ub32-matrix ub32-matrix)
  95
  96   (frob sb8-matrix sb8-matrix sb16-matrix)
  97   (frob sb16-matrix sb16-matrix sb32-matrix)
  98   (frob sb32-matrix sb8-matrix sb32-matrix)
  99   (frob sb32-matrix sb32-matrix sb32-matrix)
 100
 101   (frob ub8-matrix bit-matrix ub8-matrix)
 102   (frob ub16-matrix bit-matrix ub16-matrix)
 103   (frob ub32-matrix bit-matrix ub32-matrix)
 104
 105   (frob sb8-matrix bit-matrix sb8-matrix)
 106   (frob sb16-matrix bit-matrix sb16-matrix)
 107   (frob sb32-matrix bit-matrix sb32-matrix)
 108
 109   (frob sb32-matrix ub8-matrix sb32-matrix)
 110   (frob sb32-matrix ub16-matrix sb32-matrix)
 111
 112   (frob real-matrix real-matrix real-matrix)
 113   (frob real-matrix double-float-matrix real-matrix)
 114   (frob real-matrix single-float-matrix real-matrix)
 115   (frob real-matrix integer-matrix real-matrix)
 116
 117   (frob integer-matrix integer-matrix integer-matrix)
 118
 119   (frob complex-matrix complex-matrix complex-matrix)
 120   (frob complex-matrix integer-matrix complex-matrix)
 121   (frob complex-matrix real-matrix complex-matrix))
 122
 123
 124 (macrolet ((frob (type-1 type-2 type-3)
 125              `(progn
 126                 (def-binary-op "mat-add" + ,type-1 ,type-2 ,type-3 :allow-in-place nil))))
 127   (frob single-float-matrix double-float-matrix double-float-matrix)
 128
 129   (frob bit-matrix bit-matrix ub32-matrix)
 130
 131   (frob ub8-matrix double-float-matrix double-float-matrix)
 132   (frob ub8-matrix single-float-matrix single-float-matrix)
 133
 134   (frob ub16-matrix double-float-matrix double-float-matrix)
 135   (frob ub16-matrix single-float-matrix single-float-matrix)
 136
 137   (frob ub32-matrix double-float-matrix double-float-matrix)
 138   (frob ub32-matrix single-float-matrix single-float-matrix)
 139
 140   (frob sb8-matrix double-float-matrix double-float-matrix)
 141   (frob sb8-matrix single-float-matrix single-float-matrix)
 142
 143   (frob sb16-matrix double-float-matrix double-float-matrix)
 144   (frob sb16-matrix single-float-matrix single-float-matrix)
 145
 146   (frob sb32-matrix double-float-matrix double-float-matrix)
 147   (frob sb32-matrix single-float-matrix single-float-matrix)
 148
 149   (frob fixnum-matrix double-float-matrix double-float-matrix)
 150   (frob fixnum-matrix single-float-matrix single-float-matrix)
 151
 152   (frob bit-matrix double-float-matrix double-float-matrix)
 153   (frob bit-matrix single-float-matrix single-float-matrix))
 154
 155
 156 (defmacro def-matrix-add-number (type-1 type-2 accumulator-type &key suffix (allow-in-place t))
 157   (let ((element-type-1 (element-type (find-class `,type-1)))
 158         (accumulator-element-type (element-type (find-class `,accumulator-type))))
 159     `(progn
 160        (defmethod ,(ch-util:make-intern (concatenate 'string "mat-add-range" suffix))
 161            ((m ,type-1) (n ,type-2) startr endr startc endc &key in-place)
 162          (declare (type ,type-2 n))
 163          (destructuring-bind (mr mc) (dim m)
 164            (if in-place
 165                ,(if allow-in-place
 166                     `(with-typed-mref (m ,element-type-1)
 167                       (do ((i startr (1+ i)))
 168                           ((> i endr))
 169                         (declare (dynamic-extent i) (type fixnum i))
 170                         (do ((j startc (1+ j)))
 171                             ((> j endc))
 172                           (declare (dynamic-extent j) (type fixnum j))
 173                           (setf (mref m i j)
 174                                 (+ (mref m i j) n))))
 175                       m)
 176                     `(error 'matrix-argument-error
 177                             :format-control
 178                             "in-place operation not allowed (~S of ~S and ~S)"
 179                             :format-arguments (list '+ ',type-1 ',type-2)))
 180                (let ((p (make-instance ',accumulator-type :rows mr :cols mc)))
 181                  (with-typed-mref (m ,element-type-1)
 182                    (with-typed-mref (p ,accumulator-element-type)
 183                      (do ((i startr (1+ i)))
 184                          ((> i endr))
 185                        (declare (dynamic-extent i) (type fixnum i))
 186                        (do ((j startc (1+ j)))
 187                            ((> j endc))
 188                          (declare (dynamic-extent j) (type fixnum j))
 189                          (setf (mref p i j)
 190                                (+ (mref m i j) n))))))
 191                  p))))
 192
 193        (defmethod ,(ch-util:make-intern (concatenate 'string "mat-add" suffix))
 194            ((m ,type-1) (n ,type-2) &key in-place)
 195          (if in-place
 196              ,(if allow-in-place
 197                   `(with-typed-mref (m ,element-type-1)
 198                      (loop for i from 0 below (matrix-total-size m)
 199                         do (setf (row-major-mref m i)
 200                                  (+ (row-major-mref m i) n)))
 201                      m)
 202                   `(error 'matrix-argument-error
 203                           :format-control
 204                           "in-place operation not allowed (~S of ~S and ~S"
 205                           :format-arguments (list '+ ',type-1 ',type-2)))
 206              (let ((p (make-instance ',accumulator-type :dimensions (matrix-dimensions m))))
 207                (with-typed-mref (m ,element-type-1)
 208                  (with-typed-mref (p ,accumulator-element-type)
 209                    (loop for i from 0 below (matrix-total-size m)
 210                       do (setf (row-major-mref p i)
 211                                (+ (row-major-mref m i) n)))))
 212                p))))))
 213
 214 (macrolet ((frob (type-1 type-2 type-3 &key suffix)
 215              `(progn
 216                 (def-matrix-add-number ,type-1 ,type-2 ,type-3 :suffix ,suffix))))
 217   (frob double-float-matrix double-float double-float-matrix)
 218   (frob double-float-matrix single-float double-float-matrix)
 219   (frob double-float-matrix integer double-float-matrix)
 220
 221   (frob integer-matrix integer integer-matrix))
 222
 223 (macrolet ((frob (type-1 type-2 type-3 &key suffix)
 224              `(progn
 225                 (def-matrix-add-number ,type-1 ,type-2 ,type-3 :suffix ,suffix :allow-in-place nil))))
 226
 227   (frob ub8-matrix integer integer-matrix)
 228   (frob ub8-matrix double-float double-float-matrix)
 229   (frob ub8-matrix single-float single-float-matrix))
 230
 231 (defmacro def-matrix-add-scalar (type-1 type-2 accumulator-type &key suffix)
 232   (let ((element-type-1 (element-type (find-class `,type-1)))
 233         (element-type-2 (element-type (find-class `,type-2)))
 234         (accumulator-element-type (element-type (find-class `,accumulator-type))))
 235     `(progn
 236        (defmethod ,(ch-util:make-intern (concatenate 'string "mat-add-range" suffix))
 237            ((m ,type-1) (n ,type-2) startr endr startc endc &key in-place)
 238          (declare (type ,type-2 n))
 239          (let ((val (clem::scalar-val n)))
 240            (declare (type ,element-type-2 val))
 241            (destructuring-bind (mr mc) (dim m)
 242              (if in-place
 243                  (progn
 244                    (with-typed-mref (m ,element-type-1)
 245                      (do ((i startr (1+ i)))
 246                          ((> i endr))
 247                        (declare (dynamic-extent i) (type fixnum i))
 248                        (do ((j startc (1+ j)))
 249                            ((> j endc))
 250                          (declare (dynamic-extent j) (type fixnum j))
 251                          (setf (mref m i j)
 252                                (+ (mref m i j) val)))))
 253                    m)
 254                  (let ((p (make-instance ',accumulator-type :rows mr :cols mc)))
 255                    (with-typed-mref (m ,element-type-1)
 256                      (with-typed-mref (p ,accumulator-element-type)
 257                        (do ((i startr (1+ i)))
 258                            ((> i endr))
 259                          (declare (dynamic-extent i) (type fixnum i))
 260                          (do ((j startc (1+ j)))
 261                              ((> j endc))
 262                            (declare (dynamic-extent j) (type fixnum j))
 263                            (setf (mref p i j)
 264                                  (+ (mref m i j) val))))))
 265                    p)))))
 266
 267        (defmethod ,(ch-util:make-intern (concatenate 'string "mat-add" suffix))
 268            ((m ,type-1) (n ,type-2) &key in-place)
 269          (let ((val (clem::scalar-val n)))
 270            (declare (type ,element-type-2 val))
 271            (if in-place
 272                (with-typed-mref (m ,element-type-1)
 273                  (loop for i from 0 below (matrix-total-size m)
 274                     do (setf (row-major-mref m i)
 275                              (+ (row-major-mref m i) val)))
 276                  m)
 277                (let ((p (make-instance ',accumulator-type :dimensions (matrix-dimensions m))))
 278                  (with-typed-mref (m ,element-type-1)
 279                    (with-typed-mref (p ,accumulator-element-type)
 280                      (loop for i from 0 below (matrix-total-size m)
 281                         do (setf (row-major-mref p i)
 282                                  (+ (row-major-mref m i) val)))))
 283                  p)))
 284          ))))
 285
 286 (macrolet ((frob (type-1 type-2 type-3 &key suffix)
 287              `(progn
 288                 (def-matrix-add-scalar ,type-1 ,type-2 ,type-3 :suffix ,suffix))))
 289
 290   (frob ub8-matrix bit-scalar ub8-matrix)
 291   (frob ub8-matrix sb8-scalar ub8-matrix)
 292   (frob ub8-matrix ub8-scalar ub8-matrix))
 293