//! @file rts-math.c
//! @author J. Marcel van der Veer
//
//! @section Copyright
//
// This file is part of VIF - vintage FORTRAN compiler.
// Copyright 2020-2025 J. Marcel van der Veer <algol68g@xs4all.nl>.
//
//! @section License
//
// This program is free software; you can redistribute it and/or modify it 
// under the terms of the GNU General Public License as published by the 
// Free Software Foundation; either version 3 of the License, or 
// (at your option) any later version.
//
// This program 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 General Public License for 
// more details. You should have received a copy of the GNU General Public 
// License along with this program. If not, see <http://www.gnu.org/licenses/>.

//! @section Synopsis
//!
//! Runtime support for math operations.

#include <vif.h>

// INTEGER*4

int_4 _up_int_4 (int_4 m, int_4 n)
{
// Special cases.
  if (m == 2 && n >= 0) {
    return 1 << n;
  } else if (m == 1) {
    return m;
  } else if (m == -1) {
    return (n % 2 == 0 ? 1 : -1);
  } else if (m == 0) {
    return (n == 0 ? 1 : 0);
  } else if (n < 0) {
    return 0;
  }
// General case.
  unsigned bit = 1;
  int_4 M = m, P = 1;
  do {
    if (n & bit) {
      P *= M;
    }
    bit <<= 1;
    if ((int_4) bit <= n) {
      M *= M;
    }
  } while ((int_4) bit <= n);
  return P;
}

// INTEGER*8

int_8 _up_int_8 (int_8 m, int_4 n)
{
// Special cases.
  if (m == 2 && n >= 0) {
    int_8 s = 1;
    s <<= n;
    return s;
  } else if (m == 1) {
    return m;
  } else if (m == -1) {
    return (n % 2 == 0 ? 1 : -1);
  } else if (m == 0) {
    return (n == 0 ? 1 : 0);
  } else if (n < 0) {
    return 0;
  }
// General case.
  unsigned bit = 1;
  int_8 M = m, P = 1;
  do {
    if (n & bit) {
      P *= M;
    }
    bit <<= 1;
    if ((int_4) bit <= n) {
      M *= M;
    }
  } while ((int_4) bit <= n);
  return P;
}

// REAL*4

real_4 _up_real_4 (real_4 x, int_4 n)
{
// Only positive n.
  if (n < 0) {
    return 1 / _up_real_4 (x, -n);
  }
// Special cases.
  if (x == 0 || x == 1) {
    return x;
  } else if (x == -1) {
    return (n % 2 == 0 ? 1 : -1);
  }
// General case.
  unsigned bit = 1;
  real_4 M = x, P = 1;
  do {
    if (n & bit) {
      P *= M;
    }
    bit <<= 1;
    if ((int_4) bit <= n) {
      M *= M;
    }
  } while ((int_4) bit <= n);
  return P;
}

real_4 cotanf (real_4 x)
{
  return 1.0 / tanf (x);
}

real_4 acotanf (real_4 x)
{
  return atanf (1 / x);
}

// REAL*8

real_8 _up_real_8 (real_8 x, int_4 n)
{
// Only positive n.
  if (n < 0) {
    return 1 / _up_real_8 (x, -n);
  }
// Special cases.
  if (x == 0 || x == 1) {
    return x;
  } else if (x == -1) {
    return (n % 2 == 0 ? 1 : -1);
  }
// General case.
  unsigned bit = 1;
  real_8 M = x, P = 1;
  do {
    if (n & bit) {
      P *= M;
    }
    bit <<= 1;
    if ((int_4) bit <= n) {
      M *= M;
    }
  } while ((int_4) bit <= n);
  return P;
}

real_8 cotan (real_8 x)
{
  return 1.0 / tan (x);
}

real_8 acotan (real_8 x)
{
  return atan (1 / x);
}

