arb/gamma/series_fmpq_hypgeom.c

/*=============================================================================

    This file is part of ARB.

    ARB 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 2 of the License, or
    (at your option) any later version.

    ARB 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 ARB; if not, write to the Free Software
    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA

=============================================================================*/
/******************************************************************************

    Copyright (C) 2012, 2013 Fredrik Johansson

******************************************************************************/

#include "fmprb.h"
#include "fmprb_poly.h"
#include "gamma.h"

static void
gamma_sum_bsplit(fmprb_t P, fmprb_t Q,
            fmprb_ptr B, fmprb_ptr T,
            const fmpz_t p, const fmpz_t q,
            long a, long b, long N, long L, long wp)
{
    if (b - a == 1)
    {
        /* P = T = -N, Q = a, B = (q*a + p) + q*x */
        fmprb_set_si(P, (a == 0) ? 1 : -N);
        fmprb_set_si(Q, (a == 0) ? 1 : a);
        fmprb_set(T, P);
        fmprb_set_fmpz(B, q);
        fmprb_mul_ui(B, B, a, wp);
        fmprb_add_fmpz(B, B, p, wp);
        if (L > 1)
            fmprb_set_fmpz(B + 1, q);
    }
    else
    {
        long m, lenbl, lentl, lenbr, lentr, lent, lenb, alloc;
        fmprb_t PL, QL, PR, QR;
        fmprb_ptr BL, TL, BR, TR, TT;

        fmprb_init(PL);
        fmprb_init(QL);
        fmprb_init(PR);
        fmprb_init(QR);

        m = a + (b - a) / 2;

        lenbl = FLINT_MIN(m - a + 1, L);
        lenbr = FLINT_MIN(b - m + 1, L);
        lentl = FLINT_MIN(m - a, L);
        lentr = FLINT_MIN(b - m, L);
        lenb = FLINT_MIN(b - a + 1, L);
        lent = FLINT_MIN(b - a, L);
        alloc = lenbl + lenbr + lentl + lentr + lent;

        BL = _fmprb_vec_init(alloc);
        TL = BL + lenbl;
        BR = TL + lentl;
        TR = BR + lenbr;
        TT = TR + lentr;

        gamma_sum_bsplit(PL, QL, BL, TL, p, q, a, m, N, L, wp);
        gamma_sum_bsplit(PR, QR, BR, TR, p, q, m, b, N, L, wp);

        /* T = BR*TL*QR + BL*TR*PL */
        _fmprb_poly_mullow(T, BR, lenbr, TL, lentl, lent, wp);
        _fmprb_vec_scalar_mul(T, T, lent, QR, wp);
        _fmprb_poly_mullow(TT, BL, lenbl, TR, lentr, lent, wp);
        _fmprb_vec_scalar_mul(TT, TT, lent, PL, wp);
        _fmprb_vec_add(T, T, TT, lent, wp);

        /* P = PL*PR, Q = QL*QR, B = BL*BR */
        fmprb_mul(P, PL, PR, wp);
        fmprb_mul(Q, QL, QR, wp);
        _fmprb_poly_mullow(B, BL, lenbl, BR, lenbr, lenb, wp);

        fmprb_clear(PL);
        fmprb_clear(QL);
        fmprb_clear(PR);
        fmprb_clear(QR);

        _fmprb_vec_clear(BL, alloc);
    }
}

static void
evaluate_series(fmprb_ptr S, const fmpq_t a, long r, long N, long len, long wp, long bsplit_wp)
{
    fmprb_t P, Q;
    fmprb_ptr B, T;

    fmprb_init(P);
    fmprb_init(Q);

    B = _fmprb_vec_init(len);
    T = _fmprb_vec_init(len);

    gamma_sum_bsplit(P, Q, B, T, fmpq_numref(a), fmpq_denref(a), 0, r + 1, N, len, bsplit_wp);
    _fmprb_vec_scalar_mul_fmpz(T, T, len, fmpq_denref(a), bsplit_wp);

    /* S = T / (B * Q) */
    _fmprb_vec_scalar_mul(B, B, len, Q, bsplit_wp);
    _fmprb_poly_inv_series(S, B, len, len, bsplit_wp);
    _fmprb_poly_mullow(B, T, len, S, len, len, bsplit_wp);
    _fmprb_vec_set(S, B, len);

    fmprb_clear(P);
    fmprb_clear(Q);
    _fmprb_vec_clear(B, len);
    _fmprb_vec_clear(T, len);
}


