/*
 * intnum - implementation of tanhsinh- and Gauss-Legendre quadrature
 *
 * Copyright (C) 2013,2021 Christoph Zurnieden
 *
 * Calc is open software; you can redistribute it and/or modify it under
 * the terms of the version 2.1 of the GNU Lesser General Public License
 * as published by the Free Software Foundation.
 *
 * Calc 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.
 *
 * A copy of version 2.1 of the GNU Lesser General Public License is
 * distributed with calc under the filename COPYING-LGPL.  You should have
 * received a copy with calc; if not, write to Free Software Foundation, Inc.
 * 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
 */


static resource_debug_level;
resource_debug_level = config("resource_debug", 0);


read -once infinities;

static __CZ__tanhsinh_x;
static __CZ__tanhsinh_w;
static __CZ__tanhsinh_order;
static __CZ__tanhsinh_prec;

define quadtsdeletenodes()
{
    free(__CZ__tanhsinh_x);
    free(__CZ__tanhsinh_w);
    free(__CZ__tanhsinh_order);
    free(__CZ__tanhsinh_prec);
}

define quadtscomputenodes(order, expo, eps)
{
    local t cht sht chp sum k PI places;
    local h t0 x w;
    if (__CZ__tanhsinh_order == order && __CZ__tanhsinh_prec == eps)
        return 1;
    __CZ__tanhsinh_order = order;
    __CZ__tanhsinh_prec = eps;
    __CZ__tanhsinh_x = list();
    __CZ__tanhsinh_w = list();
    /* The tanhsinh algorithm needs a slightly higher precision than G-L */
    eps = epsilon(eps * 1e-2);
    places = highbit(1 + int (1 / epsilon())) +1;
    PI = pi();
    sum = 0;
    t0 = 2 ^ (-expo);
    h = 2 * t0;
    /*
     * The author wanted to use the mpmath trick here which was
     * advertised---and reasonably so!---to be faster. Didn't work out
     * so well with calc.
     * PI4 = PI/4;
     * expt0 = bround(exp(t0),places);
     * a = bround( PI4 * expt0,places);
     * b = bround(PI4 / expt0,places);
     * udelta = bround(exp(h),places);
     * urdelta = bround(1/udelta,places);
     */
    /* make use of x(-t) = -x(t), w(-t) = w(t)  */
    for (k = 0; k < 20 * order + 1; k++) {
        /*
         * x = tanh(pi/2 * sinh(t))
         * w = pi/2 * cosh(t) / cosh(pi/2 * sinh(t))^2
         */
        t = bround(t0 + k * h, places);

        cht = bround(cosh(t), places);
        sht = bround(sinh(t), places);
        chp = bround(cosh(0.5 * PI * sht), places);
        x = bround(tanh(0.5 * PI * sht), places);
        w = bround((PI * h * cht) / (2 * chp ^ 2), places);
        /*
         * c = bround(exp(a-b),places);
         * d = bround(1/c,places);
         * co =bround( (c+d)/2,places);
         * si =bround( (c-d)/2,places);
         * x = bround(si / co,places);
         * w = bround((a+b) / co^2,places);
         */
        if (abs(x - 1) <= eps)
            break;

        append(__CZ__tanhsinh_x, x);
        append(__CZ__tanhsinh_w, w);
        /*
         * a *= udelta;
         * b *= urdelta;
         */
    }

    /* Normalize the weights to make them add up to 2 (two) */
    /*
     * for(k=0;k < size(__CZ__tanhsinh_w);k++)
     * sum = bround(sum + __CZ__tanhsinh_w[k],places);
     * sum *= 2;
     * for(k=0;k < size(__CZ__tanhsinh_w);k++)
     * __CZ__tanhsinh_w[k] = bround(2.0 * __CZ__tanhsinh_w[k] / sum,places);
     */

    epsilon(eps);
    return 1;
}

