vol-convert.lisp

   1 ;; define a bunch of functions to convert an {1,2,3}-dimensional array
   2 ;; from one type into another type.
   3 (in-package :vol)
   4
   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.
  11
  12 (def-generator (convert (rank type out_type func short_func))
  13   (let ((long-out-type (get-long-type out_type))
  14         ;; override the name that is constructed by def-generator
  15         (name (format-symbol "convert-~a-~a/~a-~a"
  16                              rank type out_type
  17                              short_func)))
  18     (store-new-function name)
  19     `(defun ,name (a)
  20        (declare ((simple-array ,long-type ,rank) a)
  21                 (values (simple-array ,long-out-type ,rank) &optional))
  22        (let* ((result (make-array (array-dimensions a)
  23                                   :element-type (quote ,long-out-type)))
  24               (result1 (sb-ext:array-storage-vector result))
  25               (a1 (sb-ext:array-storage-vector a))
  26               (n (length a1)))
  27          (dotimes (i n)
  28            (setf (aref result1 i)
  29                  (funcall ,func (aref a1 i))))
  30          result))))
  31
  32 #+nil
  33 (def-convert-rank-type-out_type-func-short_func
  34     1 sf df #'(lambda (x) (* 1d0 x)) coerce)
  35 #+nil
  36 (def-convert-rank-type-out_type-func-short_func
  37     1 ub8 csf #'(lambda (x) (complex (* 1d0 x))) complex)
  38 #+nil
  39 (convert-1-sf/df-coerce
  40  (make-array 4 :element-type 'single-float))
  41
  42
  43 (defmacro def-convert-functions ()
  44   (labels ( ;; create a spec like this: ub8 sf (* 1s0 x) mul
  45            ;; down can be used to convert double into float
  46            (def (in-type out-type &optional (fun t))
  47                `(,in-type
  48                  ,out-type
  49                  #'(lambda (x)
  50                      ,(ecase fun
  51                              (:floor `(floor x))
  52                              (:coerce `(coerce x ',(get-long-type out-type)))
  53                              (t `(* ,(coerce 1 (get-long-type out-type)) x))))
  54                  ,(ecase fun
  55                          (:floor 'floor)
  56                          (:coerce 'coerce)
  57                          (t 'mul))))
  58            ;; create downconversions from complex types like
  59            ;; cdf df #'realpart realpart
  60            (def-comps (in-type out-type functions &optional (fun t))
  61              (loop for func in functions collect
  62                   `(,in-type
  63                     ,out-type
  64                     ,(ecase fun
  65                       (:floor `#'(lambda (x) (floor (funcall #',func x))))
  66                       (t `#',func))
  67                     ,func))))
  68     ;; an element of spec looks like this: (ub8 sf #'(lambda(x) (* 1s0 x))
  69     ;; mul) the first two cols define input and output types, then
  70     ;; comes a function that does this conversion followed by a short
  71     ;; name describing the function. this name is attached to the
  72     ;; convert function
  73     (let ((specs `(;; upconvert from ub8 into sf and similar
  74                    ,(def 'ub8 'sf)
  75                     ,(def 'ub8 'df)
  76                     ,(def 'ub8 'csf)
  77                     ,(def 'ub8 'cdf)
  78
  79                     ,(def 'sf 'df)
  80                     ,(def 'sf 'csf)
  81                     ,(def 'sf 'cdf)
  82
  83                     ,(def 'df 'cdf)
  84
  85                     ;; upconvert complex to complex
  86                     ,(def 'csf 'cdf)
  87
  88                     ;; downconvert from double into single
  89                     ,(def 'df 'sf :coerce)
  90                     ,(def 'cdf 'csf :coerce)
  91
  92                     ;; downconvert from float into bytes
  93                     ,(def 'sf 'ub8 :floor)
  94                     ,(def 'df 'ub8 :floor)
  95
  96                     ;; convert from complex into real
  97                     ,@(def-comps 'csf 'sf '(realpart imagpart abs phase))
  98                     ,@(def-comps 'cdf 'df '(realpart imagpart abs phase))
  99
 100                     ;; complex into real and conversion into fixed
 101                     ,@(def-comps 'csf 'ub8 '(realpart imagpart abs phase) :floor)
 102                     ,@(def-comps 'cdf 'ub8 '(realpart imagpart abs phase) :floor)
 103                     ))
 104           (result nil))
 105       (loop for rank in '(1 2 3) do
 106            (loop for spec in specs do
 107                 (destructuring-bind (in out fun name)
 108                     spec
 109                  (push `(def-convert-rank-type-out_type-func-short_func
 110                             ,rank ,in ,out ,fun ,name)
 111                        result))))
 112       `(progn ,@result))))
 113
 114 (def-convert-functions)
 115
 116 #+nil
 117 (convert-3-cdf/ub8-realpart
 118  (make-array (list 3 3 3) :element-type '(complex double-float)))
 119
 120 #+nil
 121 (convert-3-csf/cdf-mul
 122  (make-array (list 3 3 3) :element-type '(complex single-float)))
 123
 124
 125 ;; converting complex into real with some function and converting into
 126 ;; out_type, the name of the functions will be like:
 127 ;; normalize-3-cdf/ub8-realpart. the function is evaluated into an
 128 ;; intermediate real array (either double or float depending on the
 129 ;; input type) and then normalized into the result. float results are
 130 ;; in 0..1 and ub8 results in 0..255.
 131 (def-generator (normalize-complex (rank type out_type func short_func))
 132   (let ((long-out-type (get-long-type out_type))
 133         ;; override the name that is constructed by def-generator
 134         (name (format-symbol "normalize-~a-~a/~a-~a"
 135                              rank type out_type short_func))
 136         (intermed-type (ecase type
 137                          (cdf 'double-float)
 138                          (csf 'single-float))))
 139     (store-new-function name)
 140     `(defun ,name (a)
 141        (declare ((simple-array ,long-type ,rank) a)
 142                 (values (simple-array ,long-out-type ,rank) &optional))
 143        (let* ((result (make-array (array-dimensions a)
 144                                   :element-type ',long-out-type))
 145               (result1 (sb-ext:array-storage-vector result))
 146               (a1 (sb-ext:array-storage-vector a))
 147               (n (length a1))
 148               (intermediate1
 149                (make-array n :element-type ',intermed-type)))
 150          (dotimes (i n)
 151            (setf (aref intermediate1 i) (funcall ,func (aref a1 i))))
 152          (let* ((ma (reduce #'max intermediate1))
 153                 (mi (reduce #'min intermediate1))
 154                 (s (if (= ma mi)
 155                        (coerce 0 ',intermed-type)
 156                        (/ (- ma mi)))))
 157            (dotimes (i n)
 158              (let ((v (* s (- (aref intermediate1 i) mi))))
 159               (setf (aref result1 i) ,(if (eq 'ub8 out_type)
 160                                           `(floor (* 255 v))
 161                                           `(* (coerce 1 ',long-out-type) v)))))
 162          result)))))
 163
 164 #+nil
 165 (def-normalize-complex-rank-type-out_type-func-short_func
 166     1 csf ub8 #'realpart realpart)
 167
 168 (defmacro def-normalize-complex-functions (ranks out-types funcs)
 169   (let ((result nil))
 170     (loop for rank in ranks do
 171          (loop for type in '(csf cdf) do
 172               (loop for otype in out-types do
 173                    (loop for func in funcs do
 174                         (push `(def-normalize-complex-rank-type-out_type-func-short_func ,rank ,type ,otype #',func ,func)
 175                               result)))))
 176     `(progn ,@result)))
 177
 178 (def-normalize-complex-functions
 179     (1 2 3) (ub8 sf df) (realpart imagpart phase abs))
 180
 181 #+nil
 182 (normalize-1-csf/ub8-realpart
 183  (make-array 3 :element-type '(complex single-float)
 184              :initial-contents '(#C(1s0 0s0) #C(2s0 0s0) #C(3s0 0s0))))
 185
 186 #+nil
 187 (normalize-1-csf/df-phase
 188  (make-array 3 :element-type '(complex single-float)
 189              :initial-contents '(#C(1s0 .2s0) #C(2s0 1s0) #C(3s0 0s0))))
 190
 191 ;; normalize real arrays, name like: normalize-2-sf/ub8
 192 (def-generator (normalize (rank type out_type))
 193   (let ((long-out-type (get-long-type out_type))
 194         ;; override the name that is constructed by def-generator
 195         (name (format-symbol "normalize-~a-~a/~a"
 196                              rank type out_type)))
 197     (store-new-function name)
 198     `(defun ,name (a)
 199        (declare ((simple-array ,long-type ,rank) a)
 200                 (values (simple-array ,long-out-type ,rank) &optional))
 201        (let* ((result (make-array (array-dimensions a)
 202                                   :element-type ',long-out-type))
 203               (result1 (sb-ext:array-storage-vector result))
 204               (a1 (sb-ext:array-storage-vector a))
 205               (n (length a1))
 206               (ma (reduce #'max a1))
 207               (mi (reduce #'min a1))
 208               (s (if (= ma mi)
 209                      (coerce 0 ',(get-long-type type))
 210                      (/ (- ma mi)))))
 211          (dotimes (i n)
 212            (let ((v (* s (- (aref a1 i) mi))))
 213              (setf (aref result1 i) ,(if (eq 'ub8 out_type)
 214                                          `(floor (* 255 v))
 215                                          `(* (coerce 1 ',long-out-type) v)))))
 216          result))))
 217 #+nil
 218 (def-normalize-rank-type-out_type 1 df ub8)
 219 #+nil
 220 (normalize-1-df/ub8 (make-array 3 :element-type 'double-float
 221                                 :initial-contents '(1d0 2d0 3d0)))
 222
 223 (defmacro def-normalize-functions (ranks in-types out-types)
 224   (let ((result nil))
 225     (loop for rank in ranks do
 226          (loop for type in in-types do
 227               (loop for otype in out-types do
 228                    (push `(def-normalize-rank-type-out_type ,rank ,type ,otype)
 229                          result))))
 230     `(progn ,@result)))
 231
 232 (def-normalize-functions (1 2 3) (ub8 sf df) (ub8 sf df))
 233
 234 #+nil
 235 (normalize-1-sf/sf (make-array 3 :element-type 'single-float
 236                                 :initial-contents '(1s0 2s0 3s0)))
 237 #+nil
 238 (normalize-1-sf/ub8 (make-array 3 :element-type 'single-float
 239                                 :initial-contents '(1s0 2s0 3s0)))
 240 #+nil
 241 (normalize-1-ub8/sf (make-array 3 :element-type '(unsigned-byte 8)
 242                                 :initial-contents '(1 2 3)))
 243 #+nil
 244 (normalize-1-ub8/ub8 (make-array 3 :element-type '(unsigned-byte 8)
 245                                 :initial-contents '(1 2 3)))
 246
 247 #+nil ;; find the names of all the functions that were defined by the
 248       ;; above macros, for exporting
 249 ;; 2010-08-14 I don't think I need this anymore
 250 (let ((res ()))
 251   (with-package-iterator (next-symbol *package* :internal)
 252     (loop (multiple-value-bind (more? symbol)
 253               (next-symbol)
 254             (if more?
 255                 (push symbol res)
 256                 (return)))))
 257   (loop for s in (delete-if-not #'(lambda (x)
 258                                     (let* ((pat "CONVERT"
 259                                               #+nil "NORMALI"
 260                                              )
 261                                            (lpat (length pat)))
 262                                       (when (< lpat (length x))
 263                                         (string= pat x
 264                                                  :end1 lpat
 265                                                  :end2 lpat))))
 266                                 (mapcar #'(lambda (x)
 267                                             (format nil "~a" x)) res))
 268      do (format t "#:~a~%" (string-downcase s))))