void fmpr_gamma_ui_lbound(fmpr_t x, ulong n, long prec);

static void
add_error_series(fmprb_ptr S, long R, long N, long len)
{
    long i;
    fmpr_t t, u;

    fmpr_init(t);
    fmpr_init(u);

    fmpr_set_ui(u, N);
    fmpr_pow_sloppy_ui(t, u, R, FMPRB_RAD_PREC, FMPR_RND_UP);

    fmpr_gamma_ui_lbound(u, R, FMPRB_RAD_PREC);
    fmpr_div(t, t, u, FMPRB_RAD_PREC, FMPR_RND_UP);

    fmprb_add_error_fmpr(S + 0, t);

    for (i = 1; i < len; i++)
    {
        fmpr_div_ui(t, t, R, FMPRB_RAD_PREC, FMPR_RND_UP);
        fmprb_add_error_fmpr(S + i, t);
    }

    fmpr_clear(t);
    fmpr_clear(u);
}

static void
add_error_integral(fmprb_ptr v, long n, long num)
{
    fmpr_t t, u;
    long j;

    fmpr_init(t);
    fmpr_init(u);

    /* t = 2 exp(-n) */
    fmpr_set_si(t, -n);
    fmpr_exp(t, t, FMPRB_RAD_PREC, FMPR_RND_UP);
    fmpr_mul_2exp_si(t, t, 1);
    fmprb_add_error_fmpr(v + 0, t);

    /* u = log n */
    fmpr_set_ui(u, n);
    fmpr_log(u, u, FMPRB_RAD_PREC, FMPR_RND_UP);

    for (j = 1; j < num; j++)
    {
        /* powers of log */
        fmpr_mul(t, t, u, FMPRB_RAD_PREC, FMPR_RND_UP);
        /* factorials */
        fmpr_div_ui(t, t, j, FMPRB_RAD_PREC, FMPR_RND_UP);
        fmprb_add_error_fmpr(v + j, t);
    }

    fmpr_clear(t);
    fmpr_clear(u);
}

void
_fmprb_poly_ui_pow_series(fmprb_ptr res, ulong c, long len, long wp)
{
    long i;

    for (i = 0; i < len; i++)
    {
        if (i == 0)
        {
            fmprb_one(res + i);
        }
        else if (i == 1)
        {
            fmprb_log_ui(res + i, c, wp);
        }
        else
        {
            fmprb_mul(res + i, res + i - 1, res + 1, wp);
            fmprb_div_ui(res + i, res + i, i, wp);
        }
    }
}

void
gamma_series_fmpq_hypgeom(fmprb_ptr res, const fmpq_t a, long len, long prec)
{
    long N, R, wp, bsplit_wp;
    fmprb_ptr S, logs;
    fmprb_t t;

    wp = prec * 1.01 + 10;
    N = wp * 0.693147180559945;

    /* round N to have many trailing zeros, speeding up arithmetic */
    if (N > 256)
    {
        int b = FLINT_BIT_COUNT(N);
        N = ((N >> (b-4)) + 1) << (b-4);
    }

    R = 3.59112147666862 * N;
    bsplit_wp = wp + N / 0.693147180559945;

    S = _fmprb_vec_init(len);
    logs = _fmprb_vec_init(len);
    fmprb_init(t);

    evaluate_series(S, a, R, N, len, wp, bsplit_wp);

    /* error from truncating the series */
    add_error_series(S, R, N, len);

    /* multiply by series for N^(a+x) */
    _fmprb_poly_ui_pow_series(logs, N, len, wp);
    _fmprb_poly_mullow(res, logs, len, S, len, len, wp);
    fmprb_set_ui(t, N);
    fmprb_pow_fmpq(t, t, a, wp);
    _fmprb_vec_scalar_mul(res, res, len, t, wp);

    /* error from truncating the integral */
    add_error_integral(res, N, len);

    _fmprb_vec_clear(S, len);
    _fmprb_vec_clear(logs, len);
    fmprb_clear(t);
}