external/clem/src/arithmetic.lisp

   1 ;;; arithmetic.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 ;;;;
  34 ;;;; level-1 arithmetic functions
  35
  36 (defmethod m+ (&rest matrices)
  37   (reduce #'mat-add matrices))
  38
  39 (defmethod m- (&rest matrices)
  40   (if (cdr matrices)
  41       (reduce #'mat-subtr matrices)
  42       (mat-scale (car matrices) -1)))
  43
  44 (defmethod m* (&rest matrices)
  45   (reduce
  46    #'(lambda (x y)
  47        (cond ((and (typep y 'matrix)
  48                    (typep x 'matrix))
  49               (mat-mult x y))
  50              ((and (typep x 'matrix)
  51                    (numberp y))
  52               (mat-scale x y))
  53              ((and (numberp x)
  54                    (typep y 'matrix))
  55               (mat-scale y x))
  56              (t (error 'matrix-argument-error
  57                        :format-control "At least one argument (~{~S~^ ~}) must be a MATRIX."
  58                        :format-arguments (list matrices)))))
  59    matrices))
  60
  61 (defmethod m.* (&rest matrices)
  62   (reduce #'mat-hprod matrices))
  63