1\ complex numbers 2 3\ Copyright (C) 2005,2007 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 3 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, see http://www.gnu.org/licenses/. 19 20\ *** Complex arithmetic *** 23sep91py 21 22: complex' ( n -- offset ) 2* floats ; 23: complex+ ( zaddr -- zaddr' ) float+ float+ ; 24 25\ simple operations 02mar05py 26 27: fl> ( -- r ) f@local0 lp+ ; 28 29: zdup ( z -- z z ) fover fover ; 30: zdrop ( z -- ) fdrop fdrop ; 31: zover ( z1 z2 -- z1 z2 z1 ) 3 fpick 3 fpick ; 32: z>r ( z -- r:z) f>l f>l ; 33: zr> ( r:z -- z ) fl> fl> ; 34: zswap ( z1 z2 -- z2 z1 ) frot f>l frot fl> ; 35: zpick ( z1 .. zn n -- z1 .. zn z1 ) 2* 1+ >r r@ fpick r> fpick ; 36\ : zpin 2* 1+ >r r@ fpin r> fpin ; 37: zdepth ( -- u ) fdepth 2/ ; 38: zrot ( z1 z2 z3 -- z2 z3 z1 ) z>r zswap zr> zswap ; 39: z-rot ( z1 z2 z3 -- z3 z1 z2 ) zswap z>r zswap zr> ; 40: z@ ( zaddr -- z ) dup >r f@ r> float+ f@ ; 41: z! ( z zaddr -- ) dup >r float+ f! r> f! ; 42 43\ simple operations 02mar05py 44: z+ ( z1 z2 -- z1+z2 ) frot f+ f>l f+ fl> ; 45: z- ( z1 z2 -- z1-z2 ) fnegate frot f+ f>l f- fl> ; 46: zr- ( z1 z2 -- z2-z1 ) frot f- f>l fswap f- fl> ; 47: x+ ( z r -- z+r ) frot f+ fswap ; 48: x- ( z r -- z-r ) fnegate x+ ; 49: z* ( z1 z2 -- z1*z2 ) 50 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 ( z r -- z*r ) ftuck f* f>l f* fl> ; 53 54\ simple operations 02mar05py 55 56: znegate ( z -- -z ) fnegate fswap fnegate fswap ; 57: zconj ( rr ri -- rr -ri ) fnegate ; 58: z*i ( z -- z*i ) fnegate fswap ; 59: z/i ( z -- z/i ) fswap fnegate ; 60: zsqabs ( z -- |z|² ) fdup f* fswap fdup f* f+ ; 61: 1/z ( z -- 1/z ) zconj zdup zsqabs 1/f zscale ; 62: z/ ( z1 z2 -- z1/z2 ) 1/z z* ; 63: |z| ( z -- r ) zsqabs fsqrt ; 64: zabs ( z -- |z| ) |z| 0e ; 65: z2/ ( z -- z/2 ) f2/ f>l f2/ fl> ; 66: z2* ( z -- z*2 ) 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 ( z -- exp[z] ) fsincos fswap frot fexp zscale ; 74: pln ( z -- pln[z] ) zdup fswap fatan2 frot frot |z| fln fswap ; 75: zln ( z -- ln[z] ) >polar fswap fln fswap ; 76 77: z0= ( z -- flag ) f0= >r f0= r> and ; 78: zsqrt ( z -- sqrt[z] ) zdup z0= 0= IF 79 fdup f0= IF fdrop fsqrt 0e EXIT THEN 80 zln z2/ zexp THEN ; 81: z** ( z1 z2 -- z1**z2 ) zswap zln z* zexp ; 82\ Test: Fibonacci-Zahlen 831e 5e fsqrt f+ f2/ fconstant g 1e g f- fconstant -h 84: zfib ( z1 -- fib[z1] ) 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 ( z -- sinh[z] ) zexp zdup 1/z z- z2/ ; 91: zcosh ( z -- cosh[z] ) zexp zdup 1/z z+ z2/ ; 92: ztanh ( z -- tanh[z] ) z2* zexp zdup 1e 0e z- zswap 1e 0e z+ z/ ; 93 94: zsin ( z -- sin[z] ) z*i zsinh z/i ; 95: zcos ( z -- cos[z] ) z*i zcosh ; 96: ztan ( z -- tan[z] ) z*i ztanh z/i ; 97 98: Real ( z -- r ) fdrop ; 99: Imag ( z -- i ) fnip ; 100 101: Re ( z -- zr ) Real 0e ; 102: Im ( z -- zi ) Imag 0e ; 103 104\ complexe Operationen 02mar05py 105 106: zasinh ( z -- asinh[z] ) zdup 1e f+ zover 1e f- z* zsqrt z+ pln ; 107: zacosh ( z -- acosh[z] ) zdup 1e x- z2/ zsqrt zswap 1e x+ z2/ zsqrt z+ 108 pln z2* ; 109: zatanh ( z -- atanh[z] ) zdup 1e x+ zln zswap 1e x- znegate pln z- z2/ ; 110: zacoth ( z -- acoth[z] ) znegate zdup 1e x- pln zswap 1e x+ pln z- z2/ ; 111 112pi f2/ FConstant pi/2 113 114: zasin ( z -- -iln[iz+sqrt[1-z^~2]] ) z*i zasinh z/i ; 115: zacos ( z -- pi/2-asin[z] ) pi/2 0e zswap zasin z- ; 116: zatan ( z -- [ln[1+iz]-ln[1-iz]]/2i ) z*i zatanh z/i ; 117: zacot ( z -- [ln[[z+i]/[z-i]]/2i ) z*i zacoth z/i ; 118 119\ Ausgabe 24sep05py 120 121Defer fc. ' f. IS fc. 122: z. ( z -- ) 123 zdup z0= IF zdrop ." 0 " exit THEN 124 fdup f0= IF fdrop fc. exit THEN fswap 125 fdup f0= IF fdrop 126 ELSE fc. 127 fdup f0> IF ." +" THEN THEN 128 fc. ." i " ; 129: z.s ( z1 .. zn -- z1 .. zn ) 130 zdepth 0 ?DO i zpick zswap z>r z. zr> LOOP ; 131