(       Title:  Complex Word Set Tests
         File:  complex-test.fs
       Author:  David N. Williams
      Version:  0.9.6
      License:  LGPL
Last revision:  September 6, 2006
)
\ Copyright (C) 2002, 2003, 2005, 2006 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.

Unattributed changes are by David N. Williams.  The last
revision date above may reflect cosmetic changes not logged
here.

Version 0.9.6
 6Sep06 * Really changed names of mixed argument words, not
	  actually done in 0.9.5.
	* Removed tests for FPI, F0.0, F1.0,Z=0, Z=1, Z=I, which
	  were already commented out.

Version 0.9.5
24Apr05 * Changed names of mixed argument words to use jvn's
          more telegraphic style.  Also removed parentheses to
          get -I*.  Made adjustments for submission of
          complex.fs 0.8.3 to the FSL.
 3Sep05 * Fixed a typo discovered by Dirk Busch, namely, DEFINED
          should have been [DEFINED].  It didn't cause a problem
          on our system because both pfe and gforth have both
          words, one an alias for the other.

Version 0.9.4
 7Feb05 * Started moving tests with Inf, -Inf, and NaN,
          including all tests of ZBOX, to complex-ieee-test.fs,
          which was formerly named complex-szero-test.fs.
        * Renamed ->}}F as }}F, and left existing }}F unchanged.
          The latter cases now do an extra test for changes in
          data stack input, a fail-safe that hurts nothing.
 8Feb05 * Finished moving tests to complex-ieee-test.fs.
        * Removed tests Z=0, etc., which we no longer define in
          complex-kahan.fs or complex-ext.c.  Those constants
          were already unused in this code.
 4Mar05 * Changed ZACOS, ZASIN, ZATAN, and ZACOT tests to avoid
          the cuts.  The cuts are tested in
          complex-ieee-test.fs.

Version 0.9.3
12Jan05 * Reordered some tests and added FZ*, FZ/, ZF*, ZF/,
          IFZ*, IFZ/, ZIF*, ZIF/.
        * Added #ERRORS output, requiring ftester.fs 1.1.3 or
          above.
14Jan05 * Added ZBOX.
15Jan05 * Revised to test for sign-conserving ZBOX.

Version 0.9.2
 5Mar03 * Removed signed zero and branch cut tests.  Now
          they're in complex-szero-test.fs.

Version 0.9.1
21Feb03 * Added principal branch cut definitions and tests.
28Feb03 * Rearranged conditional includes.

Version 0.9.0
12Dec02 * Start.
18Feb03 * Release.

This code tests our modified version of Julian V. Noble's
complex arithmetic lexicon, and its port to pfe.

It is intended to test for formal correctness, not high
accuracy.

"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.
)

s" ftester.fs" included
true verbose !

0 [IF]
s" COMPLEX-EXT" environment? [IF] ( version) drop
true constant PRINCIPAL-ARG
cr
testing pfe complex words
[ELSE]
cr .( COMPLEX-EXT not available.) cr
[THEN]
[THEN]

1 [IF]
s" complex.fs" included  \ defines PRINCIPAL-ARG
cr
testing complex.fs
[THEN]

0 [IF]
s" complex-kahan.fs" included
true constant PRINCIPAL-ARG
cr
testing complex-kahan.fs
[THEN]

decimal

s" [UNDEFINED]" pad c! pad char+ pad c@ move 
pad find nip 0=
[IF]
: [UNDEFINED]  ( "name" -- flag )
  bl word find nip 0= ; immediate
[THEN]

s" [DEFINED]" pad c! pad char+ pad c@ move 
pad find nip 0=
[IF]
: [DEFINED]  postpone [UNDEFINED] 0= ; immediate
[THEN]

[UNDEFINED] \\ [IF]
  : \\   BEGIN  -1 parse  2drop  refill 0= UNTIL ; [THEN]


: near-defaults  ( -- )
  1E-14 abs-near f!
  1E-14 rel-near f! ;

 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

\ only two choices
PRINCIPAL-ARG [IF]
testing uses arg output with -pi < arg <= pi
  -3pi/4 fconstant 225arg
  -pi/2  fconstant 270arg
  -pi/4  fconstant 315arg
[ElSE]
testing uses arg output with 0 <= arg < 2pi
   5pi/4 fconstant 225arg
   3pi/2 fconstant 270arg
   7pi/4 fconstant 315arg
