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>