2 ;;; macros, functions and methods for matrix element access
4 ;;; Copyright (c) 2004-2006 Cyrus Harmon (ch-lisp@bobobeach.com)
5 ;;; All rights reserved.
7 ;;; Redistribution and use in source and binary forms, with or without
8 ;;; modification, are permitted provided that the following conditions
11 ;;; * Redistributions of source code must retain the above copyright
12 ;;; notice, this list of conditions and the following disclaimer.
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.
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.
34 ;;; first the slow versions
36 (defmethod mat-subtr ((m matrix
) (n matrix
) &key in-place result-type
)
37 ;;; FIXME how about some sanity check on the args here please?
40 (loop for i from
0 below
(matrix-total-size m
)
41 do
(setf (row-major-mref m i
)
42 (- (row-major-mref m i
)
43 (row-major-mref n i
))))
46 (let ((p (if result-type
47 (make-instance result-type
:dimensions
(matrix-dimensions m
))
49 (loop for i from
0 below
(matrix-total-size m
)
50 do
(setf (row-major-mref p i
)
51 (- (row-major-mref m i
)
52 (row-major-mref n i
))))
55 (defmethod mat-subtr ((m number
) (n matrix
) &key in-place result-type
)
57 `(error 'matrix-argument-error
59 "in-place operation not allowed (~S of ~S and ~S"
60 :format-arguments
(list '- m n
))
62 (let ((p (if result-type
63 (make-instance result-type
:dimensions
(matrix-dimensions n
))
65 (loop for i from
0 below
(matrix-total-size n
)
66 do
(setf (row-major-mref p i
)
68 (row-major-mref n i
))))
71 (defmethod mat-subtr ((m matrix
) (n number
) &key in-place result-type
)
74 (loop for i from
0 below
(matrix-total-size m
)
75 do
(setf (row-major-mref m i
)
76 (- (row-major-mref m i
) n
)))
79 (let ((p (if result-type
80 (make-instance result-type
:dimensions
(matrix-dimensions m
))
82 (loop for i from
0 below
(matrix-total-size m
)
83 do
(setf (row-major-mref p i
)
84 (- (row-major-mref m i
) n
)))
88 (defgeneric %get-subtr-matrix-class
(a b
))
89 (defgeneric mat-subtr-range3
(m n p startr endr startc endc
))
91 (defmacro def-matrix-subtr
(type-1 type-2 accumulator-type
&key suffix
)
92 (let ((element-type-1 (element-type (find-class `,type-1
)))
93 (element-type-2 (element-type (find-class `,type-2
)))
94 (accumulator-element-type (element-type (find-class `,accumulator-type
))))
97 (defmethod %get-subtr-matrix-class
((a ,type-1
) (b ,type-2
))
100 (defmethod ,(ch-util:make-intern
(concatenate 'string
"mat-subtr-range3" suffix
))
101 ((m ,type-1
) (n ,type-2
) (p ,accumulator-type
) startr endr startc endc
)
102 (with-matrix-vals (m ,element-type-1 a
)
103 (with-matrix-vals (n ,element-type-2 b
)
104 (with-matrix-vals (p ,accumulator-element-type c
)
105 (do ((i startr
(1+ i
)))
107 (declare (dynamic-extent i
) (type fixnum i
))
108 (do ((j startc
(1+ j
)))
110 (declare (dynamic-extent j
) (type fixnum j
))
112 (- (aref a i j
) (aref b i j
))))))))
115 (macrolet ((frob (type-1 type-2 type-3
&key suffix
)
117 (def-matrix-subtr ,type-1
,type-2
,type-3
:suffix
,suffix
))))
119 (frob double-float-matrix double-float-matrix double-float-matrix
)
120 (frob double-float-matrix single-float-matrix double-float-matrix
)
121 (frob double-float-matrix ub8-matrix double-float-matrix
)
122 (frob double-float-matrix ub16-matrix double-float-matrix
)
123 (frob double-float-matrix ub32-matrix double-float-matrix
)
124 (frob double-float-matrix sb8-matrix double-float-matrix
)
125 (frob double-float-matrix sb16-matrix double-float-matrix
)
126 (frob double-float-matrix sb32-matrix double-float-matrix
)
127 (frob double-float-matrix bit-matrix double-float-matrix
)
128 (frob double-float-matrix fixnum-matrix double-float-matrix
)
130 (frob single-float-matrix single-float-matrix single-float-matrix
)
131 (frob single-float-matrix ub8-matrix single-float-matrix
)
132 (frob single-float-matrix ub16-matrix single-float-matrix
)
133 (frob single-float-matrix ub32-matrix single-float-matrix
)
134 (frob single-float-matrix sb8-matrix single-float-matrix
)
135 (frob single-float-matrix sb16-matrix single-float-matrix
)
136 (frob single-float-matrix sb32-matrix single-float-matrix
)
137 (frob single-float-matrix bit-matrix single-float-matrix
)
138 (frob single-float-matrix fixnum-matrix single-float-matrix
)
140 (frob ub8-matrix ub8-matrix ub8-matrix
)
141 (frob ub8-matrix ub8-matrix sb16-matrix
)
142 (frob ub16-matrix ub16-matrix ub16-matrix
)
143 (frob ub16-matrix ub16-matrix sb32-matrix
)
144 (frob ub32-matrix ub32-matrix ub32-matrix
)
145 (frob ub32-matrix ub32-matrix sb32-matrix
)
147 (frob sb8-matrix sb8-matrix sb8-matrix
)
148 (frob sb8-matrix sb8-matrix sb16-matrix
)
149 (frob sb16-matrix sb16-matrix sb32-matrix
)
150 (frob sb16-matrix sb16-matrix sb32-matrix
)
151 (frob sb32-matrix sb32-matrix sb32-matrix
)
152 (frob sb32-matrix sb32-matrix sb32-matrix
)
154 (frob ub8-matrix bit-matrix ub8-matrix
)
155 (frob ub16-matrix bit-matrix ub16-matrix
)
156 (frob ub32-matrix bit-matrix ub32-matrix
)
158 (frob sb8-matrix bit-matrix sb8-matrix
)
159 (frob sb8-matrix bit-matrix sb16-matrix
)
160 (frob sb16-matrix bit-matrix sb16-matrix
)
161 (frob sb32-matrix bit-matrix sb32-matrix
)
163 (frob sb32-matrix ub8-matrix sb32-matrix
)
164 (frob sb32-matrix ub16-matrix sb32-matrix
)
166 (frob single-float-matrix double-float-matrix double-float-matrix
)
168 (frob ub8-matrix double-float-matrix double-float-matrix
)
169 (frob ub8-matrix single-float-matrix single-float-matrix
)
171 (frob ub16-matrix double-float-matrix double-float-matrix
)
172 (frob ub16-matrix single-float-matrix single-float-matrix
)
174 (frob ub32-matrix double-float-matrix double-float-matrix
)
175 (frob ub32-matrix single-float-matrix single-float-matrix
)
177 (frob sb8-matrix double-float-matrix double-float-matrix
)
178 (frob sb8-matrix single-float-matrix single-float-matrix
)
180 (frob sb16-matrix double-float-matrix double-float-matrix
)
181 (frob sb16-matrix single-float-matrix single-float-matrix
)
183 (frob sb32-matrix double-float-matrix double-float-matrix
)
184 (frob sb32-matrix single-float-matrix single-float-matrix
)
185 (frob bit-matrix double-float-matrix double-float-matrix
)
186 (frob bit-matrix single-float-matrix single-float-matrix
)
187 (frob bit-matrix bit-matrix bit-matrix
))
189 (defgeneric mat-subtr-range
(m n start endr startc endc
&key in-place result-type
))
191 (defmethod mat-subtr-range ((m typed-mixin
) (n typed-mixin
) startr endr startc endc
&key in-place
192 (result-type (%get-subtr-matrix-class m n
)))
193 (destructuring-bind (mr mc
) (dim m
)
195 (mat-subtr-range3 m n m startr endr startc endc
)
196 (let ((p (make-instance result-type
:rows mr
:cols mc
)))
197 (mat-subtr-range3 m n p startr endr startc endc
)))))
199 (defmethod mat-subtr :around
((m matrix
) (n matrix
)
200 &key
(in-place nil in-place-supplied-p
)
201 (result-type (%get-subtr-matrix-class m n
)))
202 (if (compute-applicable-methods #'mat-subtr-range
(list m n
0 0 0 0))
203 (destructuring-bind (mr mc
) (dim m
)
204 (apply #'mat-subtr-range
205 m n
0 (1- mr
) 0 (1- mc
) :result-type result-type
206 (when in-place-supplied-p
`(:in-place
,in-place
))))