[THEN] cr

: f{{    f{ { ;
: }}f     -> } }f ;  \ error if data stack changes

defer gauge
defer func
defer inverse

\ ZVARIABLE, Z!, and Z@ have to be tested before the next 3
\ 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   f->   zatemp z@ func   -> ;

: ?2gauge  (f: z1 z2 -- )
(
Same as above with 2 complex arguments.
) 
  zbtemp z! zatemp z!
  zatemp z@ zbtemp z@ gauge f-> 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   f->   zatemp z@   -> ;

: -z   znegate ;


\ *** NONSTANDARD FP WORDS

testing  S>F F-ROT or -FROT FNIP FTUCK 1/F F^2 F2* F2/

set-exact 
f{{    0 s>f f->    0E }}f
f{{  137 s>f f->  137E }}f
f{{ -137 s>f f-> -137E }}f

[DEFINED] f-rot [IF]
f{{ 1E1 2E1 3E1 f-rot f-> 3E1 1E1 2E1 }}f
[THEN]
[DEFINED] -frot [IF]
f{{ 1E1 2E1 3E1 -frot f-> 3E1 1E1 2E1 }}f
[THEN]
f{{ 1E1 2E1     fnip  f-> 2E1         }}f
f{{ 1E1 2E1     ftuck f-> 2E1 1E1 2E1 }}f

f{{  2E 1/f f->  0.5E }}f
f{{ -2E 1/f f-> -0.5E }}f

f{{  0E f^2 f-> 0E }}f
f{{  2E f^2 f-> 4E }}f
f{{ -2E f^2 f-> 4E }}f

f{{     0E   f2* f->     0E }}f
f{{   128E   f2* f->   256E }}f
f{{ -12.8E   f2* f-> -25.6E }}f
set-near
f{{  1/rt2   f2* f->  rt2 }}f
f{{ -1/rt2   f2* f-> -rt2 }}f

set-exact
f{{     0E f2/ f->     0E   }}f
f{{   256E f2/ f->   128E   }}f
f{{ -25.6E f2/ f-> -12.8E   }}f
set-near
f{{  rt2   f2/ f->  1/rt2 }}f
f{{ -rt2   f2/ f-> -1/rt2 }}f

[DEFINED] copysign [IF]
testing  COPYSIGN

set-exact
f{{  11E   3E copysign f->  11E }}f
f{{  -7E   5E copysign f->   7E }}f
f{{   5E  -7E copysign f->  -5E }}f
f{{  -3E -11E copysign f->  -3E }}f
[THEN]


\ *** COMPLEX CONSTANTS AND VARIABLES

testing  ZCONSTANT ZVARIABLE Z@ Z!

set-exact
f{{ 1E 2E zconstant 1+i2 f->       }}f
f{{ 1+i2                 f-> 1E 2E }}f
f{{ : equ zconstant ;    f->       }}f
f{{ 1+i2 equ z=(1+i2)    f->       }}f
f{{ z=(1+i2)             f-> 1+i2  }}f

 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

f{{ zvariable zv1 f->      }}f
f{{ 1+i2 zv1 z!   f->      }}f
f{{ zv1 z@        f-> 1+i2 }}f


\ *** COMPLEX STACK MANIPULATION

testing  ZDROP ZDUP ZSWAP ZOVER ZNIP ZTUCK ZROT Z-ROT

set-exact
f{{ 0+i0      zdrop f->                }}f
f{{ 1+i0      zdup  f-> 1+i0 1+i0      }}f
f{{ 0+i0 1+i0 zswap f-> 1+i0 0+i0      }}f
f{{ 0+i0 1+i0 zover f-> 0+i0 1+i0 0+i0 }}f
f{{ 0+i0 1+i0 znip  f-> 1+i0           }}f
f{{ 0+i0 1+i0 ztuck f-> 1+i0 0+i0 1+i0 }}f
[DEFINED] zrot [IF]
f{{ 0+i0 1+i0 0+i1 zrot f-> 1+i0 0+i1 0+i0 }}f
[THEN]
[DEFINED] z-rot [IF]
f{{ 0+i0 1+i0 0+i1 z-rot f-> 0+i1 0+i0 1+i0 }}f
[THEN]


\ *** COMPLEX ALGEBRA

testing  REAL IMAG CONJG Z*F  Z/F Z* Z/ Z+ Z-

