\\             *** Complexe Arithmetik ***             23sep91py                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                \ Loadscreen                                           15aug03py                                                                \needs float    import float \ include float.fb                                                                                 Module Complex  float also Complex                                                                                              : complex' 2* floats ;                                          : complex+ float+ float+ ;                                                                                                      1 7 +thru                                                                                                                       toss  Module;                                                                                                                                                                                                                                                                                                                   \ simple operations                                    02mar05py: zdup     fover fover ; macro  : zdrop    fdrop fdrop ; macro  : zover    fover3 fover3 ; macro                                Code z>r   $14 # RP sub  .fx $A RP D) fstp  .fx  RP ) fstp                 Next end-code macro                                  Code zr>   .fx RP ) fld  .fx $A RP D) fld  $14 # RP add                    Next end-code macro                                  Code zswap 1 ST fxch  3 ST fxch  1 ST fxch  2 ST fxch                      Next end-code macro                                  : zpick    2* 1+ >r r@ fpick r> fpick ;                         : zpin     2* 1+ >r r@ fpin r> fpin ;                           : zdepth   fdepth 2/ ;                                          : zrot     z>r zswap zr> zswap ;                                : z-rot    zswap z>r zswap zr> ;                                : z@       dup >r f@ r> float+ f@ ;                             : z!       dup >r float+ f! r> f! ;                             \ simple operations                                    02mar05pyCode z+    2 STP fadd   2 STP fadd   Next end-code macro        Code z-    2 STP fsubr  2 STP fsubr  Next end-code macro        Code zr-   2 STP fsub   2 STP fsub   Next end-code macro        Code x+    1 STP fadd   Next end-code macro                     Code x-    1 STP fsubr  Next end-code macro                     \ : z+       frot f+ f-rot f+ fswap ;                           \ : z-       fnegate frot f+ f-rot f- fswap ;                   Code z*    0 ST fld  4 ST fmul  2 ST fld 4 ST fmul 1 STP fadd              4 ST fxch  ( i3 i1 r2 i2 r1 )                                   2 STP fmul  2 STP fmul 1 STP fsub 1 ST fxch                     Next end-code                                        \ : z*       fdup 4 fpick f* f>r fover 3 fpick f* f>r           \            f>r fswap fr> f* f>r f* fr> f- fr> fr> f+ ;        Code zscale  2 <ST fmul  1 STP fmul  Next end-code macro        \ : zscale   funder f* f>r f* fr> ;                             \ simple operations                                    02mar05py                                                                : znegate  fnegate fswap fnegate fswap ;                        : zconj    fnegate ;       macro                                : z*i      fnegate fswap ; macro                                : z/i      fswap fnegate ; macro                                : zsqabs   fdup f* fswap fdup f* f+ ;                           : 1/z      zconj zdup zsqabs 1/f zscale ;                       : z/       1/z z* ;                                             : |z|      zsqabs fsqrt ;                                       : zabs     |z| !0 ;                                             : z2/      f2/ f>r f2/ fr> ;                                    : z2*      f2* f>r f2* fr> ;                                                                                                    : >polar  ( z -- r theta )  zdup  |z|  f-rot  fswap fatan2 ;    : polar>  ( r theta -- z )  fsincos frot  zscale  fswap ;       \ zexp zln                                             02mar05py                                                                : zexp     fsincos fswap frot fexp zscale ;                     : pln      zdup fswap fatan2 f-rot |z| fln fswap ;              : zln      >polar fswap fln fswap ;                                                                                             : z0=      f0= >r f0= r> and ;                                  : zsqrt    zdup z0= 0= IF                                           fdup f0= IF  fdrop fsqrt !0  EXIT  THEN                         zln z2/ zexp  THEN ;                                        : z**      zswap zln z* zexp ;                                  \ Test: Fibonacci-Zahlen                                        !1 !5 fsqrt f+ f2/ fconstant g  !1 g f- fconstant -h            : zfib  zdup z>r g !0 zswap z**                                   zr> zswap z>r -h !0 zswap z** znegate zr> z+                    [ g -h f- 1/f ] FLiteral zscale ;                             \ complexe Operationen                                 02mar05py                                                                : zsinh    zexp zdup 1/z z- z2/ ;                               : zcosh    zexp zdup 1/z z+ z2/ ;                               : ztanh    z2* zexp zdup !1 !0 z- zswap !1 !0 z+ z/ ;                                                                           : zsin     z*i zsinh  z/i ;                                     : zcos     z*i zcosh ;                                          : ztan     z*i ztanh  z/i ;                                                                                                     : Real     fdrop ; macro                                        : Imag     fnip  ; macro                                                                                                        : Re       Real !0 ;                                            : Im       Imag !0 ;                                                                                                            \ complexe Operationen                                 14aug07py                                                                : zasinh    zdup !1 f+   zover !1 f-   z* zsqrt z+ pln ;        : zacosh    zdup !1 x- z2/ zsqrt  zswap !1 x+ z2/ zsqrt z+        pln z2* ;                                                     : zatanh    zdup  !1 x+ zln  zswap !1 x- znegate pln  z- z2/ ;  : zacoth    znegate zdup !1 x- pln  zswap !1 x+ pln   z- z2/ ;                                                                  : zasin   ( f: z -- -iln[iz+sqrt[1-z^2]] )   z*i zasinh z/i ;   : zacos   ( f: z -- pi/2-asin[z] )  pi f2/ !0 zswap zasin z- ;  : zatan   ( f: z -- [ln[1+iz]-ln[1-iz]]/2i ) z*i zatanh z/i ;   : zacot   ( f: z -- [ln[[z+i]/[z-i]]/2i )    z*i zacoth z/i ;                                                                                                                                                                                                                                                                   \ Ausgabe                                              24sep05py                                                                Defer fc.       ' f. IS fc.                                     : z.       zdup z0= IF  zdrop ." 0 "  exit  THEN                           fdup f0= IF  fdrop fc. exit  THEN   fswap                       fdup f0= IF    fdrop                                                     ELSE  fc.                                                             fdup f0> IF  ." +"  THEN  THEN                   fc. ." i " ;                                         : z.s      zdepth 0 ?DO  i zpick zswap z>r z. zr> ?cr  LOOP ;