//
// LiDIA - a library for computational number theory
// Copyright (c) 1995, 1996 by the LiDIA Group
//
// xdouble.c
// Copyright (c) 1995, 1996 by Keith Briggs 
//
// File        : xdouble.c
// Author      : Keith Briggs (KB)
// Last change : KB, Mar 31 1995, initial version (1.3)
//               TP, Oct  5 1995, ported to LiDIA
//               WB, Aug 09 1996, ported to LiDIA 
//		 MM, Oct 15 1996, added xdbl_long_abs() for CC.
//		 MM, Nov 14 1996, replaced rint(double) by lidia_rint(double).
//		     	          because rint(double) is not supported by CC
//				  on HP serie 300 / 400.
//                              
// C++ functions for xdouble (double+double) precision.
// Use with xdouble.h

#include <LiDIA/xdouble.h>


//
// xdbl_long_abs() replaces xdbl_long_abs(), because with CC,
// xdbl_long_abs() is only defined for int-parameter, but
// it is used with long-parameter in this code. 
//

static inline long xdbl_long_abs (long l)
 { return ( (l>0) ? l : (-l) ); }

//
// DOMAIN_ERROR=action to take on function domain errors
//
#ifdef NAN
#define DOMAIN_ERROR return(xdouble(NAN,0.0))
#else
#define DOMAIN_ERROR exit(1)
#endif

//
// Useful constants
//
const xdouble xdouble::Log2 = "0.6931471805599453094172321214581765680755";
const xdouble xdouble::Log10 = "2.302585092994045684017991454684364207601";
const xdouble xdouble::Pi = "3.1415926535897932384626433832795028841972";
const xdouble xdouble::TwoPi = "6.2831853071795864769252867665590057683943";
const xdouble xdouble::Pion2 = "1.5707963267948966192313216916397514420985";
const xdouble xdouble::Pion4 = "0.7853981633974483096156608458198757210493";


//
// number of decimal digits to which x and y agree
//
int digits(const xdouble & x, const xdouble & y)
{
  xdouble diff = fabs(x - y);
  if (dnorm(diff) == 0.0)
    return 32;
  long d = -long_xdbl(trunc(0.4 * log((diff / fabs(x)))));
  return d < 32 ? d : 32;
}

//
// define copysign if needed
//
#ifndef HAVE_COPYSIGN
inline double copysign(double x, double y)
{
  if (y >= 0.0)
    return fabs(x);
  else
    return -fabs(x);
}
#endif

inline xdouble copysign(const xdouble& x, const double y)
{
  if (y >= 0.0)
    return fabs(x);
  else
    return -fabs(x);
}

//
// String conversions
// xdouble -> string  (modified code of operatior <<)
// string -> xdouble  (previous atoq (compiler problems))
//
void xdouble_to_string(char *s, const xdouble& xd)
{
  char *p=s;
  if (xd.h() == 0.0)
    {
      sprintf(s,"0.0");
      return;
    }
  long Digits = 34;
  xdouble ten = 10.0, y = fabs(xd);
  double q = log10(y.h());
  long m, n = long (floor(q));
  if (n < 0)
    n++;
  xdouble l = powint(ten, n);
  y = y / l;
  if (sign(xd) < 0)
    *p++='-';
  long d = Digits > 34 ? 34 : Digits;
  d = d < 3 ? 3 : d;
  for (long i = 1; i <= d; i++)
    {
      if (i == 2)
	*p++='.';
      m = long (floor(y.h()));
      sprintf(p,"%ld",m);
      p++;
      y = (y - xdouble(m)) * ten;
      if (y.h() < 0.0)
	break;			// x must be an longeger

    }
  if (n != 0)
    {
      *p++='e';
      sprintf(p,"%ld",n);
    }
  else
    *p=0;
}

