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                         :override-name t)
  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"
  17                              rank type out_type
  18                              short_func)))
  19     (store-new-function name)
  20     `(defun ,name (a)
  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))
  27               (n (length a1)))
  28          (dotimes (i n)
  29            (setf (aref result1 i)
  30                  (funcall ,func (aref a1 i))))
  31          result))))
  32
  33 #+nil
  34 (def-convert-rank-type-out_type-func-short_func
  35     1 sf df #'(lambda (x) (* 1d0 x)) coerce)
  36 #+nil
  37 (def-convert-rank-type-out_type-func-short_func
  38     1 ub8 csf #'(lambda (x) (complex (* 1d0 x))) complex)
  39 #+nil
  40 (convert-1-sf/df-coerce
  41  (make-array 4 :element-type 'single-float))
  42
  43
  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))
  48                `(,in-type
  49                  ,out-type
  50                  #'(lambda (x)
  51                      ,(ecase fun
  52                              (:floor `(floor x))
  53                              (:coerce `(coerce x ',(get-long-type out-type)))
  54                              (t `(* ,(coerce 1 (get-long-type out-type)) x))))
  55                  ,(ecase fun
  56                          (:floor 'floor)
  57                          (:coerce 'coerce)
  58                          (t 'mul))))
  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
  63                   `(,in-type
  64                     ,out-type
  65                     ,(ecase fun
  66                       (:floor `#'(lambda (x) (floor (funcall #',func x))))
  67                       (t `#',func))
  68                     ,func))))
  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
  73     ;; convert function
  74     (let ((specs `(;; upconvert from ub8 into sf and similar
  75                    ,(def 'ub8 'sf)
  76                     ,(def 'ub8 'df)
  77                     ,(def 'ub8 'csf)
  78                     ,(def 'ub8 'cdf)
  79
  80                     ,(def 'fix 'sf)
  81                     ,(def 'fix 'df)
  82                     ,(def 'fix 'csf)
  83                     ,(def 'fix 'cdf)
  84
  85
  86                     ,(def 'sf 'df)
  87                     ,(def 'sf 'csf)
  88                     ,(def 'sf 'cdf)
  89
  90                     ,(def 'df 'cdf)
  91
  92                     ;; upconvert complex to complex
  93                     ,(def 'csf 'cdf)
  94
  95                     ;; downconvert from double into single
  96                     ,(def 'df 'sf :coerce)
  97                     ,(def 'cdf 'csf :coerce)
  98
  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)
 104
 105                     ;; convert from complex into real
 106                     ,@(def-comps 'csf 'sf '(realpart imagpart abs phase))
 107                     ,@(def-comps 'cdf 'df '(realpart imagpart abs phase))
 108
 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)
 112                     ))
 113           (result nil))
 114       (loop for rank in '(1 2 3) do
 115            (loop for spec in specs do
 116                 (destructuring-bind (in out fun name)
 117                     spec
 118                  (push `(def-convert-rank-type-out_type-func-short_func
 119                             ,rank ,in ,out ,fun ,name)
 120                        result))))
 121       `(progn ,@result))))
 122
 123 (def-convert-functions)
 124
 125 #+nil
 126 (convert-3-cdf/ub8-realpart
 127  (make-array (list 3 3 3) :element-type '(complex double-float)))
 128
 129 #+nil
 130 (convert-3-csf/cdf-mul
 131  (make-array (list 3 3 3) :element-type '(complex single-float)))
 132
 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
 136 ;; default
 137
 138 (defun convert (a out-type &optional (func 'mul func-p))
 139   (let* ((in-type (get-short-type (second (type-of a))))
 140          (func (if func-p
 141                    func
 142                    (cond
 143                      ;; extract realpart of complex input by default
 144                      ((and
 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"
 153                               (array-rank a)
 154                               in-type
 155                               out-type
 156                               func)))
 157     (if (eq in-type out-type)
 158         a
 159         (funcall name a))))
 160
 161
 162
 163 #+nil
 164 (convert (v 231d0) 'sf)
 165 #+nil
 166 (convert (v 231d0) 'df)
 167 #+nil
 168 (convert (v 231d0) 'ub8)
 169
 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)
 177                                   :override-name t)
 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
 183                          (cdf 'double-float)
 184                          (csf 'single-float))))
 185     (store-new-function name)
 186     `(defun ,name (a)
 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))
 193               (n (length a1))
 194               (intermediate1
 195                (make-array n :element-type ',intermed-type)))
 196          (dotimes (i n)
 197            (setf (aref intermediate1 i) (funcall ,func (aref a1 i))))
 198          (let* ((ma (reduce #'max intermediate1))
 199                 (mi (reduce #'min intermediate1))
 200                 (s (if (= ma mi)
 201                        (coerce 0 ',intermed-type)
 202                        (/ (- ma mi)))))
 203            (dotimes (i n)
 204              (let ((v (* s (- (aref intermediate1 i) mi))))
 205               (setf (aref result1 i) ,(if (eq 'ub8 out_type)
 206                                           `(floor (* 255 v))
 207                                           `(* (coerce 1 ',long-out-type) v)))))
 208          result)))))
 209
 210 #+nil
 211 (def-normalize-complex-rank-type-out_type-func-short_func
 212     1 csf ub8 #'realpart realpart)
 213
 214 (defmacro def-normalize-complex-functions (ranks out-types funcs)
 215   (let ((result nil))
 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)
 221                               result)))))
 222     `(progn ,@result)))
 223
 224 (def-normalize-complex-functions
 225     (1 2 3) (ub8 sf df) (realpart imagpart phase abs))
 226
 227 #+nil
 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))))
 231
 232 #+nil
 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))))
 236
 237 ;; normalize real arrays, name like: normalize-2-sf/ub8
 238 (def-generator (normalize (rank type out_type)
 239                           :override-name t)
 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)
 245     `(defun ,name (a)
 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))
 252               (n (length a1))
 253               (ma (reduce #'max a1))
 254               (mi (reduce #'min a1))
 255               (s (if (= ma mi)
 256                      (coerce 0 ',(get-long-type type))
 257                      (/ (- ma mi)))))
 258          (dotimes (i n)
 259            (let ((v (* s (- (aref a1 i) mi))))
 260              (setf (aref result1 i) ,(if (eq 'ub8 out_type)
 261                                          `(floor (* 255 v))
 262                                          `(* (coerce 1 ',long-out-type) v)))))
 263          result))))
 264 #+nil
 265 (def-normalize-rank-type-out_type 1 df ub8)
 266 #+nil
 267 (normalize-1-df/ub8 (make-array 3 :element-type 'double-float
 268                                 :initial-contents '(1d0 2d0 3d0)))
 269
 270 (defmacro def-normalize-functions (ranks in-types out-types)
 271   (let ((result nil))
 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)
 276                          result))))
 277     `(progn ,@result)))
 278
 279 (def-normalize-functions (1 2 3) (ub8 sf df) (ub8 sf df))
 280
 281 #+nil
 282 (normalize-1-sf/sf (make-array 3 :element-type 'single-float
 283                                 :initial-contents '(1s0 2s0 3s0)))
 284 #+nil
 285 (normalize-1-sf/ub8 (make-array 3 :element-type 'single-float
 286                                 :initial-contents '(1s0 2s0 3s0)))
 287 #+nil
 288 (normalize-1-ub8/sf (make-array 3 :element-type '(unsigned-byte 8)
 289                                 :initial-contents '(1 2 3)))
 290 #+nil
 291 (normalize-1-ub8/ub8 (make-array 3 :element-type '(unsigned-byte 8)
 292                                 :initial-contents '(1 2 3)))
 293
 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
 297 (let ((res ()))
 298   (with-package-iterator (next-symbol *package* :internal)
 299     (loop (multiple-value-bind (more? symbol)
 300               (next-symbol)
 301             (if more?
 302                 (push symbol res)
 303                 (return)))))
 304   (loop for s in (delete-if-not #'(lambda (x)
 305                                     (let* ((pat "CONVERT"
 306                                               #+nil "NORMALI"
 307                                              )
 308                                            (lpat (length pat)))
 309                                       (when (< lpat (length x))
 310                                         (string= pat x
 311                                                  :end1 lpat
 312                                                  :end2 lpat))))
 313                                 (mapcar #'(lambda (x)
 314                                             (format nil "~a" x)) res))
 315      do (format t "#:~a~%" (string-downcase s))))