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