home *** CD-ROM | disk | FTP | other *** search
/ Club Amiga de Montreal - CAM / CAM_CD_1.iso / files / 326.lha / KFFT_v1.1 / testfft < prev    next >
Text File  |  1989-12-23  |  4KB  |  150 lines
  1. \ TESTFFT -- test code for fft programs.
  2.  
  3. assign sp: ""
  4.  
  5. INCLUDE?  fft    sp:fftinc
  6. INCLUDE?  fftrc  sp:fftrc
  7. INCLUDE?  ifftcr sp:ifftcr
  8.  
  9. jforth2? .IF    INCLUDE? float  ju:float.ffp
  10.          .ELSE  INCLUDE? f.     ju:f.
  11.          .THEN
  12.  
  13.  
  14. float_fft? NOT  jforth2?     AND   .IF  fpinit                    .THEN
  15. float_fft? NOT  jforth2? NOT AND   .IF  also floating open-float  .THEN
  16.  
  17. ANEW task-testfft
  18.  
  19. 4    CONSTANT log2_lentest
  20.  
  21. log2_lentest 2**
  22.      CONSTANT lentest
  23. 14   CONSTANT test_scale
  24.  
  25. lentest ZARRAY testcary
  26. lentest ARRAY testrary
  27. lentest ARRAY testmap
  28.  
  29. test_scale 2** float  CONSTANT  fscale_test
  30.  
  31. jforth2? .IF
  32. no-commas
  33. PI    CONSTANT  pi_test
  34. 1.    CONSTANT  r1_test
  35. 2.    CONSTANT  r2_test
  36. .ELSE
  37. 3.141593+0  CONSTANT  pi_test
  38. 1+0   CONSTANT  r1_test
  39. 2+0   CONSTANT  r2_test
  40. .THEN
  41.  
  42. float_fft? .IF   r1_test        CONSTANT rone_test
  43.            .ELSE test_scale 2** CONSTANT rone_test
  44.            .THEN
  45.  
  46. float_fft? .IF   rone_fft  CONSTANT  rone_test
  47.            .ELSE test_scale 2**  CONSTANT  rone_test 
  48.            .THEN
  49.  
  50. float_fft? NOT  jforth2? NOT  AND  .IF
  51. : FSIN  COMPILE SIN   ; IMMEDIATE
  52. : FCOS  COMPILE COS   ; IMMEDIATE
  53. : F.R   COMPILE SWAP COMPILE FP.RD ; IMMEDIATE 
  54. .THEN
  55.  
  56.  
  57. : PULSEC ( n -- ,make real pulse of length n in cmplx array testcary )
  58.        DUP 0  DO  rone_test  0   I testcary Z!  LOOP
  59.        lentest SWAP  DO 0  DUP   I testcary Z!  LOOP ;
  60.  
  61. : PULSER ( n -- , make real pulse of length n in real array testrary )
  62.        DUP 0  DO  rone_test      I testrary  !  LOOP
  63.        lentest SWAP  DO 0        I testrary  !  LOOP ;
  64.  
  65. : COSSINEC ( n -- , n cycles of cos,sine in cmplx array testcary )
  66.            FLOAT r2_test F* pi_test F* lentest  FLOAT F/
  67.            lentest 0
  68.            DO
  69.              DUP I FLOAT F* DUP FCOS SWAP FSIN 
  70. [ float_fft? NOT ]
  71. .IF          fscale_test F* FIX SWAP fscale_test F* FIX SWAP  .THEN
  72.              I testcary Z!
  73.            LOOP DROP
  74. ;
  75.  
  76. : COSR ( n -- , n cycles of cos in real array testrary )
  77.          FLOAT r2_test F* pi_test F* lentest  FLOAT F/
  78.          lentest 0
  79.          DO
  80.            DUP I FLOAT F*  FCOS
  81. [ float_fft? NOT ]
  82. .IF        fscale_test F* FIX  .THEN
  83.            I testrary !
  84.          LOOP DROP
  85. ;
  86.  
  87. : PRTMAP ( -- , print bit reversal map )
  88.     lentest 0
  89.     DO  ?TERMINAL  IF LEAVE THEN
  90.       CR I . I testmap Z@  . .  ."  " 2
  91.     +LOOP
  92. ;
  93.  
  94. : PRTC ( -- , print testcary array )
  95.     lentest 0
  96.     DO
  97.       ?TERMINAL IF LEAVE THEN
  98.       CR I . I testcary Z@
  99. [ float_fft? false = ]
  100. .IF   FLOAT fscale_test F/ SWAP FLOAT fscale_test F/ SWAP  .THEN
  101.       SWAP 4 10 F.R ."  " 4 10 F.R
  102.     LOOP
  103. ;
  104.  
  105. : PRTR ( -- , print testrary array )
  106.     lentest 0
  107.     DO
  108.       ?TERMINAL IF LEAVE THEN
  109.       CR I . I testrary @
  110. [ float_fft? NOT ]
  111. .IF   float fscale_test f/ .THEN
  112.       4 10 F.R
  113.     LOOP
  114. ;
  115.  
  116. \ In TFFTRC and TIFFTCR, for manual scale control (non-float,
  117. \ non-auto-scale), inshift-fft must be given a value to prevent
  118. \ overflow with FFTRC and IFFTCR for this scaling.
  119. \ See documentation for details.
  120.  
  121. : TFFTRC ( pulse-width -- )
  122. [ float_fft? auto_scale_fft? OR NOT ]  .IF  1 inshift-fft ! .THEN
  123.     PULSER  0 testrary  log2_lentest  FFTRC ;
  124.  
  125. : TIFFTCR ( -- )
  126. [ float_fft? auto_scale_fft? OR NOT ]  .IF  1 inshift-fft ! .THEN
  127.     0 testrary  log2_lentest  IFFTCR ;
  128.  
  129. : TEST.PULSES ( -- )
  130.     0 testmap  log2_lentest 1-  INIT.MAP.FFT    \ This is optional.
  131.     lentest 1+ 0  DO
  132.        I TFFTRC TIFFTCR  PRTR
  133.        CR ." Pulse-width of above data should be " I .
  134.        CR ." Press any key to continue, ESCAPE to terminate. "
  135.        KEY 27 = IF ABORT THEN
  136.     LOOP
  137. ;
  138.  
  139. CR CR CR CR CR CR CR CR CR CR
  140.    ." TEST.PULSES -- end-to-end test of"
  141. CR ."                FFT, IFFT, FFTRC, IFFTCR, INIT.MAP.FFT"
  142. CR
  143. CR ." Pulses of varying widths are used which should transform to sinc"
  144. CR ." functions and back to pulse; magnitudes will depend on which"
  145. CR ." variation of the FFT code was compiled."
  146. CR ." Use the right mouse button to freeze display."
  147. CR ." Press any key to continue with next pulse, ESCAPE to terminate."
  148. CR
  149. CR ." To run, enter  test.pulses" CR CR
  150.