xdouble string_to_xdouble(const char *s)
{
  xdouble result = 0.0;
  long n, sign, ex = 0;
  /* eat whitespace */
  while (*s == ' ' || *s == '\t' || *s == '\n')
    s++;
  switch (*s)
    {				// get sign of mantissa

    case '-':
      {
	sign = -1;
	s++;
	break;
      }
    case '+':
      s++;			// no break

    default:
      sign = 1;
    }
  /* get digits before decimal polong */
  while (n = (*s++) - '0', n >= 0 && n < 10)
    result = 10.0 * result + n;
  s--;
  if (*s == '.')		/* get digits after decimal polong */
    {
      s++;
      while (n = (*s++) - '0', n >= 0 && n < 10)
	{
	  result = 10.0 * result + n;
	  --ex;
	}
      s--;
    }
  if (*s == 'e' || *s == 'E')	/* get exponent */
    {
      s++;
      ex = ex + atoi(s);
    }
  if (sign < 0)
    result = -result;
  /* exponent adjustment */
  while (ex-- > 0)
    result = 10.0 * result;
  while (++ex < 0)
    result = result / 10.0;
  return result;
}

//
// Debugging use
//
void xdouble::dump(char *s = "")
{
  cerr << s << "xdouble(" << hi << "," << lo << ")\n";
}

//
// Constructor from string
//
xdouble::xdouble(char *s)
{
  xdouble y;
  y = string_to_xdouble(s);
  hi = y.hi;
  lo = y.lo;
}

// 
// xdouble = string
//
xdouble& xdouble::operator = (char *s)
{
  xdouble y;
  y = string_to_xdouble(s);
  hi = y.hi;
  lo = y.lo;
  return *this;
}

// 
// input
// improved 95Mar3...
// replaced old code with modified bigfloat code (WB)
//
istream & operator >> (istream & in, xdouble & x)
{
  char s[1000];
  char *p = s;
  char c;
 
  do {
    in.get(c);
  } while (isspace(c));
  if ((c == '+') || (c == '-'))
    {
      *p++ = c;
      do {
        in.get(c);
      } while (isspace(c));
    }
  else
    {
      while (isspace(c))
        {
          in.get(c);
        }
    }
  
  if (!isdigit(c) && c != '.')
    lidia_error_handler("xdouble", "cin::digit/point expected");
  while (isdigit(c))
    {
      *p++ = c;
      in.get(c);
    }
   
  if (c == '.')
    {
      *p++ = c;
      in.get(c);
      while (isdigit(c))
        {
          *p++ = c;
          in.get(c);
        }
    }
  while (isspace(c) && c != '\n')
    {
      in.get(c);
    }

  if (c == 'E' || c == 'e')
    {
      *p++ = c;
      do {
        in.get(c);
      } while (isspace(c));
      if ((c == '+') || (c == '-'))
        {
          *p++ = c;
          do {
            in.get(c);
          } while (isspace(c));
        }
      if (!isdigit(c))
        lidia_error_handler("xdouble", "cin::digit expected");
      while (isdigit(c))
        {
          *p++ = c;
          in.get(c);
        }
    }
  in.putback(c);
  *p = '\0';
  x=string_to_xdouble(s);
  return in;
}

// 
// output
//
ostream & operator << (ostream & s, const xdouble & x)
{
  if (x.h() == 0.0)
    {
      s << " 0.0" << " ";
      return s;
    }
  long Digits = s.precision();
  xdouble ten = 10.0, y = fabs(x);
  double q = log10(y.h());
  long m, n = long (floor(q));
  if (n < 0)
    n++;
  xdouble l = powint(ten, n);
  y = y / l;
  if (sign(x) < 0)
    s << "-";
  else
    s << " ";
  long d = Digits > 34 ? 34 : Digits;
  d = d < 3 ? 3 : d;
  for (long i = 1; i <= d; i++)
    {
      if (i == 2)
	s << ".";
      m = long (floor(y.h()));
      s << m;
      y = (y - xdouble(m)) * ten;
      if (y.h() < 0.0)
	break;			// x must be an longeger

    }
  if (n != 0)
    s << "e" << n;
  else
    s << "";
  s << "";
  return s;
}

//
// ieee - Functions (Part I)
//

//
// rint (round to nearest int)
//
xdouble rint(const xdouble& x)
{ 
  return floor(x + xdouble(0.5)); 
}

 
//
// Floor.
// Greatest intgeger <= x
//
xdouble floor(const xdouble& x)
{
  double fh = floor(x.h()), fl = floor(x.l());
  xdouble t = (x.h() - fh) + (x.l() - fl);  // t={hi}+{lo}
  if (t < 1.0)
    return xdouble(fh, fl);
  else
    return xdouble(fh, fl) + 1.0;
}
 