define quadtscore(a, b, n)
{
    local k c d order eps places sum ret x x1 x2 xm w w1 w2 m sizel;

    eps = epsilon(epsilon() * 1e-2);
    places = highbit(1 + int (1 / epsilon())) +1;
    m = int (4 + max(0, ln(places / 30.0) / ln(2))) + 2;
    if (!isnull(n)) {
        order = n;
        m = ilog(order / 3, 2) + 1;
    } else
        order = 3 * 2 ^ (m - 1);

    quadtscomputenodes(order, m, epsilon());
    sizel = size(__CZ__tanhsinh_w);

    if (isinfinite(a) || isinfinite(b)) {
        /*
         *           x
         * t =  ------------
         *                2
         *      sqrt(1 - y )
         */
        if (isninf(a) && ispinf(b)) {
            for (k = 0; k < sizel; k++) {
                x1 = __CZ__tanhsinh_x[k];
                x2 = -__CZ__tanhsinh_x[k];
                w1 = __CZ__tanhsinh_w[k];

                x = bround(x1 * (1 - x1 ^ 2) ^ (-1 / 2), places);
                xm = bround(x2 * (1 - x2 ^ 2) ^ (-1 / 2), places);
                w = bround(w1 * (((1 - x1 ^ 2) ^ (-1 / 2)) / (1 - x1 ^ 2)),
                           places);
                w2 = bround(w1 * (((1 - x2 ^ 2) ^ (-1 / 2)) / (1 - x2 ^ 2)),
                            places);
                sum += bround(w * f(x), places);
                sum += bround(w2 * f(xm), places);
            }
        }
        /*
         *        1
         * t =  - - + b + 1
         *        x
         */
        else if (isninf(a) && !iscinf(b)) {
            for (k = 0; k < sizel; k++) {
                x1 = __CZ__tanhsinh_x[k];
                x2 = -__CZ__tanhsinh_x[k];
                w1 = __CZ__tanhsinh_w[k];

                x = bround((b + 1) - (2 / (x1 + 1)), places);
                xm = bround((b + 1) - (2 / (x2 + 1)), places);
                w = bround(w1 * (1 / 2 * (2 / (x1 + 1)) ^ 2), places);
                w2 = bround(w1 * (1 / 2 * (2 / (x2 + 1)) ^ 2), places);
                sum += bround(w * f(x), places);
                sum += bround(w2 * f(xm), places);
            }
        }
        /*
         *      1
         * t =  - + a - 1
         *      x
         */
        else if (!iscinf(a) && ispinf(b)) {
            for (k = 0; k < sizel; k++) {
                x1 = __CZ__tanhsinh_x[k];
                x2 = -__CZ__tanhsinh_x[k];
                w1 = __CZ__tanhsinh_w[k];
                x = bround((a - 1) + (2 / (x1 + 1)), places);
                xm = bround((a - 1) + (2 / (x2 + 1)), places);
                w = bround(w1 * (((1 / 2) * (2 / (x1 + 1)) ^ 2)), places);
                w2 = bround(w1 * (((1 / 2) * (2 / (x2 + 1)) ^ 2)), places);
                sum += bround(w * f(x), places);
                sum += bround(w2 * f(xm), places);
            }
        } else if (isninf(a) || isninf(b)) {
            /*TODO: swap(a,b) and negate(w)? Lookup! */
            return newerror("quadtscore: reverse limits?");
        } else {
            return
                newerror("quadtscore: complex infinity not yet implemented");
        }
        ret = sum;
    } else {
        /* Avoid rounding errors */
        if (a == -1 && b == 1) {
            c = 1;
            d = 0;
        } else {
            c = (b - a) / 2;
            d = (b + a) / 2;
        }
        sum = 0;
        for (k = 0; k < sizel; k++) {
            sum +=
                bround(__CZ__tanhsinh_w[k] * f(c * __CZ__tanhsinh_x[k] + d),
                       places);
            sum +=
                bround(__CZ__tanhsinh_w[k] * f(c * -__CZ__tanhsinh_x[k] + d),
                       places);
        }
        ret = c * sum;
    }
    epsilon(eps);
    return ret;
}

static __CZ__quadts_error;

