home *** CD-ROM | disk | FTP | other *** search
/ Club Amiga de Montreal - CAM / CAM_CD_1.iso / files / 326.lha / KFFT_v1.1 / cmplx < prev    next >
Text File  |  1989-12-23  |  3KB  |  112 lines
  1. \ Cmplx - Forth Complex Arithmetic Support Words for KFFT
  2. \ Jerry Kallaus  02/14/89
  3. \
  4.  
  5. INCLUDE? asm_fft? sp:fftcontrols
  6.  
  7. asm_fft? .IF  INCLUDE?  Z*  sp:fft.asm  .THEN
  8.  
  9. anew task-cmplx
  10.  
  11. \ ------------------ Basic support words  -------------------------
  12.  
  13. float_fft? .IF
  14. : s+ COMPILE F+ ;  IMMEDIATE
  15. : s- COMPILE F- ;  IMMEDIATE
  16. : s* COMPILE F* ;  IMMEDIATE
  17. : s/ COMPILE F/ ;  IMMEDIATE
  18. : SNEGATE  COMPILE FNEGATE ; IMMEDIATE
  19. : ZSCALE.DOWN DROP both ;
  20.  
  21. .ELSE
  22. : S+  +  both ;
  23. : S-  -  both ;
  24. : S*  *  [ scale_fft negate ] literal ashift     ;
  25. : S/  swap [ scale_fft ] literal ashift swap /   ;
  26. : SNEGATE  NEGATE  both ;
  27. scale_fft 2**  CONSTANT rone_fft
  28. .THEN
  29.  
  30. float_fft? jforth2? AND .IF
  31. pi   CONSTANT pi_fft
  32. 1.0  CONSTANT rone_fft
  33. .THEN
  34.  
  35. float_fft? jforth2? NOT AND .IF
  36. 3.14159265+0 CONSTANT pi_fft
  37. 1+0          CONSTANT rone_fft        
  38. : fsin   compile sin    ; immediate
  39. : fcos   compile cos    ; immediate
  40. : f.r    compile fp.rd  ; immediate
  41. .THEN
  42.  
  43. float_fft? asm_fft? OR NOT .IF
  44. : ZSCALE.DOWN  ?DUP IF negate dup>r ashift swap r> ashift swap THEN both ;
  45. .THEN
  46.  
  47. fixasm_fft?  .IF
  48. : ZSCALE.DOWN  compile  Z/2**N ; immediate
  49. .THEN
  50.  
  51. asm_fft? NOT .IF
  52. : 2CELL+  CELL+ CELL+  both ;
  53. : 2CELL-  CELL- CELL-  both ;
  54. : 2CELLS  CELLS 2*  both ;
  55. : 4DUP    4 XDUP  both ;
  56. : Z@      dup>r @ r> cell+ @ both ;
  57. : Z!      dup>r cell+ ! r> ! both ;
  58. .THEN
  59.  
  60. : 2CELL   8       both ;
  61. : ZCELL   2CELL   both ;
  62. : ZCELL+  2cell+  both ;
  63. : ZCELL-  2cell-  both ;
  64. : ZCELLS  2cells  both ;
  65. : ZDROP   2drop   both ;
  66. : ZDUP    2dup    both ;
  67. : ZOVER   2over   both ;
  68. : Z2DUP   4DUP    both ;
  69.  
  70. \ -----------------  Complex Arithmetic Stack Words  ---------------
  71.  
  72. fixasm_fft? NOT .IF
  73. : Z+  ( a b c d --  a+c b+d )  rot s+ >r s+ r> both ;
  74. : Z-  ( a b c d  --  a-c b-d)  rot swap s- >r s- r> both ;
  75. : Z*  { a b c d  ---  ac-bd ad+bc }
  76.             a c s* b d s* s-  a d s* b c s* s+  ;
  77.  
  78. \ : Z*  ( a b c d  --  ac-bd ad+bc ) 
  79. \          2over 2over -rot s*  rot  s* s+ >r
  80. \                      rot s* -rot  s* swap s-  r>  ;
  81.  
  82. : ZNEGATE ( a b -- -a -b ) 
  83.     snegate swap snegate swap  both ;
  84.  
  85. .THEN
  86.  
  87. : CONJG  ( z -- conjugate z )  snegate  both ;
  88. : ZI*    ( a b -- -b a , cmplex multipy by i )  snegate  swap  both ;
  89.  
  90. float_fft? .IF
  91. : ZEXP ( z -- cosz sinz ) dup>r fcos r> fsin ;
  92. .THEN
  93.  
  94. \ -----------------  Forth Complex Data Type Words  -------------------
  95.  
  96. \ Complex number definitions.
  97. \ Convention for complex number on stack  is the imaginary part is on top.
  98. \ Convention for complex number in memory is the real part is at lower addr.
  99. \
  100. : ZCONSTANT   create swap , ,  does>  Z@ ;
  101. : ZVARIABLE   create 0 0 , ,   does>     ;
  102. : ZARRAY  ( #elements -- )             ( ex: 1024 ZARRAY myarray         )
  103.     create  2cells allot
  104.     does>   swap 2cells + ;            ( i myarray         gets ith addr )
  105.  
  106. : ZPTR  ( addr-of-pointer -- )         ( ex: VARIABLE mypointer           )
  107.     create ,                           ( mypointer ZPTR c-ptr             )
  108.     does> @ @ swap 2cells + ;          ( 0 myarray mypointer !            )
  109.                                        ( i c-ptr            gets ith addr )
  110.  
  111. rone_fft 0  ZCONSTANT  Z1
  112.