(in-package "USER")
(proclaim '(optimize (safety 0) (speed 3) (space 0)))

;;; FFT -- This is an FFT benchmark written by Harry Barrow.  It tests a
;;; variety of floating point operations, including array references.

(defvar re (make-array 1025. :element-type 'single-float :initial-element 0.0))	
(defvar im (make-array 1025. :element-type 'single-float :initial-element 0.0))


;areal = real part 
;aimag = imaginary part
(defun fft (areal aimag)
  (declare (type (simple-array single-float (1025)) areal aimag))
  (prog ((ar areal)
	 (ai aimag)
	 (i 0)
	 (j 0)
	 (k 0)
	 (m 0)
	 (n 0)
	 (le 0)
	 (le1 0)
	 (ip 0)
	 (nv2 0)
	 (ur 0.0)
	 (ui 0.0)
	 (wr 0.0)
	 (wi 0.0)
	 (tr 0.0)
	 (ti 0.0))
    (declare (fixnum i j k m n le le1 ip nv2)
	     (single-float ur ui wr wi tr ti))
    (setq n (array-dimension ar 0)
	  n (1- n)
	  nv2 (floor n 2)
	  m 0					;compute m = log(n)
	  i 1)
 l1 (cond ((< i n)
	   (setq m (1+ m)
		 i (+ i i))
	   (go l1)))
    (cond ((not (equal n (expt 2 m)))
	   (princ "error ... array size not a power of two.")
	   (read)
	   (return (terpri))))
    (setq j 1					;interchange elements
	  i 1)					;in bit-reversed order
 l3 (cond ((< i j)
	   (setq tr (aref ar j)
		 ti (aref ai j))
	   (setf (aref ar j) (aref ar i))
	   (setf (aref ai j) (aref ai i))
	   (setf (aref ar i) tr)
	   (setf (aref ai i) ti)))
    (setq k nv2)
 l6 (cond ((< k j) 
	   (setq j (- j k)
		 k (/ k 2))
	   (go l6)))
    (setq j (+ j k)
	  i (1+ i))
    (cond ((< i n)
	   (go l3)))
    (do ((l 1 (1+ l)))
	((> l m))			;loop thru stages
      (declare (fixnum l))
      (setq le (expt 2 l)
	    le1 (floor le 2)
	    ur 1.0
	    ui 0.0
	    wr (cos (/ 3.14159265 (float le1)))
	    wi (sin (/ 3.14159265 (float le1))))
      (do ((j 1 (1+ j)))
	  ((> j le1))		;loop thru butterflies
	(declare (fixnum j))
	(do ((i j (+ i le)))
	    ((> i n))		;do a butterfly
	  (declare (fixnum i))
	  (setq ip (+ i le1)
		tr (- (* (aref ar ip) ur)
		      (* (aref ai ip) ui))
		ti (+ (* (aref ar ip) ui)
		      (* (aref ai ip) ur)))
	  (setf (aref ar ip) (- (aref ar i) tr))
	  (setf (aref ai ip) (- (aref ai i) ti))
	  (setf (aref ar i) (+ (aref ar i) tr))
	  (setf (aref ai i) (+ (aref ai i) ti))))
	(setq tr (- (* ur wr) (* ui wi))
	      ti (+ (* ur wi) (* ui wr))
	      ur tr
	      ui ti))
    (return t)))

(defmacro fft-bench ()
  '(do ((ntimes 0 (1+ ntimes)))
      ((= ntimes 10.))
     (declare (fixnum ntimes))
     (fft re im)))

(defun time-fft ()
  (time (fft-bench)))
