2 ;;; macros, functions and methods for moving elements between
5 ;;; Copyright (c) 2004-2006 Cyrus Harmon (ch-lisp@bobobeach.com)
6 ;;; All rights reserved.
8 ;;; Redistribution and use in source and binary forms, with or without
9 ;;; modification, are permitted provided that the following conditions
12 ;;; * Redistributions of source code must retain the above copyright
13 ;;; notice, this list of conditions and the following disclaimer.
15 ;;; * Redistributions in binary form must reproduce the above
16 ;;; copyright notice, this list of conditions and the following
17 ;;; disclaimer in the documentation and/or other materials
18 ;;; provided with the distribution.
20 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
21 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
22 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
23 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
24 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
25 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
26 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
27 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
28 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
29 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
30 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
35 ;;; fallback version for when we don't have type information
37 (defmethod matrix-move ((m matrix
) (n matrix
) &key constrain
)
38 (if (= (matrix-total-size m
)
39 (matrix-total-size n
))
41 (let ((min (minval (class-of n
)))
42 (max (maxval (class-of n
))))
43 (dotimes (i (matrix-total-size m
))
44 (setf (row-major-mref n i
)
45 (constrain min
(row-major-mref m i
) max
))))
46 (dotimes (i (matrix-total-size m
))
47 (setf (row-major-mref n i
)
48 (row-major-mref m i
))))
49 (error 'matrix-argument-error
51 "Incompatible matrix dimensions in matrix-move ~S => ~S."
52 :format-arguments
(list (matrix-dimensions m
)
53 (matrix-dimensions n
)))))
55 (defmethod matrix-move ((m matrix
) (n integer-matrix
) &key constrain
)
56 (if (= (matrix-total-size m
)
57 (matrix-total-size n
))
59 (let ((min (minval (class-of n
)))
60 (max (maxval (class-of n
))))
61 (dotimes (i (matrix-total-size m
))
62 (setf (row-major-mref n i
)
63 (constrain min
(truncate (row-major-mref m i
)) max
))))
64 (dotimes (i (matrix-total-size m
))
65 (setf (row-major-mref n i
)
66 (truncate (row-major-mref m i
)))))
67 (error 'matrix-argument-error
69 "Incompatible matrix dimensions in matrix-move ~S => ~S."
70 :format-arguments
(list (matrix-dimensions m
)
71 (matrix-dimensions n
)))))
73 (defmacro def-matrix-move
(type-1 type-2
)
74 (let ((element-type-1 (element-type (find-class `,type-1
)))
75 (element-type-2 (element-type (find-class `,type-2
)))
76 (min (minval (find-class `,type-2
)))
77 (max (maxval (find-class `,type-2
))))
79 (defmethod matrix-move-range-2d ((m ,type-1
) (n ,type-2
)
80 startr1 endr1 startc1 endc1
81 startr2 endr2 startc2 endc2
)
82 (declare (optimize (speed 3) (safety 0))
83 (type fixnum startr1 endr1 startc1 endc1
84 startr2 endr2 startc2 endc2
))
85 (with-typed-matrix-vals (m ,element-type-1 a
)
86 (with-typed-matrix-vals (n ,element-type-2 b
)
87 (do ((i startr1
(1+ i
))
89 ((or (>= i endr1
) (>= k endr2
)))
90 (declare (dynamic-extent i k
) (type fixnum i k
))
91 (do ((j startc1
(1+ j
))
93 ((or (>= j endc1
) (>= l endc2
)))
94 (declare (dynamic-extent j l
) (type fixnum j l
))
98 ,element-type-1
,element-type-2
))))))
101 (defmethod matrix-move-range-2d-constrain ((m ,type-1
) (n ,type-2
)
102 startr1 endr1 startc1 endc1
103 startr2 endr2 startc2 endc2
)
104 (with-matrix-vals (m ,element-type-1 a
)
105 (with-matrix-vals (n ,element-type-2 b
)
106 (do ((i startr1
(1+ i
))
108 ((or (>= i endr1
) (>= k endr2
)))
109 (declare (dynamic-extent i k
) (type fixnum i k
))
110 (do ((j startc1
(1+ j
))
112 ((or (>= j endc1
) (>= l endc2
)))
113 (declare (dynamic-extent j l
) (type fixnum j l
))
114 (setf (aref b k l
) ,(if (eql element-type-1 element-type-2
)
115 `(constrain ,min
(aref a i j
) ,max
)
116 `(maybe-truncate (constrain ,min
(aref a i j
) ,max
)
117 ,element-type-1
,element-type-2
)))))))
120 (defmethod matrix-move ((m ,type-1
) (n ,type-2
) &key constrain
)
121 (destructuring-bind (mr mc
) (dim m
)
123 (matrix-move-range-2d-constrain m n
127 (matrix-move-range-2d m n
131 (macrolet ((frob (type-1 type-2
)
133 (def-move-element ,type-1
,type-2
)
134 (def-matrix-move ,type-1
,type-2
))))
136 (frob double-float-matrix double-float-matrix
)
137 (frob double-float-matrix single-float-matrix
)
138 (frob double-float-matrix ub8-matrix
)
139 (frob double-float-matrix ub16-matrix
)
140 (frob double-float-matrix ub32-matrix
)
141 (frob double-float-matrix sb8-matrix
)
142 (frob double-float-matrix sb16-matrix
)
143 (frob double-float-matrix sb32-matrix
)
144 (frob double-float-matrix bit-matrix
)
145 (frob double-float-matrix fixnum-matrix
)
146 (frob double-float-matrix real-matrix
)
147 (frob double-float-matrix complex-matrix
)
148 (frob double-float-matrix number-matrix
)
150 (frob single-float-matrix single-float-matrix
)
151 (frob single-float-matrix ub8-matrix
)
152 (frob single-float-matrix ub16-matrix
)
153 (frob single-float-matrix ub32-matrix
)
154 (frob single-float-matrix sb8-matrix
)
155 (frob single-float-matrix sb16-matrix
)
156 (frob single-float-matrix sb32-matrix
)
157 (frob single-float-matrix bit-matrix
)
158 (frob single-float-matrix fixnum-matrix
)
159 (frob single-float-matrix real-matrix
)
160 (frob single-float-matrix complex-matrix
)
161 (frob single-float-matrix number-matrix
)
163 (frob ub8-matrix ub8-matrix
)
164 (frob ub16-matrix ub16-matrix
)
165 (frob ub32-matrix ub32-matrix
)
167 (frob ub8-matrix bit-matrix
)
168 (frob ub16-matrix bit-matrix
)
169 (frob ub32-matrix bit-matrix
)
171 (frob sb8-matrix bit-matrix
)
172 (frob sb16-matrix bit-matrix
)
173 (frob sb32-matrix bit-matrix
)
175 (frob sb32-matrix ub8-matrix
)
176 (frob sb32-matrix ub16-matrix
))
178 (macrolet ((frob (type-1 type-2
)
180 (def-move-element ,type-1
,type-2
)
181 (def-matrix-move ,type-1
,type-2
))))
183 (frob single-float-matrix double-float-matrix
)
185 (frob ub8-matrix double-float-matrix
)
186 (frob ub8-matrix single-float-matrix
)
188 (frob ub16-matrix double-float-matrix
)
189 (frob ub16-matrix single-float-matrix
)
191 (frob ub32-matrix double-float-matrix
)
192 (frob ub32-matrix single-float-matrix
)
194 (frob sb8-matrix double-float-matrix
)
195 (frob sb8-matrix single-float-matrix
)
197 (frob sb16-matrix double-float-matrix
)
198 (frob sb16-matrix single-float-matrix
)
200 (frob sb32-matrix double-float-matrix
)
201 (frob sb32-matrix single-float-matrix
)
203 (frob fixnum-matrix double-float-matrix
)
204 (frob fixnum-matrix single-float-matrix
)
206 (frob bit-matrix double-float-matrix
)
207 (frob bit-matrix single-float-matrix
)
208 (frob bit-matrix ub8-matrix
)
209 (frob bit-matrix ub16-matrix
)
210 (frob bit-matrix ub32-matrix
)
211 (frob bit-matrix sb8-matrix
)
212 (frob bit-matrix sb16-matrix
)
213 (frob bit-matrix sb32-matrix
))
215 (macrolet ((frob (type-1 type-2
)
217 (def-move-element ,type-1
,type-2
)
218 (def-matrix-move ,type-1
,type-2
))))
220 (frob complex-matrix real-matrix
)
221 (frob complex-matrix complex-matrix
)
223 (frob real-matrix ub8-matrix
)
224 (frob real-matrix real-matrix
)
225 (frob real-matrix complex-matrix
)
226 (frob real-matrix double-float-matrix
)
227 (frob real-matrix single-float-matrix
))