set-exact
f{{ 1+i0  real  f-> 1E }}f
f{{ 0+i1  imag  f-> 1E }}f
f{{ 1E 2E conjg f-> 1E -2E }}f

set-near  \ true also works in pfe
f{{ 1E 2E 3E    z*f f->  3E  6E }}f
f{{ 3E 6E 3E    z/f f->  1E  2E }}f
f{{ 1E 2E 3E 4E z*  f-> -5E 10E }}f
f{{ 1E 2E 1+i0  z*  f->  1E  2E }}f
f{{ 1E 2E 0+i1  z*  f-> -2E  1E }}f
f{{ 1E 1E 3E 4E z/  f->  7E 25E f/ -1E 25E f/ }}f
f{{ 1E 1E 4E 3E z/  f->  7E 25E f/  1E 25E f/ }}f
f{{ 1E 2E 3E 4E z+  f->  4E  6E }}f
f{{ 1E 2E 3E 4E z-  f-> -2E -2E }}f

testing  ZNEGATE Z2* Z2/ I* -I*

set-near  \ ignore signed zero
f{{  0+i0       -z    f->  0+i0 }}f
f{{  0+i0       z2*   f->  0+i0 }}f
f{{  0+i0       z2/   f->  0+i0 }}f
f{{  0+i0       i*    f->  0+i0 }}f
f{{  0+i0       -i*   f->  0+i0 }}f

set-exact
f{{   1E   -2E  -z    f->  -1E    2E  }}f
f{{  40E1 -20E1 z2*   f->  80E1 -40E1 }}f
f{{ -40E1  20E1 z2*   f-> -80E1  40E1 }}f
f{{  50E1 -30E1 z2/   f->  25E1 -15E1 }}f
f{{ -50E1  30E1 z2/   f-> -25E1  15E1 }}f
f{{  40E1 -20E1 i*    f->  20E1  40E1 }}f
f{{ -40E1  20E1 i*    f-> -20E1 -40E1 }}f
f{{  40E1 -20E1 -i*   f-> -20E1 -40E1 }}f
f{{ -40E1  20E1 -i*   f->  20E1  40E1 }}f


\ *** MINIMAL (MIXED) OPERATIONS

testing  X+ X- Y+ Y-

set-exact
f{{ 1E 2E 3E x+ f->  4E 2E }}f
f{{ 1E 2E 3E x- f-> -2E 2E }}f
f{{ 1E 2E 4E    y+     f->  1E  6E }}f
f{{ 1E 2E 4E    y-     f->  1E -2E }}f