define quadts(a, b, points)
{
    local k sp results epsbits nsect interval length segment slope C ;
    local x1 x2 y1 y2  sum D1 D2 D3 D4;
    if (param(0) < 2)
        return newerror("quadts: not enough arguments");
    epsbits = highbit(1 + int (1 / epsilon())) +1;
    if (param(0) < 3 || isnull(points)) {
        /* return as given */
        return quadtscore(a, b);
    } else {
        if ((isinfinite(a) || isinfinite(b))
            && (!ismat(points) && !islist(points)))
            return
                newerror(strcat
                         ("quadts: segments of infinite length ",
                          "are not yet supported"));
        if (ismat(points) || islist(points)) {
            sp = size(points);
            if (sp == 0)
                return
                    newerror(strcat
                             ("quadts: variable 'points` must be a list or ",
                              "1d-matrix of a length > 0"));
            /* check if all points are numbers */
            for (k = 0; k < sp; k++) {
                if (!isnum(points[k]))
                    return
                        newerror(strcat
                                 ("quadts: elements of 'points` must be",
                                  " numbers only"));
            }
            /* We have n-1 intervals and a and b, hence n-1 + 2 results */
            results = mat[sp + 1];
            if (a != points[0]) {
                results[0] = quadtscore(a, points[0]);
            } else {
                results[0] = 0;
            }
            if (sp == 1) {
                if (b != points[0]) {
                    results[1] = quadtscore(points[0], b);
                } else {
                    results[1] = 0;
                }
            } else {
                for (k = 1; k < sp; k++) {
                    results[k] = quadtscore(points[k - 1], points[k]);
                }
                if (b != points[k - 1]) {
                    results[k] = quadtscore(points[k - 1], b);
                } else {
                    results[k] = 0;
                }
            }
        } else {
            if (!isint(points) || points <= 0)
                return newerror(strcat("quadts: variable 'points` must be a ",
                                       "list or a positive integer"));
            /* Taking "points" as the number of equally spaced intervals */
            results = mat[points + 1];
            /* It is easy if a,b lie on the real line */
            if (isreal(a) && isreal(b)) {
                length = abs(a - b);
                segment = length / points;

                for (k = 1; k <= points; k++) {
                    results[k - 1] =
                        quadtscore(a + (k - 1) * segment, a + k * segment);
                }
            } else {
                /* We have at least one complex limit but treat "points" still
                 * as the number of equally spaced intervals on a straight line
                 * connecting a and b. Computing the segments here is a bit
                 * more complicated but not much, it should have been taught in
                 * high school.
                 * Other contours by way of a list of points */
                slope = (im(b) - im(a)) / (re(b) - re(a));
                C = (im(a) + slope) * re(a);
                length = abs(re(a) - re(b));
                segment = length / points;

                /* y = mx+C where m is the slope, x is the real part and y the
                 * imaginary part  */
                if(re(a)>re(b))swap(a,b);
                for (k = re(a); k <= (re(b)); k+=segment) {
                    x1 = slope*(k) +  C;
                    results[k] = quadtscore(k + x1 * 1i);
                }
            }                   /* else of isreal */
        }                       /* else of ismat|islist */
    }                           /* else of isnull(points) */
    /* With a bit of undeserved luck we have a result by now. */
    sp = size(results);
    for (k = 0; k < sp; k++) {
        sum += results[k];
    }
    return sum;
}

static __CZ__gl_x;
static __CZ__gl_w;
static __CZ__gl_order;
static __CZ__gl_prec;

