\ TESTFFT -- test code for fft programs.

assign sp: ""

INCLUDE?  fft    sp:fftinc
INCLUDE?  fftrc  sp:fftrc
INCLUDE?  ifftcr sp:ifftcr

jforth2? .IF    INCLUDE? float  ju:float.ffp
         .ELSE  INCLUDE? f.     ju:f.
         .THEN


float_fft? NOT  jforth2?     AND   .IF  fpinit                    .THEN
float_fft? NOT  jforth2? NOT AND   .IF  also floating open-float  .THEN

ANEW task-testfft

4    CONSTANT log2_lentest

log2_lentest 2**
     CONSTANT lentest
14   CONSTANT test_scale

lentest ZARRAY testcary
lentest ARRAY testrary
lentest ARRAY testmap

test_scale 2** float  CONSTANT  fscale_test

jforth2? .IF
no-commas
PI    CONSTANT  pi_test
1.    CONSTANT  r1_test
2.    CONSTANT  r2_test
.ELSE
3.141593+0  CONSTANT  pi_test
1+0   CONSTANT  r1_test
2+0   CONSTANT  r2_test
.THEN

float_fft? .IF   r1_test        CONSTANT rone_test
           .ELSE test_scale 2** CONSTANT rone_test
           .THEN

float_fft? .IF   rone_fft  CONSTANT  rone_test
           .ELSE test_scale 2**  CONSTANT  rone_test 
           .THEN

float_fft? NOT  jforth2? NOT  AND  .IF
: FSIN  COMPILE SIN   ; IMMEDIATE
: FCOS  COMPILE COS   ; IMMEDIATE
: F.R   COMPILE SWAP COMPILE FP.RD ; IMMEDIATE 
.THEN


: PULSEC ( n -- ,make real pulse of length n in cmplx array testcary )
       DUP 0  DO  rone_test  0   I testcary Z!  LOOP
       lentest SWAP  DO 0  DUP   I testcary Z!  LOOP ;

: PULSER ( n -- , make real pulse of length n in real array testrary )
       DUP 0  DO  rone_test      I testrary  !  LOOP
       lentest SWAP  DO 0        I testrary  !  LOOP ;

: COSSINEC ( n -- , n cycles of cos,sine in cmplx array testcary )
           FLOAT r2_test F* pi_test F* lentest  FLOAT F/
           lentest 0
           DO
             DUP I FLOAT F* DUP FCOS SWAP FSIN 
[ float_fft? NOT ]
.IF          fscale_test F* FIX SWAP fscale_test F* FIX SWAP  .THEN
             I testcary Z!
           LOOP DROP
;

: COSR ( n -- , n cycles of cos in real array testrary )
         FLOAT r2_test F* pi_test F* lentest  FLOAT F/
         lentest 0
         DO
           DUP I FLOAT F*  FCOS
[ float_fft? NOT ]
.IF        fscale_test F* FIX  .THEN
           I testrary !
         LOOP DROP
;

: PRTMAP ( -- , print bit reversal map )
    lentest 0
    DO  ?TERMINAL  IF LEAVE THEN
      CR I . I testmap Z@  . .  ."  " 2
    +LOOP
;

: PRTC ( -- , print testcary array )
    lentest 0
    DO
      ?TERMINAL IF LEAVE THEN
      CR I . I testcary Z@
[ float_fft? false = ]
.IF   FLOAT fscale_test F/ SWAP FLOAT fscale_test F/ SWAP  .THEN
      SWAP 4 10 F.R ."  " 4 10 F.R
    LOOP
;

: PRTR ( -- , print testrary array )
    lentest 0
    DO
      ?TERMINAL IF LEAVE THEN
      CR I . I testrary @
[ float_fft? NOT ]
.IF   float fscale_test f/ .THEN
      4 10 F.R
    LOOP
;

\ In TFFTRC and TIFFTCR, for manual scale control (non-float,
\ non-auto-scale), inshift-fft must be given a value to prevent
\ overflow with FFTRC and IFFTCR for this scaling.
\ See documentation for details.

: TFFTRC ( pulse-width -- )
[ float_fft? auto_scale_fft? OR NOT ]  .IF  1 inshift-fft ! .THEN
    PULSER  0 testrary  log2_lentest  FFTRC ;

: TIFFTCR ( -- )
[ float_fft? auto_scale_fft? OR NOT ]  .IF  1 inshift-fft ! .THEN
    0 testrary  log2_lentest  IFFTCR ;

: TEST.PULSES ( -- )
    0 testmap  log2_lentest 1-  INIT.MAP.FFT    \ This is optional.
    lentest 1+ 0  DO
       I TFFTRC TIFFTCR  PRTR
       CR ." Pulse-width of above data should be " I .
       CR ." Press any key to continue, ESCAPE to terminate. "
       KEY 27 = IF ABORT THEN
    LOOP
;

CR CR CR CR CR CR CR CR CR CR
   ." TEST.PULSES -- end-to-end test of"
CR ."                FFT, IFFT, FFTRC, IFFTCR, INIT.MAP.FFT"
CR
CR ." Pulses of varying widths are used which should transform to sinc"
CR ." functions and back to pulse; magnitudes will depend on which"
CR ." variation of the FFT code was compiled."
CR ." Use the right mouse button to freeze display."
CR ." Press any key to continue with next pulse, ESCAPE to terminate."
CR
CR ." To run, enter  test.pulses" CR CR