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>