[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-exact
f{{ 1E 2E 3E 4E z*>real f-> -5E }}f
f{{ 1E 2E 3E 4E z*>imag f-> 10E }}f
f{{ -1E  2E 3E z*f  f-> -1E  2E  3E 0E z* }}f
f{{ -3E -6E 3E z/f  f-> -3E -6E  3E 0E z/ }}f
f{{  3E  1E 2E f*z  f->  3E  0E  1E 2E z* }}f
set-near  \ pfe works with exact
f{{  3E  6E 3E f/z  f->  3E  0E  6E 3E  z/ }}f
set-exact
f{{ -1E  2E 3E  z*i*f f-> -1E  2E  0E 3E z* }}f
f{{ -3E -6E 3E -i*z/f f-> -3E -6E  0E 3E z/ }}f
f{{  3E  1E 2E  i*f*z f->  0E  3E  1E 2E z* }}f
f{{  3E  6E 3E  i*f/z f->  0E  3E  6E 3E z/ }}f
[THEN]


\ *** ALGEBRAIC FUNCTIONS

testing  |Z| |Z|^2 1/Z Z^2 Z^N

set-exact
f{{  0+i0   |z|   f-> 0E }}f
f{{  0+i0   |z|^2 f-> 0E }}f
f{{  0+i0   z^2   f-> 0+i0 }}f

set-near
f{{  3E  4E |z|   f->  5E }}f
f{{ -3E  4E |z|   f->  5E }}f
f{{  3E -4E |z|   f->  5E }}f
f{{  3E  4E |z|^2 f-> 25E }}f
f{{ -3E  4E |z|^2 f-> 25E }}f
f{{  3E -4E |z|^2 f-> 25E }}f
f{{  3E  4E 1/z   f->  3E  25E f/ -4E 25E f/ }}f
f{{ -3E  4E 1/z   f-> -3E  25E f/ -4E 25E f/ }}f
f{{  3E -4E 1/z   f-> -3E -25E f/  4E 25E f/ }}f
f{{  1+i0   1/z   f->  1+i0 }}f
f{{  3E  4E z^2   f-> -7E  24E }}f
f{{ -3E  4E z^2   f-> -7E -24E }}f
f{{  3E -4E z^2   f-> -7E -24E }}f
f{{ -3E -4E z^2   f-> -7E  24E }}f

set-exact
f{{  0+i0     0 z^n f->  1+i0 }}f
f{{  1+i0     0 z^n f->  1+i0 }}f
f{{ -1+i0     0 z^n f->  1+i0 }}f
f{{  0+i1     0 z^n f->  1+i0 }}f
f{{  0-i1     0 z^n f->  1+i0 }}f
f{{  rt2  rt2 0 z^n f->  1+i0 }}f
f{{  rt2 -rt2 0 z^n f->  1+i0 }}f
f{{ -rt2  rt2 0 z^n f->  1+i0 }}f
f{{ -rt2 -rt2 0 z^n f->  1+i0 }}f

f{{  0+i0     1 z^n f->  0+i0 }}f
f{{  1+i0     1 z^n f->  1+i0 }}f
f{{ -1+i0     1 z^n f-> -1+i0 }}f
f{{  0+i1     1 z^n f->  0+i1 }}f
f{{  0-i1     1 z^n f->  0-i1 }}f
f{{  rt2  rt2 1 z^n f->  rt2  rt2 }}f
f{{  rt2 -rt2 1 z^n f->  rt2 -rt2 }}f
f{{ -rt2  rt2 1 z^n f-> -rt2  rt2 }}f
f{{ -rt2 -rt2 1 z^n f-> -rt2 -rt2 }}f

f{{  0+i0     2 z^n f->  0+i0 }}f
f{{  1+i0     2 z^n f->  1+i0 }}f
f{{ -1+i0     2 z^n f->  1+i0 }}f
f{{  0+i1     2 z^n f-> -1+i0 }}f
set-near \ avoid signed zero discrepancy
f{{  0-i1     2 z^n f-> -1+i0 }}f
set-exact
f{{  3E  4E   2 z^n f-> -7E  24E }}f
f{{ -3E  4E   2 z^n f-> -7E -24E }}f
f{{  3E -4E   2 z^n f-> -7E -24E }}f
f{{ -3E -4E   2 z^n f-> -7E  24E }}f

f{{  0+i0     5 z^n f->  0+i0 }}f
f{{  1+i0     5 z^n f->  1+i0 }}f
f{{ -1+i0     5 z^n f-> -1+i0 }}f
f{{  0+i1     5 z^n f->  0+i1 }}f
f{{  0-i1     5 z^n f->  0-i1 }}f
f{{  2E  2E   5 z^n f-> -128E -128E }}f
f{{  2E -2E   5 z^n f-> -128E  128E }}f
f{{ -2E  2E   5 z^n f->  128E -128E }}f
f{{ -2E -2E   5 z^n f->  128E  128E }}f


\ *** ELEMENTARY FUNCTIONS

testing  ARG >POLAR POLAR> ZSQRT ZLN ZEXP Z^

set-exact
f{{  0+i0     arg f-> 0E     }}f
f{{  1+i0     arg f-> 0E     }}f
f{{  0+i1     arg f-> pi/2   }}f
f{{  0-i1     arg f-> 270arg }}f
f{{ -1+i0     arg f-> pi     }}f
set-near
f{{  2E  2E   arg f-> pi/4   }}f
f{{  3E -3E   arg f-> 315arg }}f
set-exact
f{{ -rt2  rt2 arg f-> 3pi/4  }}f
f{{ -rt2 -rt2 arg f-> 225arg }}f

rt2 f2*   fconstant 2rt2
rt2 3E f* fconstant 3rt2

set-exact
f{{  0+i0     >polar f-> 0+i0     }}f
f{{  1+i0     >polar f-> 1+i0     }}f
f{{  0+i1     >polar f-> 1E pi/2   }}f
f{{  0-i1     >polar f-> 1E 270arg }}f
f{{ -1+i0     >polar f-> 1E pi     }}f
set-near
f{{  2E   2E  >polar f-> 2rt2 pi/4   }}f
f{{  3E  -3E  >polar f-> 3rt2 315arg }}f
f{{ -rt2  rt2 >polar f-> 2E   3pi/4  }}f
f{{ -rt2 -rt2 >polar f-> 2E   225arg }}f

set-exact
f{{ 0+i0        polar> f->  0+i0 }}f
f{{ 1+i0        polar> f->  1+i0 }}f
set-near
f{{ 1E    pi/2  polar> f->  0+i1 }}f
f{{ 1E   -pi/2  polar> f->  0-i1 }}f
f{{ 1E    pi    polar> f-> -1+i0 }}f
f{{ 2rt2  pi/4  polar> f->  2E   2E  }}f
f{{ 3rt2 -pi/4  polar> f->  3E  -3E  }}f
f{{ 2E    3pi/4 polar> f-> -rt2  rt2 }}f
f{{ 2E   -3pi/4 polar> f-> -rt2 -rt2 }}f

: gsqrt  (f: z -- exp[[ln|z|+iarg[z]]/2] )
  zln z2/ zexp ; 

' zsqrt is func   ' gsqrt is gauge
set-near
f{{ 0+i0 zsqrt f-> 0+i0 }}f
f{{  2E   0E  ?gauge }}f
f{{ -2E   0E  ?gauge }}f
f{{  0E   2E  ?gauge }}f
f{{  0E  -2E  ?gauge }}f
f{{  rt2  rt2 ?gauge }}f
f{{  rt2 -rt2 ?gauge }}f
f{{ -rt2  rt2 ?gauge }}f
f{{ -rt2 -rt2 ?gauge }}f

set-exact
f{{  1+i0     zln f-> 0+i0      }}f
f{{  0+i1     zln f-> 0E pi/2   }}f
f{{  0-i1     zln f-> 0E 270arg }}f
f{{ -1+i0     zln f-> 0E pi     }}f
set-near
f{{ -2E   0E  zln f-> ln2 pi     }}f
f{{  rt2  rt2 zln f-> ln2 pi/4   }}f
f{{  rt2 -rt2 zln f-> ln2 315arg }}f
f{{ -rt2  rt2 zln f-> ln2 3pi/4  }}f
f{{ -rt2 -rt2 zln f-> ln2 225arg }}f

 1/rt2 f2/      fconstant  1/2rt2
 1/2rt2 fnegate fconstant -1/2rt2

set-exact
f{{  0+i0       zexp f->  1+i0 }}f
f{{  ln2  0E    zexp f->  2E   0E }}f
set-near
f{{ -ln2  0E    zexp f->  0.5E 0E }}f
f{{  0E   pi    zexp f-> -1+i0    }}f
f{{  0E   pi/2  zexp f->  0+i1    }}f
f{{  0E  -pi/2  zexp f->  0+i1 conjg     }}f
f{{  0E   pi/4  zexp f->  1/rt2   1/rt2  }}f
f{{  0E  -pi/4  zexp f->  1/rt2  -1/rt2  }}f
f{{  0E   3pi/4 zexp f-> -1/rt2   1/rt2  }}f
f{{  0E  -3pi/4 zexp f-> -1/rt2  -1/rt2  }}f
f{{  ln2  pi/4  zexp f->  rt2     rt2    }}f
f{{  ln2 -pi/4  zexp f->  rt2    -rt2    }}f
f{{ -ln2  3pi/4 zexp f-> -1/2rt2  1/2rt2 }}f
f{{ -ln2 -3pi/4 zexp f-> -1/2rt2 -1/2rt2 }}f

set-exact
\ f{{  0+i0     0+i0  z^ f->  0+i0 }}f
f{{  1+i0     0+i0  z^ f->  1+i0 }}f
f{{ -1+i0     0+i0  z^ f->  1+i0 }}f
f{{  0+i1     0+i0  z^ f->  1+i0 }}f
f{{  0-i1     0+i0  z^ f->  1+i0 }}f
f{{  rt2  rt2 0+i0  z^ f->  1+i0 }}f
f{{  rt2 -rt2 0+i0  z^ f->  1+i0 }}f
f{{ -rt2  rt2 0+i0  z^ f->  1+i0 }}f
f{{ -rt2 -rt2 0+i0  z^ f->  1+i0 }}f

: identical  (f: z -- z )  ;

: z^(z=1)   1+i0 z^ ;

' z^(z=1) is func   ' identical is gauge
set-near
\ f{{  0+i0     ?gauge }}f
f{{  1+i0     ?gauge }}f
f{{ -1+i0     ?gauge }}f
f{{  0+i1     ?gauge }}f
f{{  0-i1     ?gauge }}f
f{{  rt2  rt2 ?gauge }}f
f{{  rt2 -rt2 ?gauge }}f
f{{ -rt2  rt2 ?gauge }}f
f{{ -rt2 -rt2 ?gauge }}f

:noname  (f: z -- z^(1+i2)  1+i2 z^ ;          is func
:noname  (f: z -- z^(1+i2)  zln 1+i2 z* zexp ; is gauge
f{{  1+i0     ?gauge }}f
f{{ -1+i0     ?gauge }}f
f{{  0+i1     ?gauge }}f
f{{  0-i1     ?gauge }}f
f{{  rt2  rt2 ?gauge }}f
f{{  rt2 -rt2 ?gauge }}f
f{{ -rt2  rt2 ?gauge }}f
f{{ -rt2 -rt2 ?gauge }}f

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-exact
f{{  0+i0     zcosh f-> 1+i0 }}f
set-near
f{{  1+i0     zcosh f-> zch1 }}f
f{{ -1+i0     zcosh f-> zch1 }}f
f{{  0E  pi/2 zcosh f-> 0+i0 }}f
f{{  0E -pi/2 zcosh f-> 0+i0 }}f
f{{  1E  pi/4 zcosh f-> zC1  }}f
f{{  1E -pi/4 zcosh f-> zC2  }}f
f{{ -1E  pi/4 zcosh f-> zC2  }}f
f{{ -1E -pi/4 zcosh f-> zC1  }}f

set-exact
f{{  0+i0     zsinh f-> 0+i0 }}f
set-near
f{{  1+i0     zsinh f-> zsh1 }}f
f{{ -1+i0     zsinh f-> sh1 fnegate 0E }}f
f{{  0E  pi/2 zsinh f-> 0+i1 }}f
f{{  0E -pi/2 zsinh f-> 0+i1 conjg }}f
f{{  1E  pi/4 zsinh f-> zC3  }}f
f{{  1E -pi/4 zsinh f-> zC4  }}f
f{{ -1E  pi/4 zsinh f-> zC4 -z }}f
f{{ -1E -pi/4 zsinh f-> zC3 -z }}f

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-exact
f{{  0+i0     ztanh f-> 0+i0 }}f
set-near
f{{  1+i0     ztanh f-> zth1 }}f
f{{ -1+i0     ztanh f-> zth1 -z }}f
f{{  0E  pi/4 ztanh f-> 0+i1 }}f
f{{  0E -pi/4 ztanh f-> 0+i1 conjg }}f
f{{  1E  pi/4 ztanh f-> ztanhA }}f
f{{  1E -pi/4 ztanh f-> ztanhB }}f
f{{ -1E  pi/4 ztanh f-> ztanhB -z  }}f
f{{ -1E -pi/4 ztanh f-> ztanhA -z  }}f

set-near
f{{  1+i0     zcoth f-> zcth1 }}f
f{{ -1+i0     zcoth f-> zcth1 -z  }}f
f{{  0E  pi/4 zcoth f-> 0+i1 conjg }}f
f{{  0E -pi/4 zcoth f-> 0+i1 }}f
f{{  1E  pi/4 zcoth f-> zcothA }}f
f{{  1E -pi/4 zcoth f-> zcothB }}f
f{{ -1E  pi/4 zcoth f-> zcothB -z }}f
f{{ -1E -pi/4 zcoth f-> zcothA -z }}f

:noname  -i* zcos ; is func
' zcosh is gauge
set-exact
f{{  0+i0     ?gauge }}f
f{{  1+i0     ?gauge }}f
f{{ -1+i0     ?gauge }}f
f{{  0E  pi/2 ?gauge }}f
f{{  0E -pi/2 ?gauge }}f
f{{  1E  pi/4 ?gauge }}f
f{{  1E -pi/4 ?gauge }}f
f{{ -1E  pi/4 ?gauge }}f
f{{ -1E -pi/4 ?gauge }}f

:noname  i* zsin ;  is func
:noname  zsinh i* ; is gauge
set-near
f{{  0+i0     ?gauge }}f
f{{  1+i0     ?gauge }}f
f{{ -1+i0     ?gauge }}f
f{{  0E  pi/2 ?gauge }}f
f{{  0E -pi/2 ?gauge }}f
f{{  1E  pi/4 ?gauge }}f
f{{  1E -pi/4 ?gauge }}f
f{{ -1E  pi/4 ?gauge }}f
f{{ -1E -pi/4 ?gauge }}f

:noname  i* ztan ;  is func
:noname  ztanh i* ; is gauge
set-near
f{{  0+i0     ?gauge }}f
f{{  1+i0     ?gauge }}f
f{{ -1+i0     ?gauge }}f
f{{  0E  pi/4 ?gauge }}f
f{{  0E -pi/4 ?gauge }}f
f{{  1E  pi/4 ?gauge }}f
f{{  1E -pi/4 ?gauge }}f
f{{ -1E  pi/4 ?gauge }}f
f{{ -1E -pi/4 ?gauge }}f

:noname  i* zcot ;     is func
:noname  zcoth -i* ;   is gauge
set-near
f{{  1+i0     ?gauge }}f
f{{ -1+i0     ?gauge }}f
f{{  0E  pi/4 ?gauge }}f
f{{  0E -pi/4 ?gauge }}f
f{{  1E  pi/4 ?gauge }}f
f{{  1E -pi/4 ?gauge }}f
f{{ -1E  pi/4 ?gauge }}f
f{{ -1E -pi/4 ?gauge }}f


\ *** INVERSE FUNCTIONS

PRINCIPAL-ARG 0= [IF]
cr .( Skipping inverse function tests.  To do those,)
cr .(   set PRINCIPAL-ARG to true in complex.fs.)
cr

[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-near
f{{ 0+i0       ?inverse }}f
f{{ zsh1       ?inverse }}f
f{{ zsh1 -z    ?inverse }}f
f{{ 0+i1       ?inverse }}f
f{{ 0+i1 conjg ?inverse }}f
f{{ zC3        ?inverse }}f
f{{ zC4        ?inverse }}f
f{{ zC4 -z     ?inverse }}f
f{{ zC3 -z     ?inverse }}f

' zasinh is func   ' gasinh is gauge
set-near
f{{ 0+i0       ?gauge }}f
f{{ zsh1       ?gauge }}f
f{{ zsh1 -z    ?gauge }}f
f{{ 0+i1       ?gauge }}f
f{{ 0+i1 conjg ?gauge }}f
f{{ zC3        ?gauge }}f
f{{ zC4        ?gauge }}f
f{{ zC4 -z     ?gauge }}f
f{{ zC3 -z     ?gauge }}f

' gacosh is inverse   ' zcosh  is func
set-near
f{{ 1+i0 ?inverse }}f
f{{ zch1 ?inverse }}f
f{{ 0+i0 ?inverse }}f
f{{ zC1  ?inverse }}f
f{{ zC2  ?inverse }}f

' zacosh is func   ' gacosh is gauge   
set-near
f{{ 1+i0 ?gauge }}f
f{{ zch1 ?gauge }}f
f{{ 0+i0 ?gauge }}f
f{{ zC1  ?gauge }}f
f{{ zC2  ?gauge }}f

' gatanh is inverse   ' ztanh is func
set-near
f{{ 0+i0       ?inverse }}f
f{{ zth1       ?inverse }}f
f{{ zth1 -z    ?inverse }}f
f{{ 0+i1       ?inverse }}f
f{{ 0+i1 conjg ?inverse }}f
f{{ ztanhA     ?inverse }}f
f{{ ztanhB     ?inverse }}f
f{{ ztanhB -z  ?inverse }}f
f{{ ztanhA -z  ?inverse }}f

' zatanh is func   ' gatanh is gauge
set-near
f{{  0+i0       ?gauge }}f
f{{  0+i1       ?gauge }}f
f{{  1E  1E     ?gauge }}f
f{{  1E -1E     ?gauge }}f
f{{ -1E  1E     ?gauge }}f
f{{ -1E -1E     ?gauge }}f
f{{  0+i1 conjg ?gauge }}f
f{{ zth1        ?gauge }}f
f{{ zth1 -z     ?gauge }}f
f{{ ztanhA      ?gauge }}f
f{{ ztanhB      ?gauge }}f
f{{ ztanhB -z   ?gauge }}f
f{{ ztanhA -z   ?gauge }}f

' gacoth is inverse   ' zcoth is func
set-near
f{{ zcth1      ?inverse }}f
f{{ zcth1 -z   ?inverse }}f
f{{ 0+i1 conjg  ?inverse }}f
f{{ 0+i1        ?inverse }}f
f{{ zcothA     ?inverse }}f
f{{ zcothB     ?inverse }}f
f{{ zcothB -z  ?inverse }}f
f{{ zcothA -z  ?inverse }}f

[DEFINED] zacoth [IF]
' zacoth is func   ' gacoth is gauge
set-near
f{{ zcth1      ?gauge }}f
f{{ zcth1 -z   ?gauge }}f
f{{ 0+i1 conjg ?gauge }}f
f{{ 0+i1       ?gauge }}f
f{{ zcothA     ?gauge }}f
f{{ zcothB     ?gauge }}f
f{{ zcothB -z  ?gauge }}f
f{{ zcothA -z  ?gauge }}f
[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-near
f{{ zC1 ?inverse }}f
f{{ zC2 ?inverse }}f
f{{ zC3 ?inverse }}f
f{{ zC4 ?inverse }}f
f{{ zC1 gasin zsin f-> zC1 }}f
f{{ zC1 gatan ztan f-> zC1 }}f
f{{ zC1 gacot zcot f-> zC1 }}f

' zacos is func
' gacos is gauge
\ stay off the cut |x| >= 1
set-near
f{{  0E   0E    ?gauge }}f
f{{  pi/4  0E   ?gauge }}f
f{{ -pi/4  0E   ?gauge }}f
f{{  0E    pi/4 ?gauge }}f
f{{  0E   -pi/4 ?gauge }}f
f{{  0E    pi/2 ?gauge }}f
f{{  0E   -pi/2 ?gauge }}f
f{{  pi/2  pi/4 ?gauge }}f
f{{  pi/2 -pi/4 ?gauge }}f
f{{ -pi/2  pi/4 ?gauge }}f
f{{ -pi/2 -pi/4 ?gauge }}f

' zasin is func
' gasin is gauge
\ stay off the cut |x| >= 1
set-near
f{{  0E   0E    ?gauge }}f
f{{  pi/4  0E   ?gauge }}f
f{{ -pi/4  0E   ?gauge }}f
f{{  0E    pi/4 ?gauge }}f
f{{  0E   -pi/4 ?gauge }}f
f{{  0E    pi/2 ?gauge }}f
f{{  0E   -pi/2 ?gauge }}f
f{{  pi/2  pi/4 ?gauge }}f
f{{  pi/2 -pi/4 ?gauge }}f
f{{ -pi/2  pi/4 ?gauge }}f
f{{ -pi/2 -pi/4 ?gauge }}f

' zatan is func
' gatan is gauge
\ stay off the cut |y| >= 1
set-near
f{{  0E   0E    ?gauge }}f
f{{  pi/4  0E   ?gauge }}f
f{{ -pi/4  0E   ?gauge }}f
f{{  0E    pi/4 ?gauge }}f
f{{  0E   -pi/4 ?gauge }}f
f{{  pi/2  0E   ?gauge }}f
f{{ -pi/2  0E   ?gauge }}f
f{{  pi/2  pi/4 ?gauge }}f
f{{  pi/2 -pi/4 ?gauge }}f
f{{ -pi/2  pi/4 ?gauge }}f
f{{ -pi/2 -pi/4 ?gauge }}f

[DEFINED] zacot [IF]
' zacot is func
' gacot is gauge
\ stay off the cut |y| <= 1
set-near
f{{  pi/2  0E   ?gauge }}f
f{{ -pi/2  0E   ?gauge }}f
f{{  0E    pi/2 ?gauge }}f
f{{  0E   -pi/2 ?gauge }}f
f{{  pi    0E   ?gauge }}f
f{{ -pi    0E   ?gauge }}f
f{{  pi/4  pi/2 ?gauge }}f
f{{  pi/4 -pi/2 ?gauge }}f
f{{ -pi/4  pi/2 ?gauge }}f
f{{ -pi/4 -pi/2 ?gauge }}f
[THEN]

[THEN] \ inverse functions

.( #ERRORS: ) #errors @ . cr