complex-old.fb 8 KB
Newer Older
bp's avatar
bp committed
1
\\             *** Complexe Arithmetik ***             23sep91py                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                \ Loadscreen                                           15aug03py                                                                \needs float    import float \ include float.fb                                                                                 Module Complex  float also Complex                                                                                              : complex' 2* floats ;                                          : complex+ float+ float+ ;                                                                                                      1 6 +thru                                                                                                                       toss  Module;                                                                                                                                                                                                                                                                                                                   \ simple operations                                    02may95py: cdup     fover fover ; macro  : cdrop    fdrop fdrop ; macro  : cover    fover3 fover3 ; macro                                Code c>r   $14 # RP sub  .fx $A RP D) fstp  .fx  RP ) fstp                 Next end-code macro                                  Code cr>   .fx RP ) fld  .fx $A RP D) fld  $14 # RP add                    Next end-code macro                                  Code cswap 1 ST fxch  3 ST fxch  1 ST fxch  2 ST fxch                      Next end-code macro                                  : cpick    2* 1+ >r r@ fpick r> fpick ;                         : cpin     2* 1+ >r r@ fpin r> fpin ;                           : cdepth   fdepth 2/ ;                                          : crot     c>r cswap cr> cswap ;                                : c-rot    cswap c>r cswap cr> ;                                : cf@      dup >r f@ r> float+ f@ ;                             : cf!      dup >r float+ f! r> f! ;                             \ simple operations                                    15aug03pyCode c+    2 STP fadd   2 STP fadd   Next end-code macro        Code c-    2 STP fsubr  2 STP fsubr  Next end-code macro        Code cr-   2 STP fsub   2 STP fsub   Next end-code macro        \ : c+       frot f+ f-rot f+ fswap ;                           \ : c-       fnegate frot f+ f-rot f- fswap ;                   Code c*    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                                        \ : c*       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 cscale  2 <ST fmul  1 STP fmul  Next end-code macro        \ : cscale   funder f* f>r f* fr> ;                                                                                                                                                             \ simple operations                                    15aug03py                                                                : cnegate  fnegate fswap fnegate fswap ;                        : cconj    fnegate ;       macro                                : c*i      fnegate fswap ; macro                                : c/i      fswap fnegate ; macro                                : csqabs   fdup f* fswap fdup f* f+ ;                           : 1/c      cconj cdup csqabs 1/f cscale ;                       : c/       1/c c* ;                                             : cabs     csqabs fsqrt !0 ;                                    : c2/      f2/ f>r f2/ fr> ;                                    : c2*      f2* f>r f2* fr> ;                                                                                                                                                                                                                                                                                                    \ cexp cln                                             15aug94py                                                                : cexp     fsincos fswap frot fexp cscale ;                     : cln      cdup cabs fdrop fln f>r fswap fatan2 fr> fswap ;                                                                     : csqrt    cln c2/ cexp ;                                       : c**      cswap cln c* cexp ;                                                                                                  \ Test: Fibonacci-Zahlen                                                                                                        !1 !5 fsqrt f+ f2/ fconstant g  !1 g f- fconstant -h            : cfib  cdup c>r g !0 cswap c**                                   cr> cswap c>r -h !0 cswap c** cnegate cr> c+                    [ g -h f- 1/f ] FLiteral cscale ;                                                                                                                                                             \ complexe Operationen                                 15aug94py                                                                : csinh    cexp cdup 1/c c- c2/ ;                               : ccosh    cexp cdup 1/c c+ c2/ ;                               : ctanh    c2* cexp cdup !1 !0 c- cswap !1 !0 c+ c/ ;                                                                           : csin     c*i csinh  c/i ;                                     : ccos     c*i ccosh ;                                          : ctan     c*i ctanh  c/i ;                                                                                                     : Re       fdrop !0 ;                                           : Im       fnip  !0 ;                                                                                                                                                                                                                                                                                                           \ Ausgabe                                              16may93py                                                                : c0=      f0= >r f0= r> and ;                                                                                                  Defer fc.       ' f. IS fc.                                     : c.       cdup c0= IF  cdrop ." 0 "  exit  THEN                           fdup f0= IF  fdrop fc. exit  THEN   fswap                       fdup f0= IF    fdrop                                                     ELSE  fc. curleft                                                     fdup f0> IF  ." +"  THEN  THEN                   fc. curleft ." i " ;                                 : c.s      cdepth 0 ?DO  i cpick cswap c>r c. cr> ?cr  LOOP ;