Annotation of gforth/complex.fs, revision 1.3

1.2       anton       1: \ complex numbers
                      2: 
                      3: \ Copyright (C) 2005 Free Software Foundation, Inc.
                      4: 
                      5: \ This file is part of Gforth.
                      6: 
                      7: \ Gforth is free software; you can redistribute it and/or
                      8: \ modify it under the terms of the GNU General Public License
                      9: \ as published by the Free Software Foundation; either version 2
                     10: \ of the License, or (at your option) any later version.
                     11: 
                     12: \ This program is distributed in the hope that it will be useful,
                     13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
                     14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
                     15: \ GNU General Public License for more details.
                     16: 
                     17: \ You should have received a copy of the GNU General Public License
                     18: \ along with this program; if not, write to the Free Software
                     19: \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
                     20: 
1.1       pazsan     21: \              *** Complex arithmetic ***              23sep91py
                     22: 
1.3     ! pazsan     23: : complex' ( n -- offset ) 2* floats ;
        !            24: : complex+ ( zaddr -- zaddr' ) float+ float+ ;
1.1       pazsan     25: 
                     26: \ simple operations                                    02mar05py
                     27: 
1.3     ! pazsan     28: : fl>      ( -- r ) f@local0 lp+ ;
1.1       pazsan     29: 
1.3     ! pazsan     30: : zdup     ( z -- z z ) fover fover ;
        !            31: : zdrop    ( z -- ) fdrop fdrop ;
        !            32: : zover    ( z1 z2 -- z1 z2 z1 ) 3 fpick 3 fpick ;
        !            33: : z>r      ( z -- r:z) f>l f>l ;
        !            34: : zr>      ( r:z -- z ) fl> fl> ;
        !            35: : zswap    ( z1 z2 -- z2 z1 ) frot f>l frot fl> ;
        !            36: : zpick    ( z1 .. zn n -- z1 .. zn z1 ) 2* 1+ >r r@ fpick r> fpick ;
1.1       pazsan     37: \ : zpin     2* 1+ >r r@ fpin r> fpin ;
1.3     ! pazsan     38: : zdepth   ( -- u ) fdepth 2/ ;
        !            39: : zrot     ( z1 z2 z3 -- z2 z3 z1 ) z>r zswap zr> zswap ;
        !            40: : z-rot    ( z1 z2 z3 -- z3 z1 z2 ) zswap z>r zswap zr> ;
        !            41: : z@       ( zaddr -- z ) dup >r f@ r> float+ f@ ;
        !            42: : z!       ( z zaddr -- ) dup >r float+ f! r> f! ;
1.1       pazsan     43: 
                     44: \ simple operations                                    02mar05py
1.3     ! pazsan     45: : z+       ( z1 z2 -- z1+z2 ) frot f+ f>l f+ fl> ;
        !            46: : z-       ( z1 z2 -- z1-z2 ) fnegate frot f+ f>l f- fl> ;
        !            47: : zr-      ( z1 z2 -- z2-z1 ) frot f- f>l fswap f- fl> ;
        !            48: : x+       ( z r -- z+r ) frot f+ fswap ;
        !            49: : x-       ( z r -- z-r ) fnegate x+ ;
        !            50: : z*       ( z1 z2 -- z1*z2 )
        !            51:            fdup 4 fpick f* f>l fover 3 fpick f* f>l
1.1       pazsan     52:            f>l fswap fl> f* f>l f* fl> f- fl> fl> f+ ;
1.3     ! pazsan     53: : zscale   ( z r -- z*r ) ftuck f* f>l f* fl> ;
1.1       pazsan     54: 
                     55: \ simple operations                                    02mar05py
                     56: 
1.3     ! pazsan     57: : znegate  ( z -- -z ) fnegate fswap fnegate fswap ;
        !            58: : zconj    ( rr ri -- rr -ri ) fnegate ;
        !            59: : z*i      ( z -- z*i ) fnegate fswap ;
        !            60: : z/i      ( z -- z/i ) fswap fnegate ;
        !            61: : zsqabs   ( z -- |z|² ) fdup f* fswap fdup f* f+ ;
        !            62: : 1/z      ( z -- 1/z ) zconj zdup zsqabs 1/f zscale ;
        !            63: : z/       ( z1 z2 -- z1/z2 ) 1/z z* ;
        !            64: : |z|      ( z -- r ) zsqabs fsqrt ;
        !            65: : zabs     ( z -- |z| ) |z| 0e ;
        !            66: : z2/      ( z -- z/2 ) f2/ f>l f2/ fl> ;
        !            67: : z2*      ( z -- z*2 ) f2* f>l f2* fl> ;
1.1       pazsan     68: 
                     69: : >polar  ( z -- r theta )  zdup  |z|  fswap frot fatan2 ;
                     70: : polar>  ( r theta -- z )  fsincos frot  zscale  fswap ;
                     71: 
                     72: \ zexp zln                                             02mar05py
                     73: 
1.3     ! pazsan     74: : zexp     ( z -- exp[z] ) fsincos fswap frot fexp zscale ;
        !            75: : pln      ( z -- pln[z] ) zdup fswap fatan2 frot frot |z| fln fswap ;
        !            76: : zln      ( z -- ln[z] ) >polar fswap fln fswap ;
1.1       pazsan     77: 
1.3     ! pazsan     78: : z0=      ( z -- flag ) f0= >r f0= r> and ;
        !            79: : zsqrt    ( z -- sqrt[z] ) zdup z0= 0= IF
1.1       pazsan     80:     fdup f0= IF  fdrop fsqrt 0e  EXIT  THEN
                     81:     zln z2/ zexp  THEN ;
1.3     ! pazsan     82: : z**      ( z1 z2 -- z1**z2 ) zswap zln z* zexp ;
1.1       pazsan     83: \ Test: Fibonacci-Zahlen
                     84: 1e 5e fsqrt f+ f2/ fconstant g  1e g f- fconstant -h
1.3     ! pazsan     85: : zfib     ( z1 -- fib[z1] ) zdup z>r g 0e zswap z**
1.1       pazsan     86:   zr> zswap z>r -h 0e zswap z** znegate zr> z+
                     87:   [ g -h f- 1/f ] FLiteral zscale ;
                     88: 
                     89: \ complexe Operationen                                 02mar05py
                     90: 
1.3     ! pazsan     91: : zsinh    ( z -- sinh[z] ) zexp zdup 1/z z- z2/ ;
        !            92: : zcosh    ( z -- cosh[z] ) zexp zdup 1/z z+ z2/ ;
        !            93: : ztanh    ( z -- tanh[z] ) z2* zexp zdup 1e 0e z- zswap 1e 0e z+ z/ ;
        !            94: 
        !            95: : zsin     ( z -- sin[z] ) z*i zsinh  z/i ;
        !            96: : zcos     ( z -- cos[z] ) z*i zcosh ;
        !            97: : ztan     ( z -- tan[z] ) z*i ztanh  z/i ;
1.1       pazsan     98: 
1.3     ! pazsan     99: : Real     ( z -- r ) fdrop ;
        !           100: : Imag     ( z -- i ) fnip  ;
1.1       pazsan    101: 
1.3     ! pazsan    102: : Re       ( z -- zr ) Real 0e ;
        !           103: : Im       ( z -- zi ) Imag 0e ;
1.1       pazsan    104: 
                    105: \ complexe Operationen                                 02mar05py
                    106: 
1.3     ! pazsan    107: : zasinh    ( z -- asinh[z] ) zdup 1e f+   zover 1e f-   z* zsqrt z+ pln ;
        !           108: : zacosh    ( z -- acosh[z] ) zdup 1e x- z2/ zsqrt  zswap 1e x+ z2/ zsqrt z+
1.1       pazsan    109:   pln z2* ;
1.3     ! pazsan    110: : zatanh    ( z -- atanh[z] ) zdup  1e x+ zln  zswap 1e x- znegate pln  z- z2/ ;
        !           111: : zacoth    ( z -- acoth[z] ) znegate zdup 1e x- pln  zswap 1e x+ pln   z- z2/ ;
1.1       pazsan    112: 
                    113: pi f2/ FConstant pi/2
                    114: 
1.3     ! pazsan    115: : zasin   ( z -- -iln[iz+sqrt[1-z^~2]] )   z*i zasinh z/i ;
        !           116: : zacos   ( z -- pi/2-asin[z] )     pi/2 0e zswap zasin z- ;
        !           117: : zatan   ( z -- [ln[1+iz]-ln[1-iz]]/2i ) z*i zatanh z/i ;
        !           118: : zacot   ( z -- [ln[[z+i]/[z-i]]/2i )    z*i zacoth z/i ;
1.1       pazsan    119: 
                    120: \ Ausgabe                                              24sep05py
                    121: 
                    122: Defer fc.       ' f. IS fc.
1.3     ! pazsan    123: : z. ( z -- )
        !           124:            zdup z0= IF  zdrop ." 0 "  exit  THEN
1.1       pazsan    125:            fdup f0= IF  fdrop fc. exit  THEN   fswap
                    126:            fdup f0= IF    fdrop
                    127:                     ELSE  fc.
                    128:                           fdup f0> IF  ." +"  THEN  THEN
                    129:            fc. ." i " ;
1.3     ! pazsan    130: : z.s ( z1 .. zn -- z1 .. zn )
        !           131:           zdepth 0 ?DO  i zpick zswap z>r z. zr>  LOOP ;

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>