( Title: Complex Word Set Tests File: complex-test-xf.fs Author: David N. Williams Version: 1.0.3 License: LGPL Last revision: May 6, 2011 ) \ Copyright (C) 2002, 2003, 2005-2011 David N. Williams ( This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or at your option any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. This code tests our revisions of Julian V. Noble's complex arithmetic lexicon in complex.fs [FSL Algorithm #60] and complex-kahan.fs, and our C version of the latter, which implements pfe's COMPLEX-EXT module. It is known to work when floats are doubles or extended doubles, but has not been tested with singles. In fact the tolerances for fp comparisons used in this file are too small for singles. The code is intended to test for formal correctness, not high accuracy. It does not include any tests involving IEEE 754 floating-point values for signed zero, NaN, or infinity. A separate file for such tests, complex-ieee-test-xf.fs, may be found here: http://www.umich.edu/~williams/archive/forth/complex/ In particular, that file uses signed zero to compare values for complex elementary and inverse functions on their branch cuts to explicit formulas worked out from their OpenMath principal expressions. "Gauge functions" are functions that we test against. They are defined independently here, sometimes in terms of already tested functions. Except for DEFER and IS, this code is compatible with ANS Forth, with an environmental dependence on lower case. Unattributed changes are by David N. Williams. The last revision date above may reflect cosmetic changes not logged here. Version 1.0.3 9Dec10 * Revised library selection. * Added tests for: COMPLEX COMPLEXES COMPLEX+ * Added exception test for ZLITERAL. * Improved, conditional BITS/FLOAT. 24Dec10 * Made [ElSE] upper case. km 6May11 * Removed dangling [ELSE]. Version 1.0.2 3Nov10 * Started from complex-test 1.0.1, 14Aug09, revised to use ttester-xf 1.0.2. 17Nov10 * Made PRINCIPAL-ARG a value, to agree with complex.fs 1.0.2, and revised test logic accordingly. 25Nov10 * Updated for ttester-xf 1.2.0. Now uses tester-display. * Removed ttester comparisons. * Added: FMAX FT-MREL= SET-FT-EPSILONS SET-FT-MODE-MREL ) \ debugging [UNDEFINED] \\ [IF] : \\ ( -- ) -1 parse 2drop BEGIN refill 0= UNTIL ; [THEN] : .# ( n -- ) cr ." #" . cr ; 1 CONSTANT NOBLE 2 CONSTANT KAHAN 3 CONSTANT PFE \ USER-CONFIG: select complex library implementation NOBLE \ KAHAN \ PFE CONSTANT COMPLEX-TEST-LIB : NOBLE? ( -- flag ) COMPLEX-TEST-LIB NOBLE = ; : KAHAN? ( -- flag ) COMPLEX-TEST-LIB KAHAN = ; : PFE? ( -- flag ) COMPLEX-TEST-LIB PFE = ; NOBLE? [IF] ( The nonprincipal argument can be used only with complex.fs, and then only for arg, log, and nonintegral powers. Uncomment the line below to override the complex.fs default, and use the principal argument for those operations instead. ) s" complex.fs" included \ defines PRINCIPAL-ARG \ true to PRINCIPAL-ARG [THEN] KAHAN? [IF] s" complex-kahan.fs" included [THEN] PFE? [IF] \ only for pfe s" COMPLEX-EXT" environment? [IF] ( version) drop [ELSE] cr .( COMPLEX-EXT not available.) cr ABORT [THEN] [THEN] [UNDEFINED] PRINCIPAL-ARG [IF] true VALUE PRINCIPAL-ARG [THEN] s" ttester-xf.fs" INCLUDED true verbose ! decimal s" tester-display.fs" INCLUDED \ before first displayed line PFE-HOST IFORTH-HOST or [IF] ?.cr [THEN] [UNDEFINED] BITS/FLOAT [IF] :NONAME ( -- +n ) s" MAX-FLOAT" environment? 0= ABORT" ***can't determine MAX-FLOAT" pad 3 represent 0= ABORT" ***MAX-FLOAT invalid" \ shouldn't happen ( exp plus?) drop CASE 39 OF 32 ENDOF \ .340282347e+39 309 OF 64 ENDOF \ .17976931348623157e+309 4933 OF 80 ENDOF \ .118973149535723176505e+4933 ABORT" ***BITS/FLOAT must be 32, 64, or 80" ENDCASE ; EXECUTE CONSTANT BITS/FLOAT [THEN] PFE-HOST [IF] ?." Host is pfe, " \ 0 REDEFINED-MSG ! [THEN] GFORTH-HOST [IF] ?." Host is gforth, " \ 0 WARNINGS ! [THEN] IFORTH-HOST [IF] ?." Host is iForth, " \ 0 WARNING ! [THEN] ?." floats are " BITS/FLOAT . ?." bits. BITS/FLOAT 80 = [IF] \ extended double 20.27 significant digits 1e-17 \ rel err 1e-17 \ abs err GFORTH-HOST [IF] 22 [ELSE] IFORTH-HOST [IF] 18 [ELSE] 21 [THEN] [THEN] set-precision [THEN] BITS/FLOAT 64 = [IF] \ double 16.95 significant digits 1e-15 \ rel err 1e-15 \ abs err GFORTH-HOST [IF] 18 [ELSE] 17 [THEN] set-precision [THEN] \ untested BITS/FLOAT 32 = [IF] \ single 8.225 significant digits 1.5e-7 \ rel err 1.5e-7 \ abs err GFORTH-HOST [IF] 10 [ELSE] 9 [THEN] set-precision [THEN] FCONSTANT abs-err-default FCONSTANT rel-err-default : set-ft-epsilons ( -- ) abs-err-default FT-ABS-ERROR f! rel-err-default FT-REL-ERROR f! rel-err-default FT-AREL-ERROR f! ; set-ft-epsilons [UNDEFINED] F2DUP [IF] : F2DUP FOVER FOVER ; [THEN] : fmax ( f: r1 r2 -- max[|r1|,|r2|] ) fabs fswap fabs f2dup f< IF fswap THEN fdrop ; t{ -1e 2e fmax -> 2e }t t{ 1e 2e fmax -> 2e }t t{ 2e -1e fmax -> 2e }t t{ 2e 1e fmax -> 2e }t t{ -0e 0e fmax -> 0e }t t{ 0e -0e fmax -> 0e }t t{ -0e -0e fmax -> 0e }t : ft-mrel= ( f: m r -- s: flag ) ( Let eps1 and eps2 be the values of FT-ABS-ERROR and FT-REL-ERROR. Leave true if |m - r| < max [eps1, eps2 * |r|], else false. The "m" in the name stands for "moderated". ) fdup ft-rel-error f@ f* fabs ft-abs-error f@ fmax -frot f- fabs fswap f< ; : set-ft-mode-mrel ( -- ) ['] ft-mrel= ft-test=-xt ! ; set-ft-mode-mrel 0e ft-abs-error f! 1.001E 1E f- 1E f/ FCONSTANT TEST-REL-ERR \ from ttester-xf-test.fs TEST-REL-ERR ft-rel-error f! t{ 1e-15 -> 1.001e-15 }t t{ 1.0009999e-15 -> 1e-15 }t t{ 1.0009E10 1E10 ft-mrel= -> true }t t{ 1.0011E10 1E10 ft-mrel= -> false }t set-ft-epsilons \ ***BEGIN ERROR DISPLAY VARIABLE XT-#ERRORS 0 XT-#ERRORS ! : XT-ERROR1 ( c-addr u -- ) \ Display an error message followed by the line that had the \ error. red-text 1 XT-#ERRORS +! XT-ERROR-DEFAULT normal-text ; ' XT-ERROR1 XT-ERROR-XT ! : xt-a. ( &array c-addr u -- ) blue-text type ( &array) dup >r @ dup IF 1- r> cell+ swap cells over + DO i @ . -1 cells +LOOP ELSE r> 2drop ." none" THEN cr normal-text ; : XT-ERROR2 ( c-addr u -- ) XT-ERROR1 XT-RESULTS s" xresults: " xt-a. XT-GOALS s" xgoals: " xt-a. ; VARIABLE FT-#ERRORS 0 FT-#ERRORS ! : FT-ERROR1 ( c-addr u -- ) \ Display an error message followed by the line that had the \ error. red-text 1 FT-#ERRORS +! FT-ERROR-DEFAULT normal-text ; \ ' FT-ERROR1 FT-ERROR-XT ! : ft-a. ( &array c-addr u -- ) blue-text type ( &array) dup >r @ dup IF 1- r> cell+ faligned swap floats over + DO i f@ f. -1 floats +LOOP ELSE r> 2drop ." none" THEN cr normal-text ; : FT-ERROR2 ( c-addr u -- ) FT-ERROR1 FT-RESULTS s" fresults: " ft-a. FT-GOALS s" fgoals: " ft-a. ; ' FT-ERROR2 FT-ERROR-XT ! : ?.errors ( -- ) VERBOSE @ IF blue-text ." XT-ERRORS " normal-text XT-#ERRORS @ . blue-text ." FT-ERRORS " normal-text FT-#ERRORS @ . THEN ; \ ***END ERROR DISPLAY 0.7853981633974483096157E0 fconstant pi/4 -0.7853981633974483096157E0 fconstant -pi/4 0.5497787143782138167310E1 fconstant 7pi/4 [UNDEFINED] pi/2 [IF] 0.1570796326794896619231E1 fconstant pi/2 [THEN] -0.1570796326794896619231E1 fconstant -pi/2 0.4712388980384689857694E1 fconstant 3pi/2 0.2356194490192344928847E1 fconstant 3pi/4 -0.2356194490192344928847E1 fconstant -3pi/4 0.3926990816987241548078E1 fconstant 5pi/4 [UNDEFINED] pi [IF] 0.3141592653589793238463E1 fconstant pi [THEN] [UNDEFINED] -pi [IF] -0.3141592653589793238463E1 fconstant -pi [THEN] 0.2718281828459045235360E1 fconstant e -0.2718281828459045235360E1 fconstant -e 0.3678794411714423215955E0 fconstant 1/e -0.3678794411714423215955E0 fconstant -1/e [UNDEFINED] ln2 [IF] 0.6931471805599453094172E0 fconstant ln2 [THEN] -0.6931471805599453094172E0 fconstant -ln2 0.1414213562373095048802E1 fconstant rt2 -0.1414213562373095048802E1 fconstant -rt2 0.7071067811865475244008E0 fconstant 1/rt2 -0.7071067811865475244008E0 fconstant -1/rt2 :NONAME ( lib.case -- ) COMPLEX-TEST-LIB CASE NOBLE OF s" Testing complex.fs." ENDOF KAHAN OF s" Testing complex-kahan.fs." ENDOF PFE OF s" Testing pfe COMPLEX-EXT" ENDOF ABORT" ***No complex words loaded" ENDCASE ?type ; EXECUTE \ only two choices PRINCIPAL-ARG [IF] s" arg output -pi < arg <= pi" ?type -3pi/4 fconstant 225arg -pi/2 fconstant 270arg -pi/4 fconstant 315arg [ELSE] s" with arg output 0 <= arg < 2pi ?type 5pi/4 fconstant 225arg 3pi/2 fconstant 270arg 7pi/4 fconstant 315arg [THEN] ?.cr defer gauge defer func defer inverse \ ZVARIABLE, Z!, and Z@ have to be tested before the next \ words are used. zvariable zatemp zvariable zbtemp : ?gauge ( f: z -- ) ( Compare the functions whose xt's are in FUNC and GAUGE. ) zdup zatemp z! gauge -> zatemp z@ func ; : ?2gauge ( f: z1 z2 -- ) ( Same as above with 2 complex arguments. ) zbtemp z! zatemp z! zatemp z@ zbtemp z@ gauge -> zatemp z@ zbtemp z@ func ; : ?inverse ( f: z -- ) ( Check that INVERSE FUNCT, i.e., func[inverse], is the identity mapping. ) zdup zatemp z! inverse func -> zatemp z@ ; : -z znegate ; \ *** NONSTANDARD FP WORDS testing S>F -FROT FNIP FTUCK 1/F F^2 F2* F2/ set-ft-mode-exact t{ 0 s>f -> 0E }t t{ 137 s>f -> 137E }t t{ -137 s>f -> -137E }t t{ 1E1 2E1 3E1 -frot -> 3E1 1E1 2E1 }t t{ 1E1 2E1 fnip -> 2E1 }t t{ 1E1 2E1 ftuck -> 2E1 1E1 2E1 }t t{ 2E 1/f -> 0.5E }t t{ -2E 1/f -> -0.5E }t t{ 0E f^2 -> 0E }t t{ 2E f^2 -> 4E }t t{ -2E f^2 -> 4E }t t{ 0E f2* -> 0E }t t{ 128E f2* -> 256E }t t{ -12.8E f2* -> -25.6E }t set-ft-mode-mrel t{ 1/rt2 f2* -> rt2 }t t{ -1/rt2 f2* -> -rt2 }t set-ft-mode-exact t{ 0E f2/ -> 0E }t t{ 256E f2/ -> 128E }t t{ -25.6E f2/ -> -12.8E }t set-ft-mode-mrel t{ rt2 f2/ -> 1/rt2 }t t{ -rt2 f2/ -> -1/rt2 }t [DEFINED] copysign [IF] testing COPYSIGN set-ft-mode-exact t{ 11E 3E copysign -> 11E }t t{ -7E 5E copysign -> 7E }t t{ 5E -7E copysign -> -5E }t t{ -3E -11E copysign -> -3E }t [THEN] \ *** LOAD AND STORE testing ZCONSTANT ZVARIABLE ZLITERAL Z@ Z! set-ft-mode-exact t{ 1E 2E zconstant 1+i2 -> }t t{ 1+i2 -> 1E 2E }t t{ : equ zconstant ; -> }t t{ 1+i2 equ z=(1+i2) -> }t t{ z=(1+i2) -> 1+i2 }t 0E 0E zconstant 0+i0 1E 0E zconstant 1+i0 -1E 0E zconstant -1+i0 0E 1E zconstant 0+i1 0E -1E zconstant 0-i1 t{ zvariable zv1 -> }t t{ 1+i2 zv1 z! -> }t t{ zv1 z@ -> 1+i2 }t : lit-1+i0 ( f: -- 1+i0 ) [ 1+i0 ] zliteral ; t{ lit-1+i0 -> 1+i0 }t PFE? 0= [IF] \ uncomment to see compile only exception: \ 1+i0 ZLITERAL t{ 1+i0 ' ZLITERAL CATCH zdrop -> -14 }t [ELSE] \ pfe version is noop when interpreting t{ 1+i0 ZLITERAL -> 1+i0 }t [THEN] testing COMPLEX COMPLEXES COMPLEX+ t{ COMPLEX -> 2 floats }t t{ 0 COMPLEXES -> 0 }t t{ 3 COMPLEXES -> COMPLEX 3 * }t t{ -1 COMPLEXES -> COMPLEX negate }t t{ 1 COMPLEX+ -> 1 COMPLEX + }t \ *** COMPLEX STACK MANIPULATION testing ZDROP ZDUP ZSWAP ZOVER ZNIP ZTUCK ZROT -ZROT set-ft-mode-exact t{ 0+i0 zdrop -> }t t{ 1+i0 zdup -> 1+i0 1+i0 }t t{ 0+i0 1+i0 zswap -> 1+i0 0+i0 }t t{ 0+i0 1+i0 zover -> 0+i0 1+i0 0+i0 }t t{ 0+i0 1+i0 znip -> 1+i0 }t t{ 0+i0 1+i0 ztuck -> 1+i0 0+i0 1+i0 }t t{ 0+i0 1+i0 0+i1 zrot -> 1+i0 0+i1 0+i0 }t t{ 0+i0 1+i0 0+i1 -zrot -> 0+i1 0+i0 1+i0 }t \ *** COMPLEX ALGEBRA testing REAL IMAG CONJG Z*F Z/F Z* Z/ Z+ Z- set-ft-mode-exact t{ 1+i0 real -> 1E }t t{ 0+i1 imag -> 1E }t t{ 1E 2E conjg -> 1E -2E }t set-ft-mode-mrel \ true also works in pfe t{ 1E 2E 3E z*f -> 3E 6E }t t{ 3E 6E 3E z/f -> 1E 2E }t t{ 1E 2E 3E 4E z* -> -5E 10E }t t{ 1E 2E 1+i0 z* -> 1E 2E }t t{ 1E 2E 0+i1 z* -> -2E 1E }t t{ 1E 1E 3E 4E z/ -> 7E 25E f/ -1E 25E f/ }t t{ 1E 1E 4E 3E z/ -> 7E 25E f/ 1E 25E f/ }t t{ 1E 2E 3E 4E z+ -> 4E 6E }t t{ 1E 2E 3E 4E z- -> -2E -2E }t testing ZNEGATE Z2* Z2/ I* -I* set-ft-mode-mrel \ ignore signed zero t{ 0+i0 -z -> 0+i0 }t t{ 0+i0 z2* -> 0+i0 }t t{ 0+i0 z2/ -> 0+i0 }t t{ 0+i0 i* -> 0+i0 }t t{ 0+i0 -i* -> 0+i0 }t set-ft-mode-exact t{ 1E -2E -z -> -1E 2E }t t{ 40E1 -20E1 z2* -> 80E1 -40E1 }t t{ -40E1 20E1 z2* -> -80E1 40E1 }t t{ 50E1 -30E1 z2/ -> 25E1 -15E1 }t t{ -50E1 30E1 z2/ -> -25E1 15E1 }t t{ 40E1 -20E1 i* -> 20E1 40E1 }t t{ -40E1 20E1 i* -> -20E1 -40E1 }t t{ 40E1 -20E1 -i* -> -20E1 -40E1 }t t{ -40E1 20E1 -i* -> 20E1 40E1 }t \ *** MINIMAL (MIXED) OPERATIONS testing X+ X- Y+ Y- set-ft-mode-exact t{ 1E 2E 3E x+ -> 4E 2E }t t{ 1E 2E 3E x- -> -2E 2E }t t{ 1E 2E 4E y+ -> 1E 6E }t t{ 1E 2E 4E y- -> 1E -2E }t [DEFINED] i*f/z [IF] testing Z*>REAL Z*>IMAG Z*F Z/F F*Z F/Z Z*I*F -I*Z/F I*FZ* I*F/Z set-ft-mode-exact t{ 1E 2E 3E 4E z*>real -> -5E }t t{ 1E 2E 3E 4E z*>imag -> 10E }t t{ -1E 2E 3E z*f -> -1E 2E 3E 0E z* }t t{ -3E -6E 3E z/f -> -3E -6E 3E 0E z/ }t t{ 3E 1E 2E f*z -> 3E 0E 1E 2E z* }t set-ft-mode-mrel \ pfe works with exact t{ 3E 6E 3E f/z -> 3E 0E 6E 3E z/ }t set-ft-mode-exact t{ -1E 2E 3E z*i*f -> -1E 2E 0E 3E z* }t t{ -3E -6E 3E -i*z/f -> -3E -6E 0E 3E z/ }t t{ 3E 1E 2E i*f*z -> 0E 3E 1E 2E z* }t t{ 3E 6E 3E i*f/z -> 0E 3E 6E 3E z/ }t [THEN] \ *** ALGEBRAIC FUNCTIONS testing |Z| |Z|^2 1/Z Z^2 Z^N set-ft-mode-exact t{ 0+i0 |z| -> 0E }t t{ 0+i0 |z|^2 -> 0E }t t{ 0+i0 z^2 -> 0+i0 }t set-ft-mode-mrel t{ 3E 4E |z| -> 5E }t t{ -3E 4E |z| -> 5E }t t{ 3E -4E |z| -> 5E }t t{ 3E 4E |z|^2 -> 25E }t t{ -3E 4E |z|^2 -> 25E }t t{ 3E -4E |z|^2 -> 25E }t t{ 3E 4E 1/z -> 3E 25E f/ -4E 25E f/ }t t{ -3E 4E 1/z -> -3E 25E f/ -4E 25E f/ }t t{ 3E -4E 1/z -> -3E -25E f/ 4E 25E f/ }t t{ 1+i0 1/z -> 1+i0 }t t{ 3E 4E z^2 -> -7E 24E }t t{ -3E 4E z^2 -> -7E -24E }t t{ 3E -4E z^2 -> -7E -24E }t t{ -3E -4E z^2 -> -7E 24E }t set-ft-mode-exact t{ 0+i0 0 z^n -> 1+i0 }t t{ 1+i0 0 z^n -> 1+i0 }t t{ -1+i0 0 z^n -> 1+i0 }t t{ 0+i1 0 z^n -> 1+i0 }t t{ 0-i1 0 z^n -> 1+i0 }t t{ rt2 rt2 0 z^n -> 1+i0 }t t{ rt2 -rt2 0 z^n -> 1+i0 }t t{ -rt2 rt2 0 z^n -> 1+i0 }t t{ -rt2 -rt2 0 z^n -> 1+i0 }t t{ 0+i0 1 z^n -> 0+i0 }t t{ 1+i0 1 z^n -> 1+i0 }t t{ -1+i0 1 z^n -> -1+i0 }t t{ 0+i1 1 z^n -> 0+i1 }t t{ 0-i1 1 z^n -> 0-i1 }t t{ rt2 rt2 1 z^n -> rt2 rt2 }t t{ rt2 -rt2 1 z^n -> rt2 -rt2 }t t{ -rt2 rt2 1 z^n -> -rt2 rt2 }t t{ -rt2 -rt2 1 z^n -> -rt2 -rt2 }t t{ 0+i0 2 z^n -> 0+i0 }t t{ 1+i0 2 z^n -> 1+i0 }t t{ -1+i0 2 z^n -> 1+i0 }t t{ 0+i1 2 z^n -> -1+i0 }t set-ft-mode-mrel \ avoid signed zero discrepancy t{ 0-i1 2 z^n -> -1+i0 }t set-ft-mode-exact t{ 3E 4E 2 z^n -> -7E 24E }t t{ -3E 4E 2 z^n -> -7E -24E }t t{ 3E -4E 2 z^n -> -7E -24E }t t{ -3E -4E 2 z^n -> -7E 24E }t t{ 0+i0 5 z^n -> 0+i0 }t t{ 1+i0 5 z^n -> 1+i0 }t t{ -1+i0 5 z^n -> -1+i0 }t t{ 0+i1 5 z^n -> 0+i1 }t t{ 0-i1 5 z^n -> 0-i1 }t t{ 2E 2E 5 z^n -> -128E -128E }t t{ 2E -2E 5 z^n -> -128E 128E }t t{ -2E 2E 5 z^n -> 128E -128E }t t{ -2E -2E 5 z^n -> 128E 128E }t \ *** ELEMENTARY FUNCTIONS testing ARG >POLAR POLAR> ZSQRT ZLN ZEXP Z^ set-ft-mode-exact t{ 0+i0 arg -> 0E }t t{ 1+i0 arg -> 0E }t t{ 0+i1 arg -> pi/2 }t t{ 0-i1 arg -> 270arg }t t{ -1+i0 arg -> pi }t set-ft-mode-mrel t{ 2E 2E arg -> pi/4 }t t{ 3E -3E arg -> 315arg }t set-ft-mode-exact t{ -rt2 rt2 arg -> 3pi/4 }t t{ -rt2 -rt2 arg -> 225arg }t rt2 f2* fconstant 2rt2 rt2 3E f* fconstant 3rt2 set-ft-mode-exact t{ 0+i0 >polar -> 0+i0 }t t{ 1+i0 >polar -> 1+i0 }t t{ 0+i1 >polar -> 1E pi/2 }t t{ 0-i1 >polar -> 1E 270arg }t t{ -1+i0 >polar -> 1E pi }t set-ft-mode-mrel t{ 2E 2E >polar -> 2rt2 pi/4 }t t{ 3E -3E >polar -> 3rt2 315arg }t t{ -rt2 rt2 >polar -> 2E 3pi/4 }t t{ -rt2 -rt2 >polar -> 2E 225arg }t set-ft-mode-exact t{ 0+i0 polar> -> 0+i0 }t t{ 1+i0 polar> -> 1+i0 }t set-ft-mode-mrel t{ 1E pi/2 polar> -> 0+i1 }t \ Re(f) = -6.123234E-17 t{ 1E -pi/2 polar> -> 0-i1 }t \ Re(f) = 6.123234E-17 t{ 1E pi polar> -> -1+i0 }t \ Im(f) = 1.224647E-16 t{ 2rt2 pi/4 polar> -> 2E 2E }t t{ 3rt2 -pi/4 polar> -> 3E -3E }t t{ 2E 3pi/4 polar> -> -rt2 rt2 }t t{ 2E -3pi/4 polar> -> -rt2 -rt2 }t : gsqrt ( f: z -- exp[[ln|z|+iarg[z]]/2] ) zln z2/ zexp ; ' zsqrt is func ' gsqrt is gauge set-ft-mode-mrel t{ 0+i0 zsqrt -> 0+i0 }t t{ 2E 0E ?gauge }t t{ -2E 0E ?gauge }t \ Re(g) = 8.659561E-17 t{ 0E 2E ?gauge }t t{ 0E -2E ?gauge }t t{ rt2 rt2 ?gauge }t t{ rt2 -rt2 ?gauge }t t{ -rt2 rt2 ?gauge }t t{ -rt2 -rt2 ?gauge }t set-ft-mode-exact t{ 1+i0 zln -> 0+i0 }t t{ 0+i1 zln -> 0E pi/2 }t t{ 0-i1 zln -> 0E 270arg }t t{ -1+i0 zln -> 0E pi }t set-ft-mode-mrel t{ -2E 0E zln -> ln2 pi }t t{ rt2 rt2 zln -> ln2 pi/4 }t t{ rt2 -rt2 zln -> ln2 315arg }t t{ -rt2 rt2 zln -> ln2 3pi/4 }t t{ -rt2 -rt2 zln -> ln2 225arg }t 1/rt2 f2/ fconstant 1/2rt2 1/2rt2 fnegate fconstant -1/2rt2 set-ft-mode-exact t{ 0+i0 zexp -> 1+i0 }t t{ ln2 0E zexp -> 2E 0E }t set-ft-mode-mrel t{ -ln2 0E zexp -> 0.5E 0E }t t{ 0E pi zexp -> -1+i0 }t \ Im(f) = 1.224647E-16 t{ 0E pi/2 zexp -> 0+i1 }t \ Re(f) = 6.123234E-17 t{ 0E -pi/2 zexp -> 0+i1 conjg }t \ Re(f) = 6.123234E-17 t{ 0E pi/4 zexp -> 1/rt2 1/rt2 }t t{ 0E -pi/4 zexp -> 1/rt2 -1/rt2 }t t{ 0E 3pi/4 zexp -> -1/rt2 1/rt2 }t t{ 0E -3pi/4 zexp -> -1/rt2 -1/rt2 }t t{ ln2 pi/4 zexp -> rt2 rt2 }t t{ ln2 -pi/4 zexp -> rt2 -rt2 }t t{ -ln2 3pi/4 zexp -> -1/2rt2 1/2rt2 }t t{ -ln2 -3pi/4 zexp -> -1/2rt2 -1/2rt2 }t set-ft-mode-exact t{ 1+i0 0+i0 z^ -> 1+i0 }t t{ -1+i0 0+i0 z^ -> 1+i0 }t t{ 0+i1 0+i0 z^ -> 1+i0 }t t{ 0-i1 0+i0 z^ -> 1+i0 }t t{ rt2 rt2 0+i0 z^ -> 1+i0 }t t{ rt2 -rt2 0+i0 z^ -> 1+i0 }t t{ -rt2 rt2 0+i0 z^ -> 1+i0 }t t{ -rt2 -rt2 0+i0 z^ -> 1+i0 }t : identical ( f: z -- z ) ; : z^(z=1) 1+i0 z^ ; ' z^(z=1) is func ' identical is gauge set-ft-mode-mrel t{ 1+i0 ?gauge }t t{ -1+i0 ?gauge }t \ Im(f) = 1.224647E-16 t{ 0+i1 ?gauge }t \ Re(f) = 6.123234E-17 t{ 0-i1 ?gauge }t \ Re(f) = 6.123234E-17 t{ rt2 rt2 ?gauge }t t{ rt2 -rt2 ?gauge }t t{ -rt2 rt2 ?gauge }t t{ -rt2 -rt2 ?gauge }t :noname ( f: z -- z^(1+i2) 1+i2 z^ ; is func :noname ( f: z -- z^(1+i2) zln 1+i2 z* zexp ; is gauge t{ 1+i0 ?gauge }t t{ -1+i0 ?gauge }t t{ 0+i1 ?gauge }t t{ 0-i1 ?gauge }t t{ rt2 rt2 ?gauge }t t{ rt2 -rt2 ?gauge }t \ pfe 1 t{ -rt2 rt2 ?gauge }t t{ -rt2 -rt2 ?gauge }t \ pfe 2 testing ZCOSH ZSINH ZTANH ZCOTH ZCOS ZSIN ZTAN ZCOT e 1/e f+ f2/ fconstant ch1 e 1/e f- f2/ fconstant sh1 ch1 0E zconstant zch1 sh1 0E zconstant zsh1 sh1 ch1 f/ fconstant th1 ch1 sh1 f/ fconstant cth1 th1 0E zconstant zth1 cth1 0E zconstant zcth1 ch1 sh1 rt2 z/f zconstant zC1 zC1 conjg zconstant zC2 sh1 ch1 rt2 z/f zconstant zC3 zC3 conjg zconstant zC4 set-ft-mode-exact t{ 0+i0 zcosh -> 1+i0 }t set-ft-mode-mrel t{ 1+i0 zcosh -> zch1 }t t{ -1+i0 zcosh -> zch1 }t t{ 0E pi/2 zcosh -> 0+i0 }t \ Re(f) = 6.123234E-17 t{ 0E -pi/2 zcosh -> 0+i0 }t \ Re(f) = 6.123234E-17 t{ 1E pi/4 zcosh -> zC1 }t t{ 1E -pi/4 zcosh -> zC2 }t t{ -1E pi/4 zcosh -> zC2 }t t{ -1E -pi/4 zcosh -> zC1 }t set-ft-mode-exact t{ 0+i0 zsinh -> 0+i0 }t set-ft-mode-mrel t{ 1+i0 zsinh -> zsh1 }t t{ -1+i0 zsinh -> sh1 fnegate 0E }t t{ 0E pi/2 zsinh -> 0+i1 }t t{ 0E -pi/2 zsinh -> 0+i1 conjg }t t{ 1E pi/4 zsinh -> zC3 }t t{ 1E -pi/4 zsinh -> zC4 }t t{ -1E pi/4 zsinh -> zC4 -z }t t{ -1E -pi/4 zsinh -> zC3 -z }t 1E pi/4 zdup zsinh zswap zcosh z/ zconstant ztanhA 1E -pi/4 zdup zsinh zswap zcosh z/ zconstant ztanhB ztanhA 1/z zconstant zcothA ztanhB 1/z zconstant zcothB set-ft-mode-exact t{ 0+i0 ztanh -> 0+i0 }t set-ft-mode-mrel t{ 1+i0 ztanh -> zth1 }t t{ -1+i0 ztanh -> zth1 -z }t t{ 0E pi/4 ztanh -> 0+i1 }t t{ 0E -pi/4 ztanh -> 0+i1 conjg }t t{ 1E pi/4 ztanh -> ztanhA }t t{ 1E -pi/4 ztanh -> ztanhB }t t{ -1E pi/4 ztanh -> ztanhB -z }t t{ -1E -pi/4 ztanh -> ztanhA -z }t set-ft-mode-mrel t{ 1+i0 zcoth -> zcth1 }t t{ -1+i0 zcoth -> zcth1 -z }t t{ 0E pi/4 zcoth -> 0+i1 conjg }t t{ 0E -pi/4 zcoth -> 0+i1 }t t{ 1E pi/4 zcoth -> zcothA }t t{ 1E -pi/4 zcoth -> zcothB }t t{ -1E pi/4 zcoth -> zcothB -z }t t{ -1E -pi/4 zcoth -> zcothA -z }t :noname -i* zcos ; is func ' zcosh is gauge set-ft-mode-exact t{ 0+i0 ?gauge }t t{ 1+i0 ?gauge }t t{ -1+i0 ?gauge }t t{ 0E pi/2 ?gauge }t t{ 0E -pi/2 ?gauge }t t{ 1E pi/4 ?gauge }t t{ 1E -pi/4 ?gauge }t t{ -1E pi/4 ?gauge }t t{ -1E -pi/4 ?gauge }t :noname i* zsin ; is func :noname zsinh i* ; is gauge set-ft-mode-mrel t{ 0+i0 ?gauge }t t{ 1+i0 ?gauge }t t{ -1+i0 ?gauge }t t{ 0E pi/2 ?gauge }t t{ 0E -pi/2 ?gauge }t t{ 1E pi/4 ?gauge }t t{ 1E -pi/4 ?gauge }t t{ -1E pi/4 ?gauge }t t{ -1E -pi/4 ?gauge }t :noname i* ztan ; is func :noname ztanh i* ; is gauge set-ft-mode-mrel t{ 0+i0 ?gauge }t t{ 1+i0 ?gauge }t t{ -1+i0 ?gauge }t t{ 0E pi/4 ?gauge }t t{ 0E -pi/4 ?gauge }t t{ 1E pi/4 ?gauge }t t{ 1E -pi/4 ?gauge }t t{ -1E pi/4 ?gauge }t t{ -1E -pi/4 ?gauge }t :noname i* zcot ; is func :noname zcoth -i* ; is gauge set-ft-mode-mrel t{ 1+i0 ?gauge }t t{ -1+i0 ?gauge }t t{ 0E pi/4 ?gauge }t t{ 0E -pi/4 ?gauge }t t{ 1E pi/4 ?gauge }t t{ 1E -pi/4 ?gauge }t t{ -1E pi/4 ?gauge }t t{ -1E -pi/4 ?gauge }t \ *** INVERSE FUNCTIONS true to PRINCIPAL-ARG [ELSE] testing ZASINH ZACOSH ZATANH ZACOTH \ Inverse hyperbolic gauges. Note that in the principal \ expressions for the gauges here, and in GACOS in the next \ section, it is important to use "1E x+" instead of "1+i0 z+" \ to preserve the sign of zero on the branch cuts. That is \ not tested in this file (see complex-ieee-test.fs). : gasinh ( z -- [ln[z+sqrt[z^2+1]]] ) zdup z^2 1E x+ zsqrt z+ zln ; : gacosh ( z -- 2ln[sqrt[[z+1]/2]+sqrt[[z-1]/2] ) zdup 1E x- z2/ zsqrt zswap 1E x+ z2/ zsqrt z+ zln z2* ; : gatanh ( z -- [ln[1+z]-ln[1-z]]/2 ) zdup 1E x+ zln zswap -z 1E x+ zln z- z2/ ; : gacoth ( z = [ln[-1-z]-ln[1-z]]/2 ) ( Use -1E 0E Z+ instead of 1+i0 Z- so -0 doesn't give the wrong value on the ZLN principal branch cut. ) -z zdup -1+i0 z+ zln zswap 1+i0 z+ zln z- z2/ ; \ Check that the gauges are inverses. The order func(inverse) \ used here, e.g., ZACOSH COSH in Forth reverse polish, should \ work for all branches of the inverse when func is meromorphic. ' gasinh is inverse ' zsinh is func set-ft-mode-mrel t{ 0+i0 ?inverse }t t{ zsh1 ?inverse }t t{ zsh1 -z ?inverse }t t{ 0+i1 ?inverse }t t{ 0+i1 conjg ?inverse }t t{ zC3 ?inverse }t t{ zC4 ?inverse }t t{ zC4 -z ?inverse }t t{ zC3 -z ?inverse }t ' zasinh is func ' gasinh is gauge set-ft-mode-mrel t{ 0+i0 ?gauge }t t{ zsh1 ?gauge }t t{ zsh1 -z ?gauge }t t{ 0+i1 ?gauge }t t{ 0+i1 conjg ?gauge }t t{ zC3 ?gauge }t t{ zC4 ?gauge }t t{ zC4 -z ?gauge }t t{ zC3 -z ?gauge }t ' gacosh is inverse ' zcosh is func set-ft-mode-mrel t{ 1+i0 ?inverse }t t{ zch1 ?inverse }t t{ 0+i0 ?inverse }t \ Re(f^-1 f) = 6.123234E-17, Im((f^-1 f) = 4.440892E-16 t{ zC1 ?inverse }t t{ zC2 ?inverse }t ' zacosh is func ' gacosh is gauge set-ft-mode-mrel t{ 1+i0 ?gauge }t t{ zch1 ?gauge }t t{ 0+i0 ?gauge }t \ Re(g) = 2.220446E-16 t{ zC1 ?gauge }t t{ zC2 ?gauge }t ' gatanh is inverse ' ztanh is func set-ft-mode-mrel t{ 0+i0 ?inverse }t t{ zth1 ?inverse }t t{ zth1 -z ?inverse }t t{ 0+i1 ?inverse }t t{ 0+i1 conjg ?inverse }t t{ ztanhA ?inverse }t t{ ztanhB ?inverse }t t{ ztanhB -z ?inverse }t t{ ztanhA -z ?inverse }t ' zatanh is func ' gatanh is gauge set-ft-mode-mrel t{ 0+i0 ?gauge }t t{ 0+i1 ?gauge }t t{ 1E 1E ?gauge }t t{ 1E -1E ?gauge }t t{ -1E 1E ?gauge }t t{ -1E -1E ?gauge }t t{ 0+i1 conjg ?gauge }t t{ zth1 ?gauge }t t{ zth1 -z ?gauge }t t{ ztanhA ?gauge }t t{ ztanhB ?gauge }t t{ ztanhB -z ?gauge }t t{ ztanhA -z ?gauge }t ' gacoth is inverse ' zcoth is func set-ft-mode-mrel t{ zcth1 ?inverse }t t{ zcth1 -z ?inverse }t t{ 0+i1 conjg ?inverse }t t{ 0+i1 ?inverse }t t{ zcothA ?inverse }t t{ zcothB ?inverse }t t{ zcothB -z ?inverse }t t{ zcothA -z ?inverse }t [DEFINED] zacoth [IF] ' zacoth is func ' gacoth is gauge set-ft-mode-mrel t{ zcth1 ?gauge }t t{ zcth1 -z ?gauge }t t{ 0+i1 conjg ?gauge }t t{ 0+i1 ?gauge }t t{ zcothA ?gauge }t t{ zcothB ?gauge }t t{ zcothB -z ?gauge }t t{ zcothA -z ?gauge }t [THEN] testing ZASIN ZACOS ZATAN ZACOT \ Inverse trigonometric gauges. GACOS is uncouth in the sense \ of Corless, Davenport, Jeffrey, and Watt, i.e., not related to \ the inverse hyperbolic counterpart by the naive identity. : gacos ( f: z -- -2iln[sqrt[[1+z]/2]+isqrt[[1-z]/2]] ) zdup 1E x+ z2/ zsqrt zswap -z 1E x+ z2/ zsqrt i* z+ zln z2* -i* ; : gasin i* gasinh -i* ; : gatan i* gatanh -i* ; : gacot -i* gacoth -i* ; \ We've checked that the inverse hyperbolic gauges are inverses, \ so where they're couthly related, it's sufficient to check one \ case of each inverse trigonometric gauge, where both input and \ output are full complex numbers. We checked by hand that zC1 \ works. ' gacos is inverse ' zcos is func set-ft-mode-mrel t{ zC1 ?inverse }t t{ zC2 ?inverse }t t{ zC3 ?inverse }t t{ zC4 ?inverse }t t{ zC1 gasin zsin -> zC1 }t t{ zC1 gatan ztan -> zC1 }t t{ zC1 gacot zcot -> zC1 }t ' zacos is func ' gacos is gauge \ stay off the cut |x| >= 1 set-ft-mode-mrel t{ 0E 0E ?gauge }t \ Im(g) = -4.440892E-16 t{ pi/4 0E ?gauge }t \ Im(g) = 2.220446E-16 t{ -pi/4 0E ?gauge }t \ Im(g) = 2.220446E-16 t{ 0E pi/4 ?gauge }t t{ 0E -pi/4 ?gauge }t t{ 0E pi/2 ?gauge }t t{ 0E -pi/2 ?gauge }t t{ pi/2 pi/4 ?gauge }t t{ pi/2 -pi/4 ?gauge }t t{ -pi/2 pi/4 ?gauge }t t{ -pi/2 -pi/4 ?gauge }t ' zasin is func ' gasin is gauge \ stay off the cut |x| >= 1 set-ft-mode-mrel t{ 0E 0E ?gauge }t t{ pi/4 0E ?gauge }t \ Im(g) = -1.348379E-17 t{ -pi/4 0E ?gauge }t \ Im(g) = -1.348379E-17 t{ 0E pi/4 ?gauge }t t{ 0E -pi/4 ?gauge }t t{ 0E pi/2 ?gauge }t t{ 0E -pi/2 ?gauge }t t{ pi/2 pi/4 ?gauge }t t{ pi/2 -pi/4 ?gauge }t t{ -pi/2 pi/4 ?gauge }t t{ -pi/2 -pi/4 ?gauge }t ' zatan is func ' gatan is gauge \ stay off the cut |y| >= 1 set-ft-mode-mrel t{ 0E 0E ?gauge }t t{ pi/4 0E ?gauge }t t{ -pi/4 0E ?gauge }t t{ 0E pi/4 ?gauge }t t{ 0E -pi/4 ?gauge }t t{ pi/2 0E ?gauge }t t{ -pi/2 0E ?gauge }t t{ pi/2 pi/4 ?gauge }t t{ pi/2 -pi/4 ?gauge }t t{ -pi/2 pi/4 ?gauge }t t{ -pi/2 -pi/4 ?gauge }t [DEFINED] zacot [IF] ' zacot is func ' gacot is gauge \ stay off the cut |y| <= 1 set-ft-mode-mrel t{ pi/2 0E ?gauge }t t{ -pi/2 0E ?gauge }t t{ 0E pi/2 ?gauge }t t{ 0E -pi/2 ?gauge }t t{ pi 0E ?gauge }t t{ -pi 0E ?gauge }t t{ pi/4 pi/2 ?gauge }t t{ pi/4 -pi/2 ?gauge }t t{ -pi/4 pi/2 ?gauge }t t{ -pi/4 -pi/2 ?gauge }t [THEN] [THEN] \ inverse functions ?.errors GFORTH-HOST [IF] ?.cr [THEN]