real_8 _vif_inverfc (real_8 y)
{
#define N_c_inverfc 34

  static const real_8 c_inverfc[N_c_inverfc] = {
    0.91646139826896400000,
    0.48882664027310800000,
    0.23172920032340500000,
    0.12461045461371200000,
    -0.07288467655856750000,
    0.26999930867002900000,
    0.15068904736022300000,
    0.11606502534161400000,
    0.49999930343979000000,
    3.97886080735226000000,
    0.00112648096188977922,
    1.05739299623423047e-4,
    0.00351287146129100025,
    7.71708358954120939e-4,
    0.00685649426074558612,
    0.00339721910367775861,
    0.01127491693325048700,
    0.01185981170477711040,
    0.01429619886978980180,
    0.03464942077890999220,
    0.00220995927012179067,
    0.07434243572417848610,
    0.10587217794159548800,
    0.01472979383314851210,
    0.31684763852013594400,
    0.71365763586873036400,
    1.05375024970847138000,
    1.21448730779995237000,
    1.16374581931560831000,
    0.95646497474479900600,
    0.68626594827409781600,
    0.43439749233143011500,
    0.24404451059319093500,
    0.12078223763524522200
  };

  if (y < 0 || y > 2) {
    errno = ERANGE;
    return 0;
  }
  if (y == 0) {
    return DBL_MAX;
  } else if (y == 1) {
    return 0;
  } else if (y == 2) {
    return -DBL_MAX;
  } else {
// Next is based on code that originally contained following statement:
//   Copyright (c) 1996 Takuya Ooura. You may use, copy, modify this 
//   code for any purpose and without fee.
    real_8 s, t, u, v, x, z;
    z = (y <= 1 ? y : 2 - y);
    v = c_inverfc[0] - ln (z);
    u = sqrt (v);
    s = (ln (u) + c_inverfc[1]) / v;
    t = 1 / (u + c_inverfc[2]);
    x = u *(1 - s *(s *c_inverfc[3] + 0.5)) - ((((c_inverfc[4] *t + c_inverfc[5]) *t + c_inverfc[6]) *t + c_inverfc[7]) *t + c_inverfc[8]) *t;
    t = c_inverfc[9] / (x + c_inverfc[9]);
    u = t - 0.5;
    s = (((((((((c_inverfc[10] *u + c_inverfc[11]) *u - c_inverfc[12]) *u - c_inverfc[13]) *u + c_inverfc[14]) *u + c_inverfc[15]) *u - c_inverfc[16]) *u - c_inverfc[17]) *u + c_inverfc[18]) *u + c_inverfc[19]) *u + c_inverfc[20];
    s = ((((((((((((s *u - c_inverfc[21]) *u - c_inverfc[22]) *u + c_inverfc[23]) *u + c_inverfc[24]) *u + c_inverfc[25]) *u + c_inverfc[26]) *u + c_inverfc[27]) *u + c_inverfc[28]) *u + c_inverfc[29]) *u + c_inverfc[30]) *u + c_inverfc[31]) *u + c_inverfc[32]) *t - z *exp (x *x - c_inverfc[33]);
    x += s *(x *s + 1);
    return (y <= 1 ? x : -x);
  }
}

real_8 _vif_inverf (real_8 y)
{
  return _vif_inverfc (1 - y);
}

void _merfi (real_8 *p, real_8 *x, int_4 *err)
{
  (*x) = _vif_inverf (*p);
  (*err) = errno;
}

// REAL*16

real_16 _qext (real_8 x)
{
/*
  NEW_RECORD (str);
  _srecordf (str, "%.*le", DBL_DIG, x);
  return _strtoquad (str, NO_REF_TEXT);
*/
  return (real_16) x;
}

real_16 _qmod (real_16 x, real_16 y)
{
  real_16 q;
  if ((q = x / y) >= 0) {
    q = floorq (q);
  } else {
    q = -floorq (-q);
  }
  return (x - y *q);
}

