Return to complex.fs CVS log

Up to [gforth] / gforth

Annotation of gforth/complex.fs, revision 1.1

1.1     ! pazsan      1: \              *** Complex arithmetic ***              23sep91py
        !             2: 
        !             3: : complex' 2* floats ;
        !             4: : complex+ float+ float+ ;
        !             5: 
        !             6: \ simple operations                                    02mar05py
        !             7: 
        !             8: : fl>      f@local0 lp+ ;
        !             9: 
        !            10: : zdup     fover fover ;
        !            11: : zdrop    fdrop fdrop ;
        !            12: : zover    3 fpick 3 fpick ;
        !            13: : z>r      f>l f>l ;
        !            14: : zr>      fl> fl> ;
        !            15: : zswap    frot f>l frot fl> ;
        !            16: : zpick    2* 1+ >r r@ fpick r> fpick ;
        !            17: \ : zpin     2* 1+ >r r@ fpin r> fpin ;
        !            18: : zdepth   fdepth 2/ ;
        !            19: : zrot     z>r zswap zr> zswap ;
        !            20: : z-rot    zswap z>r zswap zr> ;
        !            21: : z@       dup >r f@ r> float+ f@ ;
        !            22: : z!       dup >r float+ f! r> f! ;
        !            23: 
        !            24: \ simple operations                                    02mar05py
        !            25: : z+       frot f+ f>l f+ fl> ;
        !            26: : z-       fnegate frot f+ f>l f- fl> ;
        !            27: : zr-      frot f- f>l fswap f- fl> ;
        !            28: : x+       frot f+ fswap ;
        !            29: : x-       fnegate x+ ;
        !            30: : z*       fdup 4 fpick f* f>l fover 3 fpick f* f>l
        !            31:            f>l fswap fl> f* f>l f* fl> f- fl> fl> f+ ;
        !            32: : zscale   ftuck f* f>l f* fl> ;
        !            33: 
        !            34: \ simple operations                                    02mar05py
        !            35: 
        !            36: : znegate  fnegate fswap fnegate fswap ;
        !            37: : zconj    fnegate ;
        !            38: : z*i      fnegate fswap ;
        !            39: : z/i      fswap fnegate ;
        !            40: : zsqabs   fdup f* fswap fdup f* f+ ;
        !            41: : 1/z      zconj zdup zsqabs 1/f zscale ;
        !            42: : z/       1/z z* ;
        !            43: : |z|      zsqabs fsqrt ;
        !            44: : zabs     |z| 0e ;
        !            45: : z2/      f2/ f>l f2/ fl> ;
        !            46: : z2*      f2* f>l f2* fl> ;
        !            47: 
        !            48: : >polar  ( z -- r theta )  zdup  |z|  fswap frot fatan2 ;
        !            49: : polar>  ( r theta -- z )  fsincos frot  zscale  fswap ;
        !            50: 
        !            51: \ zexp zln                                             02mar05py
        !            52: 
        !            53: : zexp     fsincos fswap frot fexp zscale ;
        !            54: : pln      zdup fswap fatan2 frot frot |z| fln fswap ;
        !            55: : zln      >polar fswap fln fswap ;
        !            56: 
        !            57: : z0=      f0= >r f0= r> and ;
        !            58: : zsqrt    zdup z0= 0= IF
        !            59:     fdup f0= IF  fdrop fsqrt 0e  EXIT  THEN
        !            60:     zln z2/ zexp  THEN ;
        !            61: : z**      zswap zln z* zexp ;
        !            62: \ Test: Fibonacci-Zahlen
        !            63: 1e 5e fsqrt f+ f2/ fconstant g  1e g f- fconstant -h
        !            64: : zfib  zdup z>r g 0e zswap z**
        !            65:   zr> zswap z>r -h 0e zswap z** znegate zr> z+
        !            66:   [ g -h f- 1/f ] FLiteral zscale ;
        !            67: 
        !            68: \ complexe Operationen                                 02mar05py
        !            69: 
        !            70: : zsinh    zexp zdup 1/z z- z2/ ;
        !            71: : zcosh    zexp zdup 1/z z+ z2/ ;
        !            72: : ztanh    z2* zexp zdup 1e 0e z- zswap 1e 0e z+ z/ ;
        !            73: 
        !            74: : zsin     z*i zsinh  z/i ;
        !            75: : zcos     z*i zcosh ;
        !            76: : ztan     z*i ztanh  z/i ;
        !            77: 
        !            78: : Real     fdrop ;
        !            79: : Imag     fnip  ;
        !            80: 
        !            81: : Re       Real 0e ;
        !            82: : Im       Imag 0e ;
        !            83: 
        !            84: \ complexe Operationen                                 02mar05py
        !            85: 
        !            86: : zasinh    zdup 1e f+   zover 1e f-   z* zsqrt z+ pln ;
        !            87: : zacosh    zdup 1e x- z2/ zsqrt  zswap 1e x+ z2/ zsqrt z+
        !            88:   pln z2* ;
        !            89: : zatanh    zdup  1e x+ zln  zswap 1e x- znegate pln  z- z2/ ;
        !            90: : zacoth    znegate zdup 1e x- pln  zswap 1e x+ pln   z- z2/ ;
        !            91: 
        !            92: pi f2/ FConstant pi/2
        !            93: 
        !            94: : zasin   ( f: z -- -iln[iz+sqrt[1-z^~2]] )   z*i zasinh z/i ;
        !            95: : zacos   ( f: z -- pi/2-asin[z] )     pi/2 0e zswap zasin z- ;
        !            96: : zatan   ( f: z -- [ln[1+iz]-ln[1-iz]]/2i ) z*i zatanh z/i ;
        !            97: : zacot   ( f: z -- [ln[[z+i]/[z-i]]/2i )    z*i zacoth z/i ;
        !            98: 
        !            99: \ Ausgabe                                              24sep05py
        !           100: 
        !           101: Defer fc.       ' f. IS fc.
        !           102: : z.       zdup z0= IF  zdrop ." 0 "  exit  THEN
        !           103:            fdup f0= IF  fdrop fc. exit  THEN   fswap
        !           104:            fdup f0= IF    fdrop
        !           105:                     ELSE  fc.
        !           106:                           fdup f0> IF  ." +"  THEN  THEN
        !           107:            fc. ." i " ;
        !           108: : z.s      zdepth 0 ?DO  i zpick zswap z>r z. zr>  LOOP ;