define quadglcomputenodes(N)
{
    local places k l x w t1 t2 t3 t4 t5 r tmp;

    if (__CZ__gl_order == N && __CZ__gl_prec == epsilon())
        return;

    __CZ__gl_x = mat[N];
    __CZ__gl_w = mat[N];
    __CZ__gl_order = N;
    __CZ__gl_prec = epsilon();

    places = highbit(1 + int (1 / epsilon())) +1;

    /*
     * Compute roots and weights (doing it inline seems to be fastest)
     * Trick shamelessly stolen from D. Bailey et .al (program "arprec")
     */
    for (k = 1; k <= N//2; k++) {
        r = bround(cos(pi() * (k - .25) / (N + .5)), places);
        while (1) {
            t1 = 1, t2 = 0;
            for (l = 1; l <= N; l++) {
                t3 = t2;
                t2 = t1;
                t1 = bround(((2 * l - 1) * r * t2 - (l - 1) * t3) / l, places);
            }
            t4 = bround(N * (r * t1 - t2) / ((r ^ 2) - 1), places);
            t5 = r;
            tmp = t1 / t4;
            r = r - tmp;
            if (abs(tmp) <= epsilon())
                break;
        }
        x = r;
        w = bround(2 / ((1 - r ^ 2) * t4 ^ 2), places);

        __CZ__gl_x[k - 1] = x;
        __CZ__gl_w[k - 1] = w;
        __CZ__gl_x[N - k] = -__CZ__gl_x[k - 1];
        __CZ__gl_w[N - k] = __CZ__gl_w[k - 1];
    }
    return;
}

define quadgldeletenodes()
{
    free(__CZ__gl_x);
    free(__CZ__gl_w);
    free(__CZ__gl_order);
    free(__CZ__gl_prec);
}

define quadglcore(a, b, n)
{
    local k c d digs order eps places sum ret err x x1 w w1 m;
    local phalf x2 px1 spx1 u b1 a1 half;

    eps = epsilon(epsilon() * 1e-2);
    places = highbit(1 + int (1 / epsilon())) +1;
    if (!isnull(n))
        order = n;
    else {
        m = int (4 + max(0, ln(places / 30.0) / ln(2))) + 2;
        order = 3 * 2 ^ (m - 1);
    }


    quadglcomputenodes(order, 1);

    if (isinfinite(a) || isinfinite(b)) {
        if (isninf(a) && ispinf(b)) {
            for (k = 0; k < order; k++) {
                x1 = __CZ__gl_x[k];
                w1 = __CZ__gl_w[k];

                x = bround(x1 * (1 - x1 ^ 2) ^ (-1 / 2), places);
                w = bround(w1 * (((1 - x1 ^ 2) ^ (-1 / 2)) / (1 - x1 ^ 2)),
                           places);
                sum += bround(w * f(x), places);
            }
        } else if (isninf(a) && !iscinf(b)) {
            for (k = 0; k < order; k++) {
                x1 = __CZ__gl_x[k];
                w1 = __CZ__gl_w[k];

                x = bround((b + 1) - (2 / (x1 + 1)), places);
                w = bround(w1 * (1 / 2 * (2 / (x1 + 1)) ^ 2), places);
                sum += bround(w * f(x), places);
            }
        } else if (!iscinf(a) && ispinf(b)) {
            for (k = 0; k < order; k++) {
                x1 = __CZ__gl_x[k];
                w1 = __CZ__gl_w[k];
                x = bround((a - 1) + (2 / (x1 + 1)), places);
                w = bround(w1 * (((1 / 2) * (2 / (x1 + 1)) ^ 2)), places);
                sum += bround(w * f(x), places);
            }
        } else if (isninf(a) || isninf(b)) {
            /*TODO: swap(a,b) and negate(w)? Lookup! */
            return newerror("quadglcore: reverse limits?");
        } else
            return
                newerror("quadglcore: complex infinity not yet implemented");
        ret = sum;
    } else {
        /* Avoid rounding errors */
        if (a == -1 && b == 1) {
            c = 1;
            d = 0;
        } else {
            c = (b - a) / 2;
            d = (b + a) / 2;
        }
        sum = 0;
        for (k = 0; k < order; k++) {
            sum += bround(__CZ__gl_w[k] * f(c * __CZ__gl_x[k] + d), places);
        }
        ret = c * sum;
    }
    epsilon(eps);
    return ret;
}