//
// ceil.
// Least integer >= x
// ceil(x)=-floor(-x)
//
xdouble ceil(const xdouble& x)
{
  return (-floor(-x));
//  double fh = floor(-x.h()), fl = floor(-x.l());
//  xdouble t = (x.h() - fh) + (x.l() - fl);  // t={hi}+{lo}
//  if (t < 1.0)
//    return -xdouble(fh,fl) -1.0 ;
//  else
//    return -xdouble(fh,fl); // -1.0;
}

//
// trunc 
// round towards zero
//
xdouble trunc(const xdouble & x)
{
  if (x >= 0.0)
    return floor(x);
  else
    return -floor(-x);
}

//
// Modulo
//
xdouble fmod(const xdouble & x, const int n)
{
  return x - n * floor(x / n);
}

//
// Signum
//
int sign(const xdouble & x)
{
  if (x.h() > 0.0)
    return 1;
  else if (x.h() < 0.0)
    return -1;
  else
    return 0;
}

// 
// Comparison
//
bool operator > (const xdouble & x, const xdouble & y)
{
  return (x.h() > y.h()) || (x.h() == y.h() && x.l() > y.l());
}
bool operator >= (const xdouble & x, const xdouble & y)
{
  return (x.h() >= y.h()) || (x.h() == y.h() && x.l() >= y.l());
}
bool operator < (const xdouble & x, const xdouble & y)
{
  return (x.h() < y.h()) || (x.h() == y.h() && x.l() < y.l());
}
bool operator <= (const xdouble & x, const xdouble & y)
{
  return (x.h() <= y.h()) || (x.h() == y.h() && x.l() <= y.l());
}
bool operator == (const xdouble & x, const xdouble & y)
{return x.h() == y.h() && x.l() == y.l();
}
bool operator != (const xdouble & x, const xdouble & y)
{
  return x.h() != y.h() || x.l() != y.l();
}

#ifdef XDBL_NO_INLINE
#include <LiDIA/xdouble.inl>
#endif

//
// ieee - Functions (Part II)
//

//
// Square  (faster than x*x)
//
xdouble sqr(const xdouble & x)
{
  double hx, tx, C, c;
  C = Split * x.h();
  hx = C - x.h();
  hx = C - hx;
  tx = x.h() - hx;
  C = x.h() * x.h();
  c = ((((hx * hx - C) + 2.0 * hx * tx)) + tx * tx) + 2.0 * x.h() * x.l();
  hx = C + c;
  return xdouble(hx, c + double (C - hx));
}

//
// cube
//
xdouble cub(const xdouble & x)
{
  xdouble z = x * sqr(x);
  return z;
}

// 
// hypot - crude version.  Should be improved to avoid overflow!!
//
xdouble hypot(const xdouble & x, const xdouble & y)
{
  return sqrt(sqr(x) + sqr(y));
}

//
// square root
//
xdouble sqrt(const xdouble & y)
{
  double c, p, q, hx, tx, u, uu, cc, hi = y.h();
  if (hi < 0.0)
    {
      cerr << "\nxdouble: Attempt to take sqrt of " << hi << endl;
      DOMAIN_ERROR;
    }
  c = sqrt(hi);
  p = Split * c;
  hx = double (c - p);
  hx += p;
  tx = c - hx;
  p = hx * hx;
  q = 2.0 * hx * tx;
  u = p + q;
  uu = (p - u) + q + tx * tx;
  cc = (((y.h() - u) - uu) + y.l()) / (c + c);
  u = c + cc;
  return xdouble(u, cc + (c - u));
}

/*
xdouble sqrt(const xdouble& y) 
{ // Newton method for sqrt
  xdouble x, p, half=0.5;
  x = 1.0/sqrt(y.h());
  p = x*y;
  return p+half*(y-p*p)*x;
}
*/

