external/clem/src/sum.lisp

   1
   2 (in-package :clem)
   3
   4 ;;; slow fallback methods
   5 ;;; FIXME NEED FAST METHODS!!
   6
   7 (defmethod sum ((m matrix))
   8   (let ((acc 0))
   9     (loop for i from 0 below (matrix-total-size m)
  10        do (incf acc (row-major-mref m i)))
  11     acc))
  12
  13 (defmethod sum-cols ((m matrix) &key (matrix-class (class-of m)))
  14   (let ((mr (rows m)) (mc (cols m)))
  15     (let ((n (make-instance matrix-class :rows 1 :cols mc)))
  16       (dotimes (i mr)
  17         (dotimes (j mc)
  18           (incf (mref n 0 j) (mref m i j))))
  19       n)))
  20
  21 (defmethod sum-rows ((m matrix) &key (matrix-class (class-of m)))
  22   (let ((mr (rows m)) (mc (cols m)))
  23     (let ((n (make-instance matrix-class :rows mr :cols 1)))
  24       (dotimes (i mr)
  25         (dotimes (j mc)
  26           (incf (mref n i 0) (mref m i j))))
  27       n)))
  28
  29 (defmethod sum-square-range ((m matrix) (startr fixnum) (endr fixnum) (startc fixnum) (endc fixnum))
  30   (declare (dynamic-extent startr endr startc endc)
  31            (fixnum startr endr startc endc))
  32   (let ((acc 0))
  33     (map-range m startr endr startc endc
  34                #'(lambda (v i j)
  35                    (declare (ignore i j))
  36                    (incf acc (* v v))))
  37     acc))
  38
  39 (defmethod sum-square ((m matrix))
  40   (destructuring-bind (mr mc) (dim m)
  41     (sum-square-range m 0 (- mr 1) 0 (- mc 1))))
  42
  43 (defmethod sum-range ((m matrix) (startr fixnum) (endr fixnum) (startc fixnum) (endc fixnum))
  44   (declare (dynamic-extent startr endr startc endc)
  45            (fixnum startr endr startc endc))
  46   (let ((acc 0))
  47     (map-range m startr endr startc endc
  48                #'(lambda (v i j)
  49                    (declare (ignore i j))
  50                    (incf acc v)))
  51     acc))
  52
  53 ;;; faster type-specific methods
  54
  55 (defmacro %%sum-range (m startr endr startc endc element-type accumulator-type)
  56   `(let ((acc (coerce 0 ',accumulator-type))
  57          (a (matrix-vals ,m)))
  58      (declare (type ,accumulator-type acc)
  59               (type (simple-array ,element-type *) a))
  60      (do ((i ,startr (1+ i)))
  61          ((> i ,endr))
  62        (declare (dynamic-extent i) (type fixnum i))
  63        (do ((j ,startc (1+ j)))
  64            ((> j ,endc))
  65          (declare (dynamic-extent j) (type fixnum j))
  66          (setf acc (+ acc (aref a i j)))))
  67      acc))
  68
  69 (macrolet ((frob-sum (matrix-type accumulator-type)
  70              (let ((element-type (element-type (find-class matrix-type))))
  71                `(progn
  72                   (defmethod sum ((m ,matrix-type))
  73                     (let ((acc (coerce 0 ',accumulator-type)))
  74                       (declare (type ,accumulator-type acc))
  75                       (with-typed-mref (m ,element-type)
  76                         (loop for i from 0 below (matrix-total-size m)
  77                            do (incf acc (row-major-mref m i))))
  78                       acc))
  79
  80                   (defmethod sum-square ((m ,matrix-type))
  81                     (let ((acc (coerce 0 ',accumulator-type)))
  82                       (declare (type ,accumulator-type acc))
  83                       (with-typed-mref (m ,element-type)
  84                         (loop for i from 0 below (matrix-total-size m)
  85                            do (incf acc
  86                                     (* (row-major-mref m i)
  87                                        (row-major-mref m i)))))
  88                       acc))))))
  89   (frob-sum double-float-matrix double-float)
  90   (frob-sum single-float-matrix single-float)
  91
  92   (frob-sum ub8-matrix (unsigned-byte 32))
  93   (frob-sum ub16-matrix (unsigned-byte 32))
  94   (frob-sum ub32-matrix (unsigned-byte 32))
  95
  96   (frob-sum sb8-matrix (signed-byte 32))
  97   (frob-sum sb16-matrix (signed-byte 32))
  98   (frob-sum sb32-matrix (signed-byte 32))
  99
 100   (frob-sum fixnum-matrix (signed-byte 32))
 101   (frob-sum bit-matrix (signed-byte 32))
 102   (frob-sum integer-matrix integer)
 103   (frob-sum real-matrix real)
 104   (frob-sum number-matrix number))
 105
 106 (macrolet
 107     ((frob-sum-range (matrix-type accumulator-type)
 108        (let ((element-type (element-type (find-class matrix-type))))
 109          `(defmethod sum-range ((m ,matrix-type)
 110                                 (startr fixnum) (endr fixnum)
 111                                 (startc fixnum) (endc fixnum))
 112             (%%sum-range m startr endr startc endc
 113                          ,element-type ,accumulator-type)))))
 114   (frob-sum-range double-float-matrix double-float)
 115   (frob-sum-range single-float-matrix single-float)
 116
 117   (frob-sum-range ub8-matrix (unsigned-byte 32))
 118   (frob-sum-range ub16-matrix (unsigned-byte 32))
 119   (frob-sum-range ub32-matrix (unsigned-byte 32))
 120
 121   (frob-sum-range sb8-matrix (signed-byte 32))
 122   (frob-sum-range sb16-matrix (signed-byte 32))
 123   (frob-sum-range sb32-matrix (signed-byte 32))
 124
 125   (frob-sum-range fixnum-matrix (signed-byte 32))
 126   (frob-sum-range bit-matrix (signed-byte 32)))
 127
 128
 129 (macrolet
 130     ((frob-sum-square-range (matrix-type accumulator-type)
 131        (let ((element-type (element-type (find-class matrix-type))))
 132          `(defmethod sum-square-range ((m ,matrix-type) (startr fixnum) (endr fixnum) (startc fixnum) (endc fixnum))
 133             (let ((acc (coerce 0 ',accumulator-type))
 134                   (a (matrix-vals m)))
 135               (declare (type ,accumulator-type acc)
 136                        (type (simple-array ,element-type *) a))
 137               (do ((i startr (1+ i)))
 138                   ((> i endr))
 139                 (declare (dynamic-extent i) (type fixnum i))
 140                 (do ((j startc (1+ j)))
 141                     ((> j endc))
 142                   (declare (dynamic-extent j) (type fixnum j))
 143                   (incf acc (* (aref a i j) (aref a i j)))))
 144               acc)))))
 145
 146   (frob-sum-square-range double-float-matrix double-float)
 147   (frob-sum-square-range single-float-matrix single-float)
 148
 149   (frob-sum-square-range ub8-matrix (unsigned-byte 32))
 150   (frob-sum-square-range ub16-matrix (unsigned-byte 32))
 151   (frob-sum-square-range ub32-matrix (unsigned-byte 32))
 152
 153   (frob-sum-square-range sb8-matrix (signed-byte 32))
 154   (frob-sum-square-range sb16-matrix (signed-byte 32))
 155   (frob-sum-square-range sb32-matrix (signed-byte 32))
 156
 157   (frob-sum-square-range fixnum-matrix (signed-byte 32))
 158   (frob-sum-square-range bit-matrix (signed-byte 32)))
 159