define quadgl(a, b, points)
{
    local k sp results epsbits nsect interval length segment slope C x1 y1 x2
        y2;
    local sum D1 D2 D3 D4;
    if (param(0) < 2)
        return newerror("quadgl: not enough arguments");
    epsbits = highbit(1 + int (1 / epsilon())) +1;
    if (isnull(points)) {
        /* return as given */
        return quadglcore(a, b);
    } else {
        /* But if we could half the time needed to execute a single operation
         * we could do all of it in just twice that time. */
        if (isinfinite(a) || isinfinite(b)
            && (!ismat(points) && !islist(points)))
            return
                newerror(strcat
                         ("quadgl: multiple segments of infinite length ",
                          "are not yet supported"));
        if (ismat(points) || islist(points)) {
            sp = size(points);
            if (sp == 0)
                return
                    newerror(strcat
                             ("quadgl: variable 'points` must be a list or ",
                              "1d-matrix of a length > 0"));
            /* check if all points are numbers */
            for (k = 0; k < sp; k++) {
                if (!isnum(points[k]))
                    return
                        newerror(strcat
                                 ("quadgl: elements of 'points` must be ",
                                  "numbers only"));
            }
            /* We have n-1 intervals and a and b, hence n-1 + 2 results */
            results = mat[sp + 1];
            if (a != points[0]) {
                results[0] = quadglcore(a, points[0]);
            } else {
                results[0] = 0;
            }
            if (sp == 1) {
                if (b != points[0]) {
                    results[1] = quadglcore(points[0], b);
                } else {
                    results[1] = 0;
                }
            } else {
                for (k = 1; k < sp; k++) {
                    results[k] = quadglcore(points[k - 1], points[k]);
                }
                if (b != points[k - 1]) {
                    results[k] = quadglcore(points[k - 1], b);
                } else {
                    results[k] = 0;
                }
            }
        } else {
            if (!isint(points) || points <= 0)
                return newerror(strcat("quadgl: variable 'points` must be a ",
                                       "list or a positive integer"));
            /* Taking "points" as the number of equally spaced intervals */
            results = mat[points + 1];
            /* It is easy if a,b lie on the real line */
            if (isreal(a) && isreal(b)) {
                length = abs(a - b);
                segment = length / points;

                for (k = 1; k <= points; k++) {
                    results[k - 1] =
                        quadglcore(a + (k - 1) * segment, a + k * segment);
                }
            } else {
                /* Other contours by way of a list of points */
                slope = (im(b) - im(a)) / (re(b) - re(a));
                C = (im(a) + slope) * re(a);
                length = abs(re(a) - re(b));
                segment = length / points;

                /* y = mx+C where m is the slope, x is the real part and y the
                 * imaginary part  */
                if(re(a)>re(b))swap(a,b);
                for (k = re(a); k <= (re(b)); k+=segment) {
                    x1 = slope*(k) +  C;
                    results[k] = quadglcore(k + x1 * 1i);
                }
            }                   /* else of isreal */
        }                       /* else of ismat|islist */
    }                           /* else of isnull(points) */
    /* With a bit of undeserved luck we have a result by now. */
    sp = size(results);
    for (k = 0; k < sp; k++) {
        sum += results[k];
    }
    return sum;
}

define quad(a, b, points = -1, method = "tanhsinh")
{
    if (isnull(a) || isnull(b) || param(0) < 2)
        return newerror("quad: both limits must be given");
    if (isstr(a)) {
        if (strncmp(a, "cinf", 1) == 0)
            return
                newerror(strcat
                         ("quad: complex infinity not yet supported, use",
                          " 'pinf' or 'ninf' respectively"));
    }
    if (isstr(b)) {
        if (strncmp(b, "cinf", 1) == 0)
            return
                newerror(strcat
                         ("quad: complex infinity not yet supported, use",
                          " 'pinf' or 'ninf' respectively"));
    }

    if (param(0) == 3) {
        if (isstr(points))
            method = points;
    }

    if (strncmp(method, "tanhsinh", 1) == 0) {
        if (!isstr(points)) {
            if (points == -1) {
                return quadts(a, b);
            } else {
                return quadts(a, b, points);
            }
        } else {
            return quadts(a, b);
        }
    }

    if (strncmp(method, "gausslegendre", 1) == 0) {
        if (!isstr(points)) {
            if (points == -1) {
                return quadgl(a, b);
            } else {
                return quadgl(a, b, points);
            }
        } else {
            return quadgl(a, b);
        }
    }
}

