1 ;; define a bunch of functions to convert an {1,2,3}-dimensional array
2 ;; from one type into another type.
5 ;; for writing several type conversion functions will have a name like
6 ;; convert-3-ub8/cdf-mul the rank is looped over 1, 2 and 3. here the
7 ;; suffix mul indicates that type (up-)conversion is forced by a
8 ;; multiplication. other suffixes are floor for conversion into fixed
9 ;; type and coerce. coerce seemed to be quite slow last time i
10 ;; tried. thats why i prefer the multiplication for most conversions.
12 (def-generator (convert (rank type out_type func short_func
)
14 (let ((long-out-type (get-long-type out_type
))
15 ;; override the name that is constructed by def-generator
16 (name (format-symbol "convert-~a-~a/~a-~a"
19 (store-new-function name
)
21 (declare ((simple-array ,long-type
,rank
) a
)
22 (values (simple-array ,long-out-type
,rank
) &optional
))
23 (let* ((result (make-array (array-dimensions a
)
24 :element-type
(quote ,long-out-type
)))
25 (result1 (sb-ext:array-storage-vector result
))
26 (a1 (sb-ext:array-storage-vector a
))
29 (setf (aref result1 i
)
30 (funcall ,func
(aref a1 i
))))
34 (def-convert-rank-type-out_type-func-short_func
35 1 sf df
#'(lambda (x) (* 1d0 x
)) coerce
)
37 (def-convert-rank-type-out_type-func-short_func
38 1 ub8 csf
#'(lambda (x) (complex (* 1d0 x
))) complex
)
40 (convert-1-sf/df-coerce
41 (make-array 4 :element-type
'single-float
))
44 (defmacro def-convert-functions
()
45 (labels ( ;; create a spec like this: ub8 sf (* 1s0 x) mul
46 ;; down can be used to convert double into float
47 (def (in-type out-type
&optional
(fun t
))
53 (:coerce
`(coerce x
',(get-long-type out-type
)))
54 (t `(* ,(coerce 1 (get-long-type out-type
)) x
))))
59 ;; create downconversions from complex types like
60 ;; cdf df #'realpart realpart
61 (def-comps (in-type out-type functions
&optional
(fun t
))
62 (loop for func in functions collect
66 (:floor
`#'(lambda (x) (floor (funcall #',func x
))))
69 ;; an element of spec looks like this: (ub8 sf #'(lambda(x) (* 1s0 x))
70 ;; mul) the first two cols define input and output types, then
71 ;; comes a function that does this conversion followed by a short
72 ;; name describing the function. this name is attached to the
74 (let ((specs `(;; upconvert from ub8 into sf and similar
92 ;; upconvert complex to complex
95 ;; downconvert from double into single
96 ,(def 'df
'sf
:coerce
)
97 ,(def 'cdf
'csf
:coerce
)
99 ;; downconvert from float into bytes
100 ,(def 'sf
'ub8
:floor
)
101 ,(def 'df
'ub8
:floor
)
102 ,(def 'sf
'fix
:floor
)
103 ,(def 'df
'fix
:floor
)
105 ;; convert from complex into real
106 ,@(def-comps 'csf
'sf
'(realpart imagpart abs phase
))
107 ,@(def-comps 'cdf
'df
'(realpart imagpart abs phase
))
109 ;; complex into real and conversion into fixed
110 ,@(def-comps 'csf
'ub8
'(realpart imagpart abs phase
) :floor
)
111 ,@(def-comps 'cdf
'ub8
'(realpart imagpart abs phase
) :floor
)
114 (loop for rank in
'(1 2 3) do
115 (loop for spec in specs do
116 (destructuring-bind (in out fun name
)
118 (push `(def-convert-rank-type-out_type-func-short_func
119 ,rank
,in
,out
,fun
,name
)
123 (def-convert-functions)
126 (convert-3-cdf/ub8-realpart
127 (make-array (list 3 3 3) :element-type
'(complex double-float
)))
130 (convert-3-csf/cdf-mul
131 (make-array (list 3 3 3) :element-type
'(complex single-float
)))
133 ;; now I need a generic function that converts into the requested type
134 ;; without me having to think about the input type. if the input is
135 ;; complex than the generic converter should take the realpart as
138 (defun convert (a out-type
&optional
(func 'mul func-p
))
139 (let* ((in-type (get-short-type (second (type-of a
))))
143 ;; extract realpart of complex input by default
145 (member in-type
'(csf cdf
))
146 (member out-type
'(ub8 fix sf df
))) 'realpart
)
147 ((member out-type
'(ub8 fix
)) 'floor
)
148 ((and (eq in-type
'df
)
149 (eq out-type
'sf
)) 'coerce
)
150 ((and (eq in-type
'cdf
)
151 (eq out-type
'csf
)) 'coerce
))))
152 (name (format-symbol "convert-~a-~a/~a-~a"
157 (if (eq in-type out-type
)
164 (convert (v 231d0
) 'sf
)
166 (convert (v 231d0
) 'df
)
168 (convert (v 231d0
) 'ub8
)
170 ;; converting complex into real with some function and converting into
171 ;; out_type, the name of the functions will be like:
172 ;; normalize-3-cdf/ub8-realpart. the function is evaluated into an
173 ;; intermediate real array (either double or float depending on the
174 ;; input type) and then normalized into the result. float results are
175 ;; in 0..1 and ub8 results in 0..255.
176 (def-generator (normalize-complex (rank type out_type func short_func
)
178 (let ((long-out-type (get-long-type out_type
))
179 ;; override the name that is constructed by def-generator
180 (name (format-symbol "normalize-~a-~a/~a-~a"
181 rank type out_type short_func
))
182 (intermed-type (ecase type
184 (csf 'single-float
))))
185 (store-new-function name
)
187 (declare ((simple-array ,long-type
,rank
) a
)
188 (values (simple-array ,long-out-type
,rank
) &optional
))
189 (let* ((result (make-array (array-dimensions a
)
190 :element-type
',long-out-type
))
191 (result1 (sb-ext:array-storage-vector result
))
192 (a1 (sb-ext:array-storage-vector a
))
195 (make-array n
:element-type
',intermed-type
)))
197 (setf (aref intermediate1 i
) (funcall ,func
(aref a1 i
))))
198 (let* ((ma (reduce #'max intermediate1
))
199 (mi (reduce #'min intermediate1
))
201 (coerce 0 ',intermed-type
)
204 (let ((v (* s
(- (aref intermediate1 i
) mi
))))
205 (setf (aref result1 i
) ,(if (eq 'ub8 out_type
)
207 `(* (coerce 1 ',long-out-type
) v
)))))
211 (def-normalize-complex-rank-type-out_type-func-short_func
212 1 csf ub8
#'realpart realpart
)
214 (defmacro def-normalize-complex-functions
(ranks out-types funcs
)
216 (loop for rank in ranks do
217 (loop for type in
'(csf cdf
) do
218 (loop for otype in out-types do
219 (loop for func in funcs do
220 (push `(def-normalize-complex-rank-type-out_type-func-short_func ,rank
,type
,otype
#',func
,func
)
224 (def-normalize-complex-functions
225 (1 2 3) (ub8 sf df
) (realpart imagpart phase abs
))
228 (normalize-1-csf/ub8-realpart
229 (make-array 3 :element-type
'(complex single-float
)
230 :initial-contents
'(#C
(1s0 0s0
) #C
(2s0 0s0
) #C
(3s0 0s0
))))
233 (normalize-1-csf/df-phase
234 (make-array 3 :element-type
'(complex single-float
)
235 :initial-contents
'(#C
(1s0 .2s0
) #C
(2s0 1s0
) #C
(3s0 0s0
))))
237 ;; normalize real arrays, name like: normalize-2-sf/ub8
238 (def-generator (normalize (rank type out_type
)
240 (let ((long-out-type (get-long-type out_type
))
241 ;; override the name that is constructed by def-generator
242 (name (format-symbol "normalize-~a-~a/~a"
243 rank type out_type
)))
244 (store-new-function name
)
246 (declare ((simple-array ,long-type
,rank
) a
)
247 (values (simple-array ,long-out-type
,rank
) &optional
))
248 (let* ((result (make-array (array-dimensions a
)
249 :element-type
',long-out-type
))
250 (result1 (sb-ext:array-storage-vector result
))
251 (a1 (sb-ext:array-storage-vector a
))
253 (ma (reduce #'max a1
))
254 (mi (reduce #'min a1
))
256 (coerce 0 ',(get-long-type type
))
259 (let ((v (* s
(- (aref a1 i
) mi
))))
260 (setf (aref result1 i
) ,(if (eq 'ub8 out_type
)
262 `(* (coerce 1 ',long-out-type
) v
)))))
265 (def-normalize-rank-type-out_type 1 df ub8
)
267 (normalize-1-df/ub8
(make-array 3 :element-type
'double-float
268 :initial-contents
'(1d0 2d0
3d0
)))
270 (defmacro def-normalize-functions
(ranks in-types out-types
)
272 (loop for rank in ranks do
273 (loop for type in in-types do
274 (loop for otype in out-types do
275 (push `(def-normalize-rank-type-out_type ,rank
,type
,otype
)
279 (def-normalize-functions (1 2 3) (ub8 sf df
) (ub8 sf df
))
282 (normalize-1-sf/sf
(make-array 3 :element-type
'single-float
283 :initial-contents
'(1s0 2s0
3s0
)))
285 (normalize-1-sf/ub8
(make-array 3 :element-type
'single-float
286 :initial-contents
'(1s0 2s0
3s0
)))
288 (normalize-1-ub8/sf
(make-array 3 :element-type
'(unsigned-byte 8)
289 :initial-contents
'(1 2 3)))
291 (normalize-1-ub8/ub8
(make-array 3 :element-type
'(unsigned-byte 8)
292 :initial-contents
'(1 2 3)))
294 #+nil
;; find the names of all the functions that were defined by the
295 ;; above macros, for exporting
296 ;; 2010-08-14 I don't think I need this anymore
298 (with-package-iterator (next-symbol *package
* :internal
)
299 (loop (multiple-value-bind (more? symbol
)
304 (loop for s in
(delete-if-not #'(lambda (x)
305 (let* ((pat "CONVERT"
309 (when (< lpat
(length x
))
313 (mapcar #'(lambda (x)
314 (format nil
"~a" x
)) res
))
315 do
(format t
"#:~a~%" (string-downcase s
))))