;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; File:         fft.sc
  Description :   FFT benchmark from the  tests .
  Author :         
;;; Created:      8-Apr-85
  Modified :      6 - May-85 09:29:22 (   )
                11 - Aug-87 (   )
                16 - Nov-94 ( Qobi )
;;;               31-Mar-98 (Qobi)
                26 - Mar-00 ( flw )
;;; Language:     Scheme
;;; Status:       Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define pi (atan 0 -1))

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

(define *re* (make-vector 1025 0.0))

(define *im* (make-vector 1025 0.0))

(define (fft areal aimag)
 (let ((ar areal)			;Qobi
       (ai aimag)			;Qobi
       (i 0)
       (j 0)
       (k 0)
       (m 0)
       (n 0)
       (le 0)
       (le1 0)
       (ip 0)
       (nv2 0)
       (nm1 0)
       (ur 0.0)				;Qobi
       (ui 0.0)				;Qobi
       (wr 0.0)				;Qobi
       (wi 0.0)				;Qobi
       (tr 0.0)				;Qobi
       (ti 0.0))			;Qobi
  ;; initialize
  (set! ar areal)
  (set! ai aimag)
  (set! n (vector-length ar))
  (set! n (- n 1))
  (set! nv2 (quotient n 2))
  (set! nm1 (- n 1))
  (set! m 0)				;compute m = log(n)
  (set! i 1)
  (let loop ()
   (if (< i n)
       (begin (set! m (+ m 1))
	      (set! i (+ i i))
	      (loop))))
  (cond ((not (= n (let loop ((i m) (p 1)) ;Qobi
		    (if (zero? i) p (loop (- i 1) (* 2 p))))))
	 (display "array size not a power of two.")
	 (newline)))
  ;; interchange elements in bit-reversed order
  (set! j 1)
  (set! i 1)
  (let l3 ()
   (cond ((< i j)
	  (set! tr (vector-ref ar j))
	  (set! ti (vector-ref ai j))
	  (vector-set! ar j (vector-ref ar i))
	  (vector-set! ai j (vector-ref ai i))
	  (vector-set! ar i tr)
	  (vector-set! ai i ti)))
   (set! k nv2)
   (let l6 ()
    (cond ((< k j)
	   (set! j (- j k))
Qobi : was / but this violates R4RS
	   (l6))))
   (set! j (+ j k))
   (set! i (+ i 1))
   (cond ((< i n) (l3))))
  ;; loop thru stages (syntax converted from old MACLISP style \bs)
  (do ((l 1 (+ l 1))) ((> l m))
   (set! le (let loop ((i l) (p 1))	;Qobi
	     (if (zero? i) p (loop (- i 1) (* 2 p)))))
   (set! le1 (quotient le 2))
   (set! ur 1.0)
   (set! ui 0.0)
   (set! wr (cos (/ pi le1)))
   (set! wi (sin (/ pi le1)))
   ;; loop thru butterflies
   (do ((j 1 (+ j 1))) ((> j le1))
    ;; do a butterfly
    (do ((i j (+ i le))) ((> i n))
     (set! ip (+ i le1))
     (set! tr (- (* (vector-ref ar ip) ur) (* (vector-ref ai ip) ui)))
     (set! ti (+ (* (vector-ref ar ip) ui) (* (vector-ref ai ip) ur)))
     (vector-set! ar ip (- (vector-ref ar i) tr))
     (vector-set! ai ip (- (vector-ref ai i) ti))
     (vector-set! ar i (+ (vector-ref ar i) tr))
     (vector-set! ai i (+ (vector-ref ai i) ti))))
   (set! tr (- (* ur wr) (* ui wi)))
   (set! ti (+ (* ur wi) (* ui wr)))
   (set! ur tr)
   (set! ui ti))
  #t))

  the timer which does 10 calls on fft

(define (fft-bench)
 (do ((ntimes 0 (+ ntimes 1))) ((= ntimes 10))
  (fft *re* *im*)))

(time (fft-bench))


 File:         fft.sc
 Created:      8-Apr-85
               31-Mar-98 (Qobi)
 Language:     Scheme
 Status:       Public Domain

 It tests a variety of floating point operations,
 including array references.
Qobi
Qobi
Qobi
Qobi
Qobi
Qobi
Qobi
Qobi
 initialize
compute m = log(n)
Qobi
 interchange elements in bit-reversed order
 loop thru stages (syntax converted from old MACLISP style \bs)
Qobi
 loop thru butterflies
 do a butterfly
  Description :   FFT benchmark from the  tests .
  Author :         
  Modified :      6 - May-85 09:29:22 (   )
                11 - Aug-87 (   )
                16 - Nov-94 ( Qobi )
                26 - Mar-00 ( flw )

(define pi (atan 0 -1))

  FFT -- This is an FFT benchmark written by   .

(define *re* (make-vector 1025 0.0))

(define *im* (make-vector 1025 0.0))

(define (fft areal aimag)
       (i 0)
       (j 0)
       (k 0)
       (m 0)
       (n 0)
       (le 0)
       (le1 0)
       (ip 0)
       (nv2 0)
       (nm1 0)
  (set! ar areal)
  (set! ai aimag)
  (set! n (vector-length ar))
  (set! n (- n 1))
  (set! nv2 (quotient n 2))
  (set! nm1 (- n 1))
  (set! i 1)
  (let loop ()
   (if (< i n)
       (begin (set! m (+ m 1))
	      (set! i (+ i i))
	      (loop))))
		    (if (zero? i) p (loop (- i 1) (* 2 p))))))
	 (display "array size not a power of two.")
	 (newline)))
  (set! j 1)
  (set! i 1)
  (let l3 ()
   (cond ((< i j)
	  (set! tr (vector-ref ar j))
	  (set! ti (vector-ref ai j))
	  (vector-set! ar j (vector-ref ar i))
	  (vector-set! ai j (vector-ref ai i))
	  (vector-set! ar i tr)
	  (vector-set! ai i ti)))
   (set! k nv2)
   (let l6 ()
    (cond ((< k j)
	   (set! j (- j k))
Qobi : was / but this violates R4RS
	   (l6))))
   (set! j (+ j k))
   (set! i (+ i 1))
   (cond ((< i n) (l3))))
  (do ((l 1 (+ l 1))) ((> l m))
	     (if (zero? i) p (loop (- i 1) (* 2 p)))))
   (set! le1 (quotient le 2))
   (set! ur 1.0)
   (set! ui 0.0)
   (set! wr (cos (/ pi le1)))
   (set! wi (sin (/ pi le1)))
   (do ((j 1 (+ j 1))) ((> j le1))
    (do ((i j (+ i le))) ((> i n))
     (set! ip (+ i le1))
     (set! tr (- (* (vector-ref ar ip) ur) (* (vector-ref ai ip) ui)))
     (set! ti (+ (* (vector-ref ar ip) ui) (* (vector-ref ai ip) ur)))
     (vector-set! ar ip (- (vector-ref ar i) tr))
     (vector-set! ai ip (- (vector-ref ai i) ti))
     (vector-set! ar i (+ (vector-ref ar i) tr))
     (vector-set! ai i (+ (vector-ref ai i) ti))))
   (set! tr (- (* ur wr) (* ui wi)))
   (set! ti (+ (* ur wi) (* ui wr)))
   (set! ur tr)
   (set! ui ti))
  #t))

  the timer which does 10 calls on fft

(define (fft-bench)
 (do ((ntimes 0 (+ ntimes 1))) ((= ntimes 10))
  (fft *re* *im*)))

(time (fft-bench))
