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 ((result nil))
  46     (loop for rank in ranks do
  47         (loop for type in types do
  48              (push `(def-fftshift-rank-type ,rank ,type)
  49                    result)))
  50     `(progn ,@result)))
  51
  52 (def-fftshift-functions (1 2 3) (cdf csf))
  53
  54 #+nil
  55 (let* ((ls '(1 2 3 4 5 6 7 8 9))
  56        (a (make-array (length ls)
  57                       :element-type '(complex single-float)
  58                       :initial-contents (mapcar
  59                                          #'(lambda (z) (coerce z
  60                                                          '(complex single-float)))
  61                                          ls))))
  62   (fftshift1-csf a))
  63
  64 #+nil
  65 (time
  66  (let ((a (make-array (list 128 128 128)
  67                       :element-type '(complex single-float))))
  68    (fftshift3-csf a)
  69    nil))