//
// Exponential function
// See Bailey, MPFUN  ACM TOMS vol 19, Algorithm 719.
//
xdouble exp(const xdouble & t)
{
  long n = long (lidia_rint((t / xdouble::Log2).h()));	// minimizes |r|

  xdouble r = (t - n * xdouble::Log2) / 256;
  xdouble s = 1.0 + r;
  xdouble term = 0.5 * r * r;
  double f = 3.0;
  do
    {
      s = s + term;
      term = r * term / f;
      f++;
    } while (fabs(term.h() / s.h()) > 1.0e-35);
  s = sqr(s);
  s = sqr(s);
  s = sqr(s);
  s = sqr(s);
  s = sqr(s);
  s = sqr(s);
  s = sqr(s);
  s = sqr(s);
  r = s;
  for (long i = 1; i <= xdbl_long_abs(n); i++)
    s = s + s;
  if (n < 0)
    {
      r = r * r * recip(s);
      return r;
    }
  else
    return s;
}

//
// Natural logarithm
//
xdouble log(const xdouble & t)
{				// Newton method. See Bailey, MPFUN

  if (t.h() <= 0.0)
    {
      cerr << "Attempt to take xdouble::log(<=0), quitting!\n";
      DOMAIN_ERROR;
    }
  xdouble e, s(log(t.h()));	// s=double approx to result
  // e=exp(s); s=s+(t-e)/e;  // Newton step EXPERIMENT

  e = exp(s);
  return s + (t - e) / e;	// Newton step

}

//
// logarithm base 10
//
xdouble log10(const xdouble & t)
{
  const xdouble one_on_log10 = "0.4342944819032518276511289189166050822944";
  return one_on_log10 * log(t);
}

// 
// Reciprocal
//
xdouble recip(const xdouble & y)
{
  double hc, tc, hy, ty, C, c, U, u;
  C = 1.0 / y.h();
  c = Split * C;
  hc = c - C;
  u = Split * y.h();
  hc = c - hc;
  tc = C - hc;
  hy = u - y.h();
  U = C * y.h();
  hy = u - hy;
  ty = y.h() - hy;
  u = (((hc * hy - U) + hc * ty) + tc * hy) + tc * ty;
  c = ((((1.0 - U) - u)) - C * y.l()) / y.h();
  u = C + c;
  hy = double (C - u) + c;
  return xdouble(u, hy);
}

// 
// Like pow in math.h...
//
xdouble pow(const xdouble & a, const xdouble & b)
{
  return exp(b * log(a));
}

//
// xdouble^int
//
xdouble powint(const xdouble & u, const long c)
{
  switch (c)
    {
    case -2:
      return recip(u * u);
    case -1:
      return recip(u);
    case 0:
      return xdouble(1.0);		/* O^0 = NaN ?? */

    case 1:
      return u;
    case 2:
      return u * u;
    case 3:
      return u * u * u;
    default:
      {				// binary method

	long n = c, m;
	xdouble y(1.0), z = u;
	if (n < 0)
	  n = -n;
	do
	  {
	    m = n;
	    n = n / 2;
	    if (n + n != m)
	      {			// m odd

		y = z * y;
		if (n == 0)
		  {
		    if (c > 0)
		      return y;
		    else
		      return recip(y);
		  }
	      }
	    z = z * z;
	  } while (1);
      }
    }
}

