vol/fft-helper.lisp

   1 ;; functions that are somehow related to the fouriertransform
   2
   3 (in-package :vol)
   4
   5 (def-generator (fftshift (rank type))
   6   `(defun ,name (in)
   7      (declare ((simple-array ,long-type ,rank) in)
   8               (values (simple-array ,long-type ,rank) &optional))
   9      (let ((out (make-array (array-dimensions in)
  10                             :element-type ',long-type)))
  11        ,(ecase rank
  12                (1 `(destructuring-bind (x)
  13                        (array-dimensions in)
  14                      (let ((xx (floor x 2)))
  15                        (do-region ((i) (x))
  16                          (let ((ii (mod (+ i xx) x)))
  17                            (setf (aref out i)
  18                                  (aref in ii)))))))
  19                (2 `(destructuring-bind (y x)
  20                        (array-dimensions in)
  21                      (let ((xx (floor x 2))
  22                            (yy (floor y 2)))
  23                        (do-region ((j i) (y x))
  24                          (let ((ii (mod (+ i xx) x))
  25                                (jj (mod (+ j yy) y)))
  26                            (setf (aref out j i)
  27                                  (aref in jj ii)))))))
  28                (3 `(destructuring-bind (z y x)
  29                        (array-dimensions in)
  30                      (let ((xx (floor x 2))
  31                            (yy (floor y 2))
  32                            (zz (floor z 2)))
  33                        (do-region ((k j i) (z y x))
  34                          (let ((ii (mod (+ i xx) x))
  35                                (jj (mod (+ j yy) y))
  36                                (kk (mod (+ k zz) z)))
  37                            (setf (aref out k j i)
  38                                  (aref in kk jj ii))))))))
  39        out)))
  40
  41 #+nil
  42 (def-fftshift-rk-type 3 sf)
  43
  44 (defmacro def-fftshift-functions (ranks types)
  45   (let* ((specifics nil)
  46          (cases nil)
  47          (name (format-symbol "fftshift")))
  48     (loop for rank in ranks do
  49          (loop for type in types do
  50               (let ((def-name (format-symbol "def-~a-rank-type" name))
  51                     (specific-name (format-symbol "~a-~a-~a" name rank type)))
  52                 (push `(,def-name ,rank ,type) specifics)
  53                 (push `((simple-array ,(get-long-type type) ,rank)
  54                         (,specific-name a))
  55                       cases))))
  56     (store-new-function name)
  57     `(progn ,@specifics
  58             (defun ,name (a)
  59                (etypecase a
  60                  ,@cases
  61                  (t (error "The given type can't be handled with a generic ~a function." ',name)))))))
  62
  63 (def-fftshift-functions (1 2 3) (cdf csf))
  64
  65 #+nil
  66 (let* ((ls '(1 2 3 4 5 6 7 8 9))
  67        (a (make-array (length ls)
  68                       :element-type '(complex single-float)
  69                       :initial-contents (mapcar
  70                                          #'(lambda (z) (coerce z
  71                                                          '(complex single-float)))
  72                                          ls))))
  73   (fftshift1-csf a))
  74
  75 #+nil
  76 (time
  77  (let ((a (make-array (list 128 128 128)
  78                       :element-type '(complex single-float))))
  79    (fftshift3-csf a)
  80    nil))