clem 0.4.1, ch-asdf 0.2.8, ch-util 0.2.2, lift 1.3.1, darcs ignored, smarkup 0.3.3
[CommonLispStat.git] / external / clem / src / typed-ops / defmatrix-hprod.lisp
blob89ecffd34be63238acc93cb997303132a32a6137
2 (in-package :clem)
4 (defmacro def-matrix-hprod (type-1 type-2 accumulator-type &key suffix)
5 (let ((element-type-1 (element-type (find-class `,type-1)))
6 (element-type-2 (element-type (find-class `,type-2)))
7 (accumulator-element-type (element-type (find-class `,accumulator-type))))
8 `(progn
9 (defmethod ,(ch-util:make-intern (concatenate 'string "mat-hprod-range" suffix))
10 ((m ,type-1) (n ,type-2) startr endr startc endc)
11 (destructuring-bind (mr mc) (dim m)
12 (let ((p (make-instance ',accumulator-type :rows mr :cols mc)))
13 (with-matrix-vals (m ,element-type-1 a)
14 (with-matrix-vals (n ,element-type-2 b)
15 (with-matrix-vals (p ,accumulator-element-type c)
16 (do ((i startr (1+ i)))
17 ((> i endr))
18 (declare (dynamic-extent i) (type fixnum i))
19 (do ((j startc (1+ j)))
20 ((> j endc))
21 (declare (dynamic-extent j) (type fixnum j))
22 (setf (aref c i j)
23 (* (aref a i j) (aref b i j))))))))
24 p)))
26 (defmethod ,(ch-util:make-intern (concatenate 'string "mat-hprod" suffix))
27 ((m ,type-1) (n ,type-2))
28 (destructuring-bind (mr mc) (dim m)
29 (mat-hprod-range m n 0 (1- mr) 0 (1- mc)))))))
31 (defmacro def-matrix-hprod! (type-1 type-2 accumulator-type &key suffix)
32 (declare (ignore accumulator-type))
33 (let ((element-type-1 (element-type (find-class `,type-1)))
34 (element-type-2 (element-type (find-class `,type-2))))
35 `(progn
36 (defmethod ,(ch-util:make-intern (concatenate 'string "mat-hprod-range!" suffix))
37 ((m ,type-1) (n ,type-2) startr endr startc endc)
38 (with-matrix-vals (m ,element-type-1 a)
39 (with-matrix-vals (n ,element-type-2 b)
40 (do ((i startr (1+ i)))
41 ((> i endr))
42 (declare (dynamic-extent i) (type fixnum i))
43 (do ((j startc (1+ j)))
44 ((> j endc))
45 (declare (dynamic-extent j) (type fixnum j))
46 (setf (aref a i j)
47 (* (aref a i j) (aref b i j))))))
48 m))
50 (defmethod ,(ch-util:make-intern (concatenate 'string "mat-hprod!" suffix))
51 ((m ,type-1) (n ,type-2))
52 (destructuring-bind (mr mc) (dim m)
53 (mat-hprod-range! m n 0 (1- mr) 0 (1- mc)))))))
55 (macrolet ((frob (type-1 type-2 type-3 &key suffix)
56 `(progn
57 (def-matrix-hprod ,type-1 ,type-2 ,type-3 :suffix ,suffix)
58 (def-matrix-hprod! ,type-1 ,type-2 ,type-3 :suffix ,suffix))))
60 (frob double-float-matrix double-float-matrix double-float-matrix)
61 (frob double-float-matrix single-float-matrix double-float-matrix)
62 (frob double-float-matrix ub8-matrix double-float-matrix)
63 (frob double-float-matrix ub16-matrix double-float-matrix)
64 (frob double-float-matrix ub32-matrix double-float-matrix)
65 (frob double-float-matrix sb8-matrix double-float-matrix)
66 (frob double-float-matrix sb16-matrix double-float-matrix)
67 (frob double-float-matrix sb32-matrix double-float-matrix)
68 (frob double-float-matrix fixnum-matrix double-float-matrix)
69 (frob double-float-matrix bit-matrix double-float-matrix)
71 (frob single-float-matrix single-float-matrix single-float-matrix)
72 (frob single-float-matrix ub8-matrix single-float-matrix)
73 (frob single-float-matrix ub16-matrix single-float-matrix)
74 (frob single-float-matrix ub32-matrix single-float-matrix)
75 (frob single-float-matrix sb8-matrix single-float-matrix)
76 (frob single-float-matrix sb16-matrix single-float-matrix)
77 (frob single-float-matrix sb32-matrix single-float-matrix)
78 (frob single-float-matrix fixnum-matrix single-float-matrix)
79 (frob single-float-matrix bit-matrix single-float-matrix)
81 (frob ub8-matrix ub8-matrix ub8-matrix)
82 (frob ub8-matrix bit-matrix ub8-matrix)
84 (frob ub16-matrix ub16-matrix ub16-matrix)
85 (frob ub16-matrix ub8-matrix ub16-matrix)
86 (frob ub16-matrix bit-matrix ub16-matrix)
88 (frob ub32-matrix ub32-matrix ub32-matrix)
89 (frob ub32-matrix ub16-matrix ub32-matrix)
90 (frob ub32-matrix ub8-matrix ub32-matrix)
91 (frob ub32-matrix bit-matrix ub32-matrix)
93 (frob sb8-matrix sb8-matrix sb8-matrix)
94 (frob sb8-matrix bit-matrix sb8-matrix)
96 (frob sb16-matrix sb16-matrix sb16-matrix)
97 (frob sb16-matrix sb8-matrix sb16-matrix)
98 (frob sb16-matrix bit-matrix sb16-matrix)
100 (frob sb32-matrix sb32-matrix sb32-matrix)
101 (frob sb32-matrix sb16-matrix sb32-matrix)
102 (frob sb32-matrix sb8-matrix sb32-matrix)
103 (frob sb32-matrix bit-matrix sb32-matrix)
105 (frob fixnum-matrix fixnum-matrix fixnum-matrix)
106 (frob fixnum-matrix bit-matrix fixnum-matrix)
108 (frob bit-matrix bit-matrix bit-matrix))
110 (macrolet ((frob (type-1 type-2 type-3 &key suffix)
111 `(progn
112 (def-matrix-hprod ,type-1 ,type-2 ,type-3 :suffix ,suffix)
113 (def-matrix-hprod! ,type-1 ,type-2 ,type-3 :suffix ,suffix))))
115 (frob real-matrix double-float-matrix real-matrix)
116 (frob real-matrix single-float-matrix real-matrix)
117 (frob real-matrix ub8-matrix real-matrix)
118 (frob real-matrix ub16-matrix real-matrix)
119 (frob real-matrix ub32-matrix real-matrix)
120 (frob real-matrix sb8-matrix real-matrix)
121 (frob real-matrix sb16-matrix real-matrix)
122 (frob real-matrix sb32-matrix real-matrix)
123 (frob real-matrix real-matrix real-matrix)
124 (frob real-matrix number-matrix real-matrix)
125 (frob real-matrix bit-matrix real-matrix)
127 (frob complex-matrix double-float-matrix complex-matrix)
128 (frob complex-matrix single-float-matrix complex-matrix)
129 (frob complex-matrix ub8-matrix complex-matrix)
130 (frob complex-matrix ub16-matrix complex-matrix)
131 (frob complex-matrix ub32-matrix complex-matrix)
132 (frob complex-matrix sb8-matrix complex-matrix)
133 (frob complex-matrix sb16-matrix complex-matrix)
134 (frob complex-matrix sb32-matrix complex-matrix)
135 (frob complex-matrix real-matrix complex-matrix)
136 (frob complex-matrix complex-matrix complex-matrix)
137 (frob complex-matrix number-matrix complex-matrix)
138 (frob complex-matrix bit-matrix complex-matrix))