define makerange(start, end, steps)
{
    local ret k l step C length slope x1 x2 y1 y2;
    local segment;
    steps = int (steps);
    if (steps < 1) {
        return newerror("makerange: number of steps must be > 0");
    }
    if (!isnum(start) || !isnum(end)) {
        return newerror("makerange: only numbers are supported yet");
    }
    if (isreal(start) && isreal(end)) {
        step = (end - start) / (steps);
        print step;
        ret = mat[steps + 1];
        for (k = 0; k <= steps; k++) {
            ret[k] = k * step + start;
        }
    } else {
        ret = mat[steps + 1];
        if (re(start) > re(end)) {
            swap(start, end);
        }

        slope = (im(end) - im(start)) / (re(end) - re(start));
        C = im(start) - slope * re(start);
        length = abs(re(start) - re(end));
        segment = length / (steps);

        for (k = re(start), l = 0; k <= (re(end)); k += segment, l++) {
            x1 = slope * (k) + C;
            ret[l] = k + x1 * 1i;
        }

    }
    return ret;
}

define makecircle(radius, center, points)
{
    local ret k a b twopi centerx centery;
    if (!isint(points) || points < 2) {
        return
            newerror("makecircle: number of points is not a positive integer");
    }
    if (!isnum(center)) {
        return newerror("makecircle: center does not lie on the complex plane");
    }
    if (!isreal(radius) || radius <= 0) {
        return newerror("makecircle: radius is not a real > 0");
    }
    ret = mat[points];
    twopi = 2 * pi();
    centerx = re(center);
    centery = im(center);
    for (k = 0; k < points; k++) {
        a = centerx + radius * cos(twopi * k / points);
        b = centery + radius * sin(twopi * k / points);
        ret[k] = a + b * 1i;
    }
    return ret;
}

define makeellipse(angle, a, b, center, points)
{
    local ret k x y twopi centerx centery;
    if (!isint(points) || points < 2) {
        return
            newerror("makeellipse: number of points is not a positive integer");
    }
    if (!isnum(center)) {
        return
            newerror("makeellipse: center does not lie on the complex plane");
    }
    if (!isreal(a) || a <= 0) {
        return newerror("makecircle: a is not a real > 0");
    }
    if (!isreal(b) || b <= 0) {
        return newerror("makecircle: b is not a real > 0");
    }
    if (!isreal(angle)) {
        return newerror("makecircle: angle is not a real");
    }
    ret = mat[points];
    twopi = 2 * pi();
    centerx = re(center);
    centery = im(center);
    for (k = 0; k < points; k++) {
        x = centerx + a * cos(twopi * k / points) * cos(angle)
            - b * sin(twopi * k / points) * sin(angle);
        y = centerx + a * cos(twopi * k / points) * sin(angle)
            + b * sin(twopi * k / points) * cos(angle);
        ret[k] = x + y * 1i;
    }
    return ret;
}

define makepoints()
{
    local ret k;
    ret = mat[param(0)];
    for (k = 0; k < param(0); k++) {
        if (!isnum(param(k + 1))) {
            return
                newerror(strcat
                         ("makepoints: parameter number \"", str(k + 1),
                          "\" is not a number"));
        }
        ret[k] = param(k + 1);
    }
    return ret;
}


config("resource_debug", resource_debug_level),;
if (config("resource_debug") & 3) {
    print "quadtsdeletenodes()";
    print "quadtscomputenodes(order, expo, eps)";
    print "quadtscore(a,b,n)";
    print "quadts(a,b,points)";
    print "quadglcomputenodes(N)";
    print "quadgldeletenodes()";
    print "quadglcore(a,b,n)";
    print "quadgl(a,b,points)";
    print "quad(a,b,points=-1,method=\"tanhsinh\")";
    print "makerange(start, end, steps)";
    print "makecircle(radius, center, points)";
    print "makeellipse(angle, a, b, center, points)";
    print "makepoints(a1,[...])";
}
