[gforth] / gforth / complex.fs  

gforth: gforth/complex.fs

Diff for /gforth/complex.fs between version 1.2 and 1.5

version 1.2, Sat Dec 31 15:46:08 2005 UTC version 1.5, Mon Dec 31 18:40:23 2007 UTC
Line 1 
Line 1 
 \ complex numbers  \ complex numbers
   
 \ Copyright (C) 2005 Free Software Foundation, Inc.  \ Copyright (C) 2005,2007 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
 \ Gforth is free software; you can redistribute it and/or  \ Gforth is free software; you can redistribute it and/or
 \ modify it under the terms of the GNU General Public License  \ modify it under the terms of the GNU General Public License
 \ as published by the Free Software Foundation; either version 2  \ as published by the Free Software Foundation, either version 3
 \ of the License, or (at your option) any later version.  \ of the License, or (at your option) any later version.
   
 \ This program is distributed in the hope that it will be useful,  \ This program is distributed in the hope that it will be useful,
Line 15 
Line 15 
 \ GNU General Public License for more details.  \ GNU General Public License for more details.
   
 \ You should have received a copy of the GNU General Public License  \ You should have received a copy of the GNU General Public License
 \ along with this program; if not, write to the Free Software  \ along with this program. If not, see http://www.gnu.org/licenses/.
 \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.  
   
 \              *** Complex arithmetic ***              23sep91py  \              *** Complex arithmetic ***              23sep91py
   
 : complex' 2* floats ;  : complex' ( n -- offset ) 2* floats ;
 : complex+ float+ float+ ;  : complex+ ( zaddr -- zaddr' ) float+ float+ ;
   
 \ simple operations                                    02mar05py  \ simple operations                                    02mar05py
   
 : fl>      f@local0 lp+ ;  : fl>      ( -- r ) f@local0 lp+ ;
   
 : zdup     fover fover ;  : zdup     ( z -- z z ) fover fover ;
 : zdrop    fdrop fdrop ;  : zdrop    ( z -- ) fdrop fdrop ;
 : zover    3 fpick 3 fpick ;  : zover    ( z1 z2 -- z1 z2 z1 ) 3 fpick 3 fpick ;
 : z>r      f>l f>l ;  : z>r      ( z -- r:z) f>l f>l ;
 : zr>      fl> fl> ;  : zr>      ( r:z -- z ) fl> fl> ;
 : zswap    frot f>l frot fl> ;  : zswap    ( z1 z2 -- z2 z1 ) frot f>l frot fl> ;
 : zpick    2* 1+ >r r@ fpick r> fpick ;  : zpick    ( z1 .. zn n -- z1 .. zn z1 ) 2* 1+ >r r@ fpick r> fpick ;
 \ : zpin     2* 1+ >r r@ fpin r> fpin ;  \ : zpin     2* 1+ >r r@ fpin r> fpin ;
 : zdepth   fdepth 2/ ;  : zdepth   ( -- u ) fdepth 2/ ;
 : zrot     z>r zswap zr> zswap ;  : zrot     ( z1 z2 z3 -- z2 z3 z1 ) z>r zswap zr> zswap ;
 : z-rot    zswap z>r zswap zr> ;  : z-rot    ( z1 z2 z3 -- z3 z1 z2 ) zswap z>r zswap zr> ;
 : z@       dup >r f@ r> float+ f@ ;  : z@       ( zaddr -- z ) dup >r f@ r> float+ f@ ;
 : z!       dup >r float+ f! r> f! ;  : z!       ( z zaddr -- ) dup >r float+ f! r> f! ;
   
 \ simple operations                                    02mar05py  \ simple operations                                    02mar05py
 : z+       frot f+ f>l f+ fl> ;  : z+       ( z1 z2 -- z1+z2 ) frot f+ f>l f+ fl> ;
 : z-       fnegate frot f+ f>l f- fl> ;  : z-       ( z1 z2 -- z1-z2 ) fnegate frot f+ f>l f- fl> ;
 : zr-      frot f- f>l fswap f- fl> ;  : zr-      ( z1 z2 -- z2-z1 ) frot f- f>l fswap f- fl> ;
 : x+       frot f+ fswap ;  : x+       ( z r -- z+r ) frot f+ fswap ;
 : x-       fnegate x+ ;  : x-       ( z r -- z-r ) fnegate x+ ;
 : z*       fdup 4 fpick f* f>l fover 3 fpick f* f>l  : z*       ( z1 z2 -- z1*z2 )
              fdup 4 fpick f* f>l fover 3 fpick f* f>l
            f>l fswap fl> f* f>l f* fl> f- fl> fl> f+ ;             f>l fswap fl> f* f>l f* fl> f- fl> fl> f+ ;
 : zscale   ftuck f* f>l f* fl> ;  : zscale   ( z r -- z*r ) ftuck f* f>l f* fl> ;
   
 \ simple operations                                    02mar05py  \ simple operations                                    02mar05py
   
 : znegate  fnegate fswap fnegate fswap ;  : znegate  ( z -- -z ) fnegate fswap fnegate fswap ;
 : zconj    fnegate ;  : zconj    ( rr ri -- rr -ri ) fnegate ;
 : z*i      fnegate fswap ;  : z*i      ( z -- z*i ) fnegate fswap ;
 : z/i      fswap fnegate ;  : z/i      ( z -- z/i ) fswap fnegate ;
 : zsqabs   fdup f* fswap fdup f* f+ ;  : zsqabs   ( z -- |z|² ) fdup f* fswap fdup f* f+ ;
 : 1/z      zconj zdup zsqabs 1/f zscale ;  : 1/z      ( z -- 1/z ) zconj zdup zsqabs 1/f zscale ;
 : z/       1/z z* ;  : z/       ( z1 z2 -- z1/z2 ) 1/z z* ;
 : |z|      zsqabs fsqrt ;  : |z|      ( z -- r ) zsqabs fsqrt ;
 : zabs     |z| 0e ;  : zabs     ( z -- |z| ) |z| 0e ;
 : z2/      f2/ f>l f2/ fl> ;  : z2/      ( z -- z/2 ) f2/ f>l f2/ fl> ;
 : z2*      f2* f>l f2* fl> ;  : z2*      ( z -- z*2 ) f2* f>l f2* fl> ;
   
 : >polar  ( z -- r theta )  zdup  |z|  fswap frot fatan2 ;  : >polar  ( z -- r theta )  zdup  |z|  fswap frot fatan2 ;
 : polar>  ( r theta -- z )  fsincos frot  zscale  fswap ;  : polar>  ( r theta -- z )  fsincos frot  zscale  fswap ;
   
 \ zexp zln                                             02mar05py  \ zexp zln                                             02mar05py
   
 : zexp     fsincos fswap frot fexp zscale ;  : zexp     ( z -- exp[z] ) fsincos fswap frot fexp zscale ;
 : pln      zdup fswap fatan2 frot frot |z| fln fswap ;  : pln      ( z -- pln[z] ) zdup fswap fatan2 frot frot |z| fln fswap ;
 : zln      >polar fswap fln fswap ;  : zln      ( z -- ln[z] ) >polar fswap fln fswap ;
   
 : z0=      f0= >r f0= r> and ;  : z0=      ( z -- flag ) f0= >r f0= r> and ;
 : zsqrt    zdup z0= 0= IF  : zsqrt    ( z -- sqrt[z] ) zdup z0= 0= IF
     fdup f0= IF  fdrop fsqrt 0e  EXIT  THEN      fdup f0= IF  fdrop fsqrt 0e  EXIT  THEN
     zln z2/ zexp  THEN ;      zln z2/ zexp  THEN ;
 : z**      zswap zln z* zexp ;  : z**      ( z1 z2 -- z1**z2 ) zswap zln z* zexp ;
 \ Test: Fibonacci-Zahlen  \ Test: Fibonacci-Zahlen
 1e 5e fsqrt f+ f2/ fconstant g  1e g f- fconstant -h  1e 5e fsqrt f+ f2/ fconstant g  1e g f- fconstant -h
 : zfib  zdup z>r g 0e zswap z**  : zfib     ( z1 -- fib[z1] ) zdup z>r g 0e zswap z**
   zr> zswap z>r -h 0e zswap z** znegate zr> z+    zr> zswap z>r -h 0e zswap z** znegate zr> z+
   [ g -h f- 1/f ] FLiteral zscale ;    [ g -h f- 1/f ] FLiteral zscale ;
   
 \ complexe Operationen                                 02mar05py  \ complexe Operationen                                 02mar05py
   
 : zsinh    zexp zdup 1/z z- z2/ ;  : zsinh    ( z -- sinh[z] ) zexp zdup 1/z z- z2/ ;
 : zcosh    zexp zdup 1/z z+ z2/ ;  : zcosh    ( z -- cosh[z] ) zexp zdup 1/z z+ z2/ ;
 : ztanh    z2* zexp zdup 1e 0e z- zswap 1e 0e z+ z/ ;  : ztanh    ( z -- tanh[z] ) z2* zexp zdup 1e 0e z- zswap 1e 0e z+ z/ ;
   
 : zsin     z*i zsinh  z/i ;  : zsin     ( z -- sin[z] ) z*i zsinh  z/i ;
 : zcos     z*i zcosh ;  : zcos     ( z -- cos[z] ) z*i zcosh ;
 : ztan     z*i ztanh  z/i ;  : ztan     ( z -- tan[z] ) z*i ztanh  z/i ;
   
 : Real     fdrop ;  : Real     ( z -- r ) fdrop ;
 : Imag     fnip  ;  : Imag     ( z -- i ) fnip  ;
   
 : Re       Real 0e ;  : Re       ( z -- zr ) Real 0e ;
 : Im       Imag 0e ;  : Im       ( z -- zi ) Imag 0e ;
   
 \ complexe Operationen                                 02mar05py  \ complexe Operationen                                 02mar05py
   
 : zasinh    zdup 1e f+   zover 1e f-   z* zsqrt z+ pln ;  : zasinh    ( z -- asinh[z] ) zdup 1e f+   zover 1e f-   z* zsqrt z+ pln ;
 : zacosh    zdup 1e x- z2/ zsqrt  zswap 1e x+ z2/ zsqrt z+  : zacosh    ( z -- acosh[z] ) zdup 1e x- z2/ zsqrt  zswap 1e x+ z2/ zsqrt z+
   pln z2* ;    pln z2* ;
 : zatanh    zdup  1e x+ zln  zswap 1e x- znegate pln  z- z2/ ;  : zatanh    ( z -- atanh[z] ) zdup  1e x+ zln  zswap 1e x- znegate pln  z- z2/ ;
 : zacoth    znegate zdup 1e x- pln  zswap 1e x+ pln   z- z2/ ;  : zacoth    ( z -- acoth[z] ) znegate zdup 1e x- pln  zswap 1e x+ pln   z- z2/ ;
   
 pi f2/ FConstant pi/2  pi f2/ FConstant pi/2
   
 : zasin   ( f: z -- -iln[iz+sqrt[1-z^~2]] )   z*i zasinh z/i ;  : zasin   ( z -- -iln[iz+sqrt[1-z^~2]] )   z*i zasinh z/i ;
 : zacos   ( f: z -- pi/2-asin[z] )     pi/2 0e zswap zasin z- ;  : zacos   ( z -- pi/2-asin[z] )     pi/2 0e zswap zasin z- ;
 : zatan   ( f: z -- [ln[1+iz]-ln[1-iz]]/2i ) z*i zatanh z/i ;  : zatan   ( 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 ;  : zacot   ( z -- [ln[[z+i]/[z-i]]/2i )    z*i zacoth z/i ;
   
 \ Ausgabe                                              24sep05py  \ Ausgabe                                              24sep05py
   
 Defer fc.       ' f. IS fc.  Defer fc.       ' f. IS fc.
 : z.       zdup z0= IF  zdrop ." 0 "  exit  THEN  : z. ( z -- )
              zdup z0= IF  zdrop ." 0 "  exit  THEN
            fdup f0= IF  fdrop fc. exit  THEN   fswap             fdup f0= IF  fdrop fc. exit  THEN   fswap
            fdup f0= IF    fdrop             fdup f0= IF    fdrop
                     ELSE  fc.                      ELSE  fc.
                           fdup f0> IF  ." +"  THEN  THEN                            fdup f0> IF  ." +"  THEN  THEN
            fc. ." i " ;             fc. ." i " ;
 : z.s      zdepth 0 ?DO  i zpick zswap z>r z. zr>  LOOP ;  : z.s ( z1 .. zn -- z1 .. zn )
              zdepth 0 ?DO  i zpick zswap z>r z. zr>  LOOP ;

Generate output suitable for use with a patch program
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.5
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help