//
//  Sin added 95Feb17
// Bailey's method.    See MPFUN notes.
//
xdouble sin(const xdouble & x)
{
  const xdouble tab[9] = {	// tab[b] := sin(b*Pi/16)...
    0.0,
    "0.1950903220161282678482848684770222409277",
    "0.3826834323650897717284599840303988667613",
    "0.5555702330196022247428308139485328743749",
    "0.7071067811865475244008443621048490392850",
    "0.8314696123025452370787883776179057567386",
    "0.9238795325112867561281831893967882868225",
    "0.9807852804032304491261822361342390369739",
    1.0
    };
  if (x == 0.0)
    return xdouble(0.0);
  // reduce x: -Pi < x <= Pi
  xdouble k1 = 0.5 * x / xdouble::Pi;
  xdouble k3 = k1 - rint(k1);
  // determine a and b to minimise |s|, where  s = x - a Pi/2 - b Pi/16
  xdouble t2 = 4.0 * k3;
  long a = long (lidia_rint(t2.h()));
  long b = long (lidia_rint((8.0 * (t2 - a)).h()));
  // if (abs(a)>2) { cerr << "Internal error in sin, a=" << a << endl; DOMAIN_ERROR;}
  // if (abs(b)>7) { cerr << "Internal error in sin, b=" << b << endl; DOMAIN_ERROR;}
  xdouble s = xdouble::Pi * (2.0 * k3 - (8.0 * a + b) / 16.0);
  // s is now reduced argument
  xdouble s2 = s * s, term = s, sum = term, fac = 6.0, k = 1.0;
  do
    {
      term = -term * s2 / fac;
      sum = sum + term;
      k = k + 1.0;
      fac = 2.0 * k * (2.0 * k + 1.0);
      // if (k>100) { cerr << "No convergence in sin !\n"; DOMAIN_ERROR;}
    } while (fabs(term.h()) > fabs(sum.h()) * 1.0e-35);	// is this test OK?

  xdouble sins = sum;
  xdouble coss = sqrt(1.0 - sins * sins);
  if (2.0 * fabs(s) > xdouble::Pi)
    coss = -coss;
  xdouble sina, cosa;
  sina = 0.0;
  if (a == 1)
    sina = 1.0;
  else if (a == -1)
    sina = -1.0;
  if (xdbl_long_abs(a) == 2)
    cosa = -1.0;
  else if (xdbl_long_abs(a) == 1)
    cosa = 0.0;
  else
    cosa = 1.0;
  xdouble sinb = tab[xdbl_long_abs(b)];
  if (b < 0)
    sinb = -sinb;
  xdouble cosb = tab[8 - xdbl_long_abs(b)];
  return sins * (cosa * cosb - sina * sinb) + coss * (sina * cosb + cosa * sinb);
}

//
// cos
//
xdouble cos(const xdouble & x)
{
  return sin(xdouble::Pion2 - x);
}

// 
// hyperbolic
//
xdouble sinh(const xdouble & x)
{
  xdouble t = exp(x);
  return 0.5 * (t - recip(t));
}

xdouble cosh(const xdouble & x)
{
  xdouble t = exp(x);
  return 0.5 * (t + recip(t));
}

//
// arctan
//
xdouble atan(const xdouble & x)
{
  if (x.h() == 0.0)
    return xdouble(0.0);
  xdouble s = x;
  long fac = 1;
//
// use identity to reduce argument...
//
  while (fabs(s) > 0.5)
    {
      s = s / (1.0 + sqrt(1.0 + s * s));
      fac = 2 * fac;
    }
  xdouble s2 = s * s, term = s, sum = s, k = 3.0;
  do {
    term = -term * s2;
    sum = sum + term / k;
    k = k + 2.0; 
    // if (k>100) { cerr << "No convergence in xdouble::atan !\n"; DOMAIN_ERROR;}
  } while (fabs(term.h()) > fabs(sum.h()) * 1.0e-35);
  return fac * sum;
}

//
// Better, but portability problems with __isnan, __isinf etc.
//
xdouble atan2(const xdouble & qy, const xdouble & qx)
{				// Based on GNU libc atan2.c

  static const double one = 1.0, zero = 0.0;
  double x, y;
  x = qx.h();
  y = qy.h();
  double signx, signy;
  if (x != x)
    return qx; /* x=NaN */

  if (y != y)
    return qy;
  signy = copysign(one, y);
  signx = copysign(one, x);
  if (y == zero)
    return signx == one ? qy : copysign(xdouble::Pi, signy);
  if (x == zero)
    return copysign(xdouble::Pion2, signy);
  /* __isinf not defined on landau...
     if (__isinf(x)) {
     if (__isinf(y)) return copysign(signx==one ? xdouble::Pion4 : 3.0*xdouble::Pion4, signy);
     else            return copysign(signx==one ? xdouble(0.0) : xdouble::Pi, signy);
     }
     if (__isinf(y)) return copysign(xdouble::Pion2, signy);
     */
  xdouble aqy = fabs(qy);
  if (x < 0.0)			// X is negative.

    return copysign(xdouble::Pi - atan(aqy / (-qx)), signy);
  return copysign(atan(aqy / qx), signy);
}

//
// arcsin
//
xdouble asin(const xdouble & x)
{
  if (fabs(x) > 1.0)
    {
      cerr << "|Argument|>1 in xdouble::asin!\n";
      DOMAIN_ERROR;
    }
  return atan2(x, sqrt(1.0 - x * x));
}

//
// end of xdouble.c
//
