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 'fix 'sf)
  80                     ,(def 'fix 'df)
  81                     ,(def 'fix 'csf)
  82                     ,(def 'fix 'cdf)
  83
  84
  85                     ,(def 'sf 'df)
  86                     ,(def 'sf 'csf)
  87                     ,(def 'sf 'cdf)
  88
  89                     ,(def 'df 'cdf)
  90
  91                     ;; upconvert complex to complex
  92                     ,(def 'csf 'cdf)
  93
  94                     ;; downconvert from double into single
  95                     ,(def 'df 'sf :coerce)
  96                     ,(def 'cdf 'csf :coerce)
  97
  98                     ;; downconvert from float into bytes
  99                     ,(def 'sf 'ub8 :floor)
 100                     ,(def 'df 'ub8 :floor)
 101                     ,(def 'sf 'fix :floor)
 102                     ,(def 'df 'fix :floor)
 103
 104                     ;; convert from complex into real
 105                     ,@(def-comps 'csf 'sf '(realpart imagpart abs phase))
 106                     ,@(def-comps 'cdf 'df '(realpart imagpart abs phase))
 107
 108                     ;; complex into real and conversion into fixed
 109                     ,@(def-comps 'csf 'ub8 '(realpart imagpart abs phase) :floor)
 110                     ,@(def-comps 'cdf 'ub8 '(realpart imagpart abs phase) :floor)
 111                     ))
 112           (result nil))
 113       (loop for rank in '(1 2 3) do
 114            (loop for spec in specs do
 115                 (destructuring-bind (in out fun name)
 116                     spec
 117                  (push `(def-convert-rank-type-out_type-func-short_func
 118                             ,rank ,in ,out ,fun ,name)
 119                        result))))
 120       `(progn ,@result))))
 121
 122 (def-convert-functions)
 123
 124 #+nil
 125 (convert-3-cdf/ub8-realpart
 126  (make-array (list 3 3 3) :element-type '(complex double-float)))
 127
 128 #+nil
 129 (convert-3-csf/cdf-mul
 130  (make-array (list 3 3 3) :element-type '(complex single-float)))
 131
 132
 133 ;; converting complex into real with some function and converting into
 134 ;; out_type, the name of the functions will be like:
 135 ;; normalize-3-cdf/ub8-realpart. the function is evaluated into an
 136 ;; intermediate real array (either double or float depending on the
 137 ;; input type) and then normalized into the result. float results are
 138 ;; in 0..1 and ub8 results in 0..255.
 139 (def-generator (normalize-complex (rank type out_type func short_func))
 140   (let ((long-out-type (get-long-type out_type))
 141         ;; override the name that is constructed by def-generator
 142         (name (format-symbol "normalize-~a-~a/~a-~a"
 143                              rank type out_type short_func))
 144         (intermed-type (ecase type
 145                          (cdf 'double-float)
 146                          (csf 'single-float))))
 147     (store-new-function name)
 148     `(defun ,name (a)
 149        (declare ((simple-array ,long-type ,rank) a)
 150                 (values (simple-array ,long-out-type ,rank) &optional))
 151        (let* ((result (make-array (array-dimensions a)
 152                                   :element-type ',long-out-type))
 153               (result1 (sb-ext:array-storage-vector result))
 154               (a1 (sb-ext:array-storage-vector a))
 155               (n (length a1))
 156               (intermediate1
 157                (make-array n :element-type ',intermed-type)))
 158          (dotimes (i n)
 159            (setf (aref intermediate1 i) (funcall ,func (aref a1 i))))
 160          (let* ((ma (reduce #'max intermediate1))
 161                 (mi (reduce #'min intermediate1))
 162                 (s (if (= ma mi)
 163                        (coerce 0 ',intermed-type)
 164                        (/ (- ma mi)))))
 165            (dotimes (i n)
 166              (let ((v (* s (- (aref intermediate1 i) mi))))
 167               (setf (aref result1 i) ,(if (eq 'ub8 out_type)
 168                                           `(floor (* 255 v))
 169                                           `(* (coerce 1 ',long-out-type) v)))))
 170          result)))))
 171
 172 #+nil
 173 (def-normalize-complex-rank-type-out_type-func-short_func
 174     1 csf ub8 #'realpart realpart)
 175
 176 (defmacro def-normalize-complex-functions (ranks out-types funcs)
 177   (let ((result nil))
 178     (loop for rank in ranks do
 179          (loop for type in '(csf cdf) do
 180               (loop for otype in out-types do
 181                    (loop for func in funcs do
 182                         (push `(def-normalize-complex-rank-type-out_type-func-short_func ,rank ,type ,otype #',func ,func)
 183                               result)))))
 184     `(progn ,@result)))
 185
 186 (def-normalize-complex-functions
 187     (1 2 3) (ub8 sf df) (realpart imagpart phase abs))
 188
 189 #+nil
 190 (normalize-1-csf/ub8-realpart
 191  (make-array 3 :element-type '(complex single-float)
 192              :initial-contents '(#C(1s0 0s0) #C(2s0 0s0) #C(3s0 0s0))))
 193
 194 #+nil
 195 (normalize-1-csf/df-phase
 196  (make-array 3 :element-type '(complex single-float)
 197              :initial-contents '(#C(1s0 .2s0) #C(2s0 1s0) #C(3s0 0s0))))
 198
 199 ;; normalize real arrays, name like: normalize-2-sf/ub8
 200 (def-generator (normalize (rank type out_type))
 201   (let ((long-out-type (get-long-type out_type))
 202         ;; override the name that is constructed by def-generator
 203         (name (format-symbol "normalize-~a-~a/~a"
 204                              rank type out_type)))
 205     (store-new-function name)
 206     `(defun ,name (a)
 207        (declare ((simple-array ,long-type ,rank) a)
 208                 (values (simple-array ,long-out-type ,rank) &optional))
 209        (let* ((result (make-array (array-dimensions a)
 210                                   :element-type ',long-out-type))
 211               (result1 (sb-ext:array-storage-vector result))
 212               (a1 (sb-ext:array-storage-vector a))
 213               (n (length a1))
 214               (ma (reduce #'max a1))
 215               (mi (reduce #'min a1))
 216               (s (if (= ma mi)
 217                      (coerce 0 ',(get-long-type type))
 218                      (/ (- ma mi)))))
 219          (dotimes (i n)
 220            (let ((v (* s (- (aref a1 i) mi))))
 221              (setf (aref result1 i) ,(if (eq 'ub8 out_type)
 222                                          `(floor (* 255 v))
 223                                          `(* (coerce 1 ',long-out-type) v)))))
 224          result))))
 225 #+nil
 226 (def-normalize-rank-type-out_type 1 df ub8)
 227 #+nil
 228 (normalize-1-df/ub8 (make-array 3 :element-type 'double-float
 229                                 :initial-contents '(1d0 2d0 3d0)))
 230
 231 (defmacro def-normalize-functions (ranks in-types out-types)
 232   (let ((result nil))
 233     (loop for rank in ranks do
 234          (loop for type in in-types do
 235               (loop for otype in out-types do
 236                    (push `(def-normalize-rank-type-out_type ,rank ,type ,otype)
 237                          result))))
 238     `(progn ,@result)))
 239
 240 (def-normalize-functions (1 2 3) (ub8 sf df) (ub8 sf df))
 241
 242 #+nil
 243 (normalize-1-sf/sf (make-array 3 :element-type 'single-float
 244                                 :initial-contents '(1s0 2s0 3s0)))
 245 #+nil
 246 (normalize-1-sf/ub8 (make-array 3 :element-type 'single-float
 247                                 :initial-contents '(1s0 2s0 3s0)))
 248 #+nil
 249 (normalize-1-ub8/sf (make-array 3 :element-type '(unsigned-byte 8)
 250                                 :initial-contents '(1 2 3)))
 251 #+nil
 252 (normalize-1-ub8/ub8 (make-array 3 :element-type '(unsigned-byte 8)
 253                                 :initial-contents '(1 2 3)))
 254
 255 #+nil ;; find the names of all the functions that were defined by the
 256       ;; above macros, for exporting
 257 ;; 2010-08-14 I don't think I need this anymore
 258 (let ((res ()))
 259   (with-package-iterator (next-symbol *package* :internal)
 260     (loop (multiple-value-bind (more? symbol)
 261               (next-symbol)
 262             (if more?
 263                 (push symbol res)
 264                 (return)))))
 265   (loop for s in (delete-if-not #'(lambda (x)
 266                                     (let* ((pat "CONVERT"
 267                                               #+nil "NORMALI"
 268                                              )
 269                                            (lpat (length pat)))
 270                                       (when (< lpat (length x))
 271                                         (string= pat x
 272                                                  :end1 lpat
 273                                                  :end2 lpat))))
 274                                 (mapcar #'(lambda (x)
 275                                             (format nil "~a" x)) res))
 276      do (format t "#:~a~%" (string-downcase s))))