Annotation of gforth/complex.fs, revision 1.2

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

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