external/clem/src/defmatrix.lisp

   1 ;;;; File: defmatrix.cl
   2 ;;;; Author: Cyrus Harmon
   3 ;;;;
   4 ;;;; This file contains definitions for typed matrices. Typed
   5 ;;;; matrices have elements that are of a single type (although
   6 ;;;; this type can have mutliple subtypes; even a t-matrix where
   7 ;;;; each of the items is of type t can offer substantial
   8 ;;;; performance gains, at least on SBCL).
   9 ;;;;
  10
  11 (in-package :clem)
  12
  13 (defmacro with-map-range (m element-type startr endr startc endc (a i j) &body body)
  14   `(with-matrix-vals (,m ,element-type ,a)
  15      (do ((,i ,startr (1+ ,i)))
  16          ((> ,i ,endr))
  17        (declare (dynamic-extent ,i) (type fixnum ,i))
  18        (do ((,j ,startc (1+ ,j)))
  19            ((> ,j ,endc))
  20          (declare (dynamic-extent ,j) (type fixnum ,j))
  21          ,@body))))
  22
  23 (defmacro with-typed-map-range (m element-type startr endr startc endc (a i j) &body body)
  24   `(with-typed-matrix-vals (,m ,element-type ,a)
  25      (do ((,i ,startr (1+ ,i)))
  26          ((> ,i ,endr))
  27        (declare (dynamic-extent ,i) (type fixnum ,i))
  28        (do ((,j ,startc (1+ ,j)))
  29            ((> ,j ,endc))
  30          (declare (dynamic-extent ,j) (type fixnum ,j))
  31          ,@body))))
  32
  33 (defmacro with-matrix-range-do (matrix-class m n p
  34                                 startr endr startc endc (a b c i j) &body body)
  35   (let ((mat-class (if (typep matrix-class 'class)
  36                        matrix-class
  37                        (find-class matrix-class))))
  38     (let ((element-type (element-type mat-class)))
  39       `(with-matrix-vals (,m ,element-type ,a)
  40          (with-matrix-vals (,n ,element-type ,b)
  41            (with-matrix-vals (,p ,element-type ,c)
  42              (do ((,i ,startr (1+ ,i)))
  43                  ((> ,i ,endr))
  44                (declare #-sbcl (dynamic-extent ,i) (type fixnum ,i))
  45                (do ((,j ,startc (1+ ,j)))
  46                    ((> ,j ,endc))
  47                  (declare #-sbcl (dynamic-extent ,j) (type fixnum ,j))
  48                  ,@body))))))))
  49
  50
  51 (defmacro defmatrixfuncs (type &key
  52                           (element-type 'double-float)
  53                           (accumulator-type 'double-float)
  54                           minval maxval)
  55   `(progn
  56      #+nil
  57      (defmethod mref ((m ,type) (row fixnum) (col fixnum))
  58        (with-typed-matrix-vals (m ,element-type a)
  59          (aref a row col)))
  60
  61      #+nil
  62      (defmethod (setf mref) (v (m ,type) (row fixnum) (col fixnum))
  63        (with-typed-matrix-vals (m ,element-type a)
  64          (setf (aref a row col) v)))
  65
  66      (defgeneric ,(ch-util:make-intern
  67                    (concatenate 'string "array->" (symbol-name type))) (a))
  68      (defmethod ,(ch-util:make-intern
  69                   (concatenate 'string "array->" (symbol-name type))) ((a array))
  70        (array->matrix a :matrix-class ',type))
  71
  72      (defmethod sample-variance-range ((m ,type)
  73                                        (startr fixnum) (endr fixnum)
  74                                        (startc fixnum) (endc fixnum))
  75        (let ((acc (coerce 0 ',accumulator-type)))
  76          (let ((mu (mean-range m startr endr startc endc)))
  77            (let ((musq (* mu mu)))
  78              (with-map-range m ,element-type startr endr startc endc (a i j)
  79                (incf acc (- (* (aref a i j) (aref a i j)) musq)))))
  80          (double-float-divide acc (1- (count-range startr endr startc endc)))))
  81
  82      (defmethod set-val ((m ,type) i j v &key (coerce t))
  83       (declare (fixnum i j))
  84        (setf (aref (matrix-vals m) i j)
  85              (if coerce
  86                  (coerce v (element-type (class-of m)))
  87                  v)))
  88
  89      (defmethod fit ((m ,type) v)
  90        (declare (ignore m))
  91        ,(if (subtypep element-type 'real)
  92             (if maxval
  93                 `(if (> v ,maxval)
  94                      ,maxval
  95                      ,(if minval `(if (< v ,minval) ,minval v) `v))
  96                 (if minval `(if (< v ,minval) ,minval v) `v))
  97             `v))
  98
  99      (defmethod set-val-fit ((m ,type) i j v &key (truncate nil))
 100        (set-val m i j (coerce
 101                        ,(if (and (subtypep element-type 'real) minval maxval)
 102                             `(cond ((< v ,minval) ,minval)
 103                                    ((> v ,maxval) ,maxval)
 104                                    (t (if truncate (truncate v) v)))
 105                             `(if truncate (truncate v) v))
 106                        (element-type (class-of m)))))
 107
 108      (defmethod map-set-val ((m ,type) f)
 109        (destructuring-bind (rows cols) (mapcar #'1- (dim m))
 110          (declare (dynamic-extent rows cols) (fixnum rows cols))
 111          (with-map-range m ,element-type 0 rows 0 cols (a i j)
 112            (setf (aref a i j) (funcall f (aref a i j)))))
 113        m)
 114
 115      (defgeneric
 116          ,(ch-util:make-intern (concatenate 'string "random-" (symbol-name type)))
 117          (rows cols &key max))
 118      (defmethod
 119          ,(ch-util:make-intern (concatenate 'string "random-" (symbol-name type)))
 120          (rows cols &key (max nil))
 121        (let ((a (make-instance ',type :rows rows :cols cols))
 122              (maxvalue (if max
 123                            max
 124                            ,(if maxval maxval 255))))
 125          (map-set-val-fit a #'(lambda (x) (declare (ignore x))
 126                                       ,(if (subtypep element-type 'integer)
 127                                            `(coerce (random (1+ maxvalue)) ',element-type)
 128                                            `(random (coerce maxvalue ',element-type))))
 129                           :truncate nil)
 130          a))
 131
 132      (defmethod normalize ((u ,type) &key normin normax copy)
 133        (let ((min (min-val u))
 134              (max (max-val u))
 135              (nmin (if normin normin ,(if minval minval 0)))
 136              (nmax (if normax normax ,(if maxval maxval 255)))
 137              (u (if copy (mat-copy u) u)))
 138          (let ((slope (if (= max min)
 139                           0d0
 140                           (double-float-divide (- nmax nmin)  (- max min)))))
 141            (map-set-val-fit u #'(lambda (x) (+ nmin (* slope (- x min))))))
 142          u))
 143
 144      ,(cond ((and (find-class 'integer-matrix nil)
 145                   (member (find-class 'integer-matrix)
 146                           (class-precedence-list (find-class type))))
 147              `(progn
 148                 (defmethod scalar-divide-row ((m ,type)  k q)
 149                   (with-typed-matrix-vals (m ,element-type a)
 150                     (dotimes (j (cols m))
 151                       (setf (aref a k j) (fit m (truncate (aref a k j) q)))))
 152                   m)
 153                 (defmethod scalar-mult-row ((m ,type) k q)
 154                   (with-typed-matrix-vals (m ,element-type a)
 155                     (dotimes (j (cols m))
 156                       (setf (aref a k j) (fit m (truncate (* (aref a k j) q))))))
 157                   m)))
 158             (t `(progn
 159                   (defmethod scalar-divide-row ((m ,type)  k q)
 160                     (with-typed-matrix-vals (m ,element-type a)
 161                       (dotimes (j (cols m))
 162                         (setf (aref a k j) (fit m (/ (aref a k j) q)))))
 163                     m)
 164                   (defmethod scalar-mult-row ((m ,type) k q)
 165                     (with-typed-matrix-vals (m ,element-type a)
 166                       (dotimes (j (cols m))
 167                         (setf (aref a k j) (fit m (* (aref a k j) q)))))
 168                     m))))))
 169
 170
 171 (defmacro def-move-element (type-1 type-2)
 172   (let ((element-type-1 (element-type (find-class `,type-1)))
 173         (element-type-2 (element-type (find-class `,type-2))))
 174     `(progn
 175        (defmethod move-element
 176            ((m ,type-1) i1 j1 (n ,type-2) i2 j2)
 177          (with-matrix-vals (m ,element-type-1 a)
 178            (with-matrix-vals (n ,element-type-2 b)
 179              (setf (aref b i2 j2)
 180                    ,(if (eql element-type-1 element-type-2)
 181                         `(aref a i1 j1)
 182                         `(coerce (aref a i1 j1) ',element-type-2)))))))))
 183
 184 (defmacro maybe-coerce (val type-1 type-2)
 185   (if (eql type-1 type-2)
 186       val
 187       `(coerce ,val ',type-2)))
 188
 189 (defmacro maybe-truncate (val type-1 type-2)
 190   (if (and (subtypep type-2 'integer)
 191            (and (subtypep type-1 'real)
 192                 (not (subtypep type-1 'integer))))
 193       `(nth-value 0 (truncate ,val))
 194       `(maybe-coerce ,val ,type-1 ,type-2)))
 195