[gforth] / gforth / complex.fs  

gforth: gforth/complex.fs

1 : anton 1.2 \ 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 :    
21 : pazsan 1.1 \ *** Complex arithmetic *** 23sep91py
22 :    
23 : pazsan 1.3 : complex' ( n -- offset ) 2* floats ;
24 :     : complex+ ( zaddr -- zaddr' ) float+ float+ ;
25 : pazsan 1.1
26 :     \ simple operations 02mar05py
27 :    
28 : pazsan 1.3 : fl> ( -- r ) f@local0 lp+ ;
29 : pazsan 1.1
30 : pazsan 1.3 : 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 ;
37 : pazsan 1.1 \ : zpin 2* 1+ >r r@ fpin r> fpin ;
38 : pazsan 1.3 : 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! ;
43 : pazsan 1.1
44 :     \ simple operations 02mar05py
45 : pazsan 1.3 : 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
52 : pazsan 1.1 f>l fswap fl> f* f>l f* fl> f- fl> fl> f+ ;
53 : pazsan 1.3 : zscale ( z r -- z*r ) ftuck f* f>l f* fl> ;
54 : pazsan 1.1
55 :     \ simple operations 02mar05py
56 :    
57 : pazsan 1.3 : 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> ;
68 : pazsan 1.1
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 :    
74 : pazsan 1.3 : 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 ;
77 : pazsan 1.1
78 : pazsan 1.3 : z0= ( z -- flag ) f0= >r f0= r> and ;
79 :     : zsqrt ( z -- sqrt[z] ) zdup z0= 0= IF
80 : pazsan 1.1 fdup f0= IF fdrop fsqrt 0e EXIT THEN
81 :     zln z2/ zexp THEN ;
82 : pazsan 1.3 : z** ( z1 z2 -- z1**z2 ) zswap zln z* zexp ;
83 : pazsan 1.1 \ Test: Fibonacci-Zahlen
84 :     1e 5e fsqrt f+ f2/ fconstant g 1e g f- fconstant -h
85 : pazsan 1.3 : zfib ( z1 -- fib[z1] ) zdup z>r g 0e zswap z**
86 : pazsan 1.1 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 :    
91 : pazsan 1.3 : 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 ;
98 : pazsan 1.1
99 : pazsan 1.3 : Real ( z -- r ) fdrop ;
100 :     : Imag ( z -- i ) fnip ;
101 : pazsan 1.1
102 : pazsan 1.3 : Re ( z -- zr ) Real 0e ;
103 :     : Im ( z -- zi ) Imag 0e ;
104 : pazsan 1.1
105 :     \ complexe Operationen 02mar05py
106 :    
107 : pazsan 1.3 : 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+
109 : pazsan 1.1 pln z2* ;
110 : pazsan 1.3 : 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/ ;
112 : pazsan 1.1
113 :     pi f2/ FConstant pi/2
114 :    
115 : pazsan 1.3 : 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 ;
119 : pazsan 1.1
120 :     \ Ausgabe 24sep05py
121 :    
122 :     Defer fc. ' f. IS fc.
123 : pazsan 1.3 : z. ( z -- )
124 :     zdup z0= IF zdrop ." 0 " exit THEN
125 : pazsan 1.1 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 " ;
130 : pazsan 1.3 : z.s ( z1 .. zn -- z1 .. zn )
131 :     zdepth 0 ?DO i zpick zswap z>r z. zr> LOOP ;
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help