real_16 _up_real_16 (real_16 x, int_4 n)
{
// Only positive n.
  if (n < 0) {
    return 1.0q / _up_real_16 (x, -n);
  }
// Special cases.
  if (x == 0.0q || x == 1.0q) {
    return x;
  } else if (x == -1.0q) {
    return (n % 2 == 0 ? 1.0q : -1.0q);
  }
// General case.
  unsigned bit = 1;
  real_16 M = x, P = 1.0q;
  do {
    if (n & bit) {
      P *= M;
    }
    bit <<= 1;
    if ((int_4) bit <= n) {
      M *= M;
    }
  } while ((int_4) bit <= n);
  return P;
}

real_16 cotanq (real_16 x)
{
  return 1.0q / tanq (x);
}

real_16 acotanq (real_16 x)
{
  return atanq (1 / x);
}

// COMPLEX*8

complex_8 _cmplxd (complex_16 z)
{
  return CMPLXF ((real_4) creal (z), (real_4) cimag (z));
}

complex_8 _up_complex_8 (complex_8 x, int_4 n)
{
// Only positive n.
  if (n < 0) {
    return 1 / _up_complex (x, -n);
  }
// General case.
  unsigned bit = 1;
  complex_8 M = x, P = 1;
  do {
    if (n & bit) {
      P *= M;
    }
    bit <<= 1;
    if ((int_4) bit <= n) {
      M *= M;
    }
  } while ((int_4) bit <= n);
  return P;
}

// COMPLEX*16

complex_16 _dcmplxq (complex_32 z)
{
  return CMPLX (crealq (z), cimagq (z));
}

complex_16 _up_complex (complex_16 x, int_4 n)
{
// Only positive n.
  if (n < 0) {
    return 1 / _up_complex (x, -n);
  }
// General case.
  unsigned bit = 1;
  complex_16 M = x, P = 1;
  do {
    if (n & bit) {
      P *= M;
    }
    bit <<= 1;
    if ((int_4) bit <= n) {
      M *= M;
    }
  } while ((int_4) bit <= n);
  return P;
}

// COMPLEX*32

complex_32 _qcmplxd (complex_16 z)
{
  return CMPLXQ (_qext (creal (z)), _qext (cimag (z)));
}

complex_32 _up_complex_32 (complex_32 x, int_4 n)
{
// Only positive n.
  if (n < 0) {
    return 1.0q / _up_complex_32 (x, -n);
  }
// General case.
  unsigned bit = 1;
  complex_32 M = x, P = 1.0q;
  do {
    if (n & bit) {
      P *= M;
    }
    bit <<= 1;
    if ((int_4) bit <= n) {
      M *= M;
    }
  } while ((int_4) bit <= n);
  return P;
}

real_4 _zabs_8 (real_4 re, real_4 im)
{
  return cabsf (CMPLXF (re, im));
}

real_8 _zabs_16 (real_8 re, real_8 im)
{
  return cabs (CMPLX (re, im));
}

real_16 _zabs_32 (real_16 re, real_16 im)
{
  return cabsq (CMPLXQ (re, im));
}

void _qhex (real_16 *u)
{
  unt_2 *p = (unt_2 *) u;
  fprintf (stdout, "{");
  for (int_4 i = 0; i <= FLT128_LEN; i++) {
    fprintf (stdout, "0x%04x", *(p++));
    if (i < FLT128_LEN) {
      fprintf (stdout, ", ");
    }
  }
  fprintf (stdout, "}\n");
}

void _xhex (real_32 *u)
{
  fprintf (stdout, "{");
  for (int_4 i = 0; i <= FLT256_LEN; i++) {
    fprintf (stdout, "0x%04x", u->value[i]);
    if (i < FLT256_LEN) {
      fprintf (stdout, ", ");
    }
  }
  fprintf (stdout, "}\n");
}

//

void _pi4 (real_4 * x)
{
  *x = (real_4) M_PI;
}

void _pi8 (real_8 * x)
{
  *x = M_PI;
}

void _pi16 (real_16 * x)
{
  *x = M_PIq;
}
