4 (defgeneric mat-scale-fit-range
(m q startr endr startc endc
))
5 (defgeneric mat-scale-fit
(m q
))
6 (defgeneric mat-scale-fit-range
! (m q startr endr startc endc
))
7 (defgeneric mat-scale-fit
! (m q
))
9 (defmacro def-matrix-scale-fit
(type-1 accumulator-type
)
10 (let ((element-type-1 (element-type (find-class `,type-1
))))
12 (defmethod mat-scale-fit-range
13 ((m ,type-1
) q startr endr startc endc
)
14 (let ((qconv (coerce q
',element-type-1
)))
15 (declare (type ,element-type-1 qconv
))
16 (destructuring-bind (mr mc
) (dim m
)
17 (let ((p (make-instance ',accumulator-type
:rows mr
:cols mc
)))
18 (with-matrix-vals (m ,element-type-1 a
)
19 (do ((i startr
(1+ i
)))
21 (declare (dynamic-extent i
) (type fixnum i
))
22 (do ((j startc
(1+ j
)))
24 (declare (dynamic-extent j
) (type fixnum j
))
25 (set-val-fit p i j
(* (aref a i j
) qconv
)))))
28 (defmethod mat-scale-fit
30 (destructuring-bind (mr mc
) (dim m
)
31 (mat-scale-fit-range m q
0 (1- mr
) 0 (1- mc
)))))))
34 (defmacro def-matrix-scale-fit
! (type-1)
35 (let ((element-type-1 (element-type (find-class `,type-1
))))
37 (defmethod mat-scale-fit-range!
38 ((m ,type-1
) q startr endr startc endc
)
39 (if (subtypep (type-of q
) ',element-type-1
)
40 (let ((qconv (coerce q
',element-type-1
)))
41 (declare (type ,element-type-1 qconv
))
42 (with-matrix-vals (m ,element-type-1 a
)
43 (do ((i startr
(1+ i
)))
45 (declare (dynamic-extent i
) (type fixnum i
))
46 (do ((j startc
(1+ j
)))
48 (declare (dynamic-extent j
) (type fixnum j
))
49 (set-val-fit m i j
(* (aref a i j
) qconv
))))))
50 (with-matrix-vals (m ,element-type-1 a
)
51 (do ((i startr
(1+ i
)))
53 (declare (dynamic-extent i
) (type fixnum i
))
54 (do ((j startc
(1+ j
)))
56 (declare (dynamic-extent j
) (type fixnum j
))
57 (set-val-fit m i j
(* (aref a i j
) q
))))))
60 (defmethod mat-scale-fit!
62 (destructuring-bind (mr mc
) (dim m
)
63 (mat-scale-fit-range! m q
0 (1- mr
) 0 (1- mc
)))))))
65 (macrolet ((frob (type-1 type-2
)
67 (def-matrix-scale-fit ,type-1
,type-2
)
68 (def-matrix-scale-fit! ,type-1
))))
69 (frob double-float-matrix double-float-matrix
)
70 (frob single-float-matrix single-float-matrix
)
71 (frob ub8-matrix ub8-matrix
)
72 (frob ub16-matrix ub16-matrix
)
73 (frob ub32-matrix ub32-matrix
)
74 (frob sb8-matrix sb8-matrix
)
75 (frob sb16-matrix sb16-matrix
)
76 (frob sb32-matrix sb32-matrix
)
77 (frob bit-matrix bit-matrix
)
78 (frob fixnum-matrix fixnum-matrix
)
79 (frob real-matrix real-matrix
)
80 (frob integer-matrix integer-matrix
)
81 (frob complex-matrix complex-matrix
)
82 (frob t-matrix t-matrix
))
