# Written in Julia by Andreas Noack Jensen
# January 2013
#
# Translation of Fortran file tvpack.f authored by
#
# Alan Genz
# Department of Mathematics
# Washington State University
# Pullman, WA 99164-3113
# Email : alangenz@wsu.edu
#
# Original source available from
# http://www.math.wsu.edu/faculty/genz/software/fort77/tvpack.f

function tvtcdf(nu::Int, h::Vector{Float64}, r::Vector{Float64})
    pt = 0.5 * pi
    h1 = h[1]
    h2 = h[2]
    h3 = h[3]
    r12 = r[1]
    r13 = r[2]
    r23 = r[3]

    # Sort R's and check for special cases

    if abs(r12) > abs(r13)
        h2 = h3
        h3 = h[2]
        r12 = r13
        r13 = r[1]
    end
    if abs(r13) > abs(r23)
        h1 = h2
        h2 = h[1]
        r23 = r13
        r13 = r[3]
    end
    tvt = 0.0
    if abs(h1) + abs(h2) + abs(h3) < eps()
        tvt = (1.0 + (asin(r12) + asin(r13) + asin(r23)) / pt) * 0.125
    elseif nu < 1 && abs(r12) + abs(r13) < eps()
        tvt = normcdf(h1) * bvtcdf(nu, h2, h3, r23)
    elseif nu < 1 && abs(r13) + abs(r23) < eps()
        tvt = normcdf(h3) * bvtcdf(nu, h1, h2, r12)
    elseif nu < 1 && abs(r12) + abs(r23) < eps()
        tvt = normcdf(h2) * bvtcdf(nu, h1, h3, r13)
    elseif 1.0 - r23 < eps()
        tvt = bvtcdf(nu, h1, min(h2, h3), r12)
    elseif r23 + 1.0 < eps()
        if h2 > -h3
            tvt = bvtcdf(nu, h1, h2, r12) - bvtcdf(nu, h1, -h3, r12)
        end
    else

        # Compute singular TVT value

        if nu < 1
            tvt = bvtcdf(nu, h2, h3, r23) * normcdf(h1)
        elseif r23 > 0
            tvt = bvtcdf(nu, h1, min(h2, h3), 0.0)
        elseif h2 > -h3
            tvt = bvtcdf(nu, h1, h2, 0.0) - bvtcdf(nu, h1, -h3, 0.0)
        end
        # Use numerical integration to compute probability

        rua = asin(r12)
        rub = asin(r13)
        ar = asin(r23)
        ruc = pt * sign(ar) - ar
        tvt += adonet(x -> tvtmfn(x, rua, rub, nu, h1, h2, h3, r23, ar, ruc), 0.0, 1.0, sqrt(eps())) / (4.0 * pt)
    end
    return max(0.0, min(tvt, 1.0))
end

#Computes Plackett formula integrands
function tvtmfn(x::Float64, rua::Float64, rub::Float64, nu::Int, h1::Float64, h2::Float64, h3::Float64, r23::Float64, ar::Float64, ruc::Float64)
    retval = 0.0
    r12, rr2 = sincs(rua * x)
    r13, rr3 = sincs(rub * x)
    if abs(rua) > 0
        retval += rua * pntgnd(nu, h1, h2, h3, r13, r23, r12, rr2)
    end
    if abs(rub) > 0
        retval += rub * pntgnd(nu, h1, h3, h2, r12, r23, r13, rr3)
    end
    if nu > 0
        r, rr = sincs(ar + ruc * x)
        retval -= ruc * pntgnd(nu, h2, h3, h1, 0.0, 0.0, r, rr)
    end
    return retval
end

# Computes SIN(X), COS(X)^2, with series approx. for |X| near PI/2
function sincs(x::Float64)
    ee = (0.5 * pi - abs(x))^2
    if ee < 5.0e-5
        sx = abs(1.0 - ee * (1.0 - ee / 12.0) * 0.5) * sign(x)
        cs = ee * (1.0 - ee * (1.0 - 2.0 * ee / 15.0) / 3.0)
    else
        sx = sin(x)
        cs = 1.0 - sx * sx
    end
    return sx, cs
end

# Computes Plackett formula integrand
function pntgnd(nu::Int, ba::Float64, bb::Float64, bc::Float64, ra::Float64, rb::Float64, r::Float64, rr::Float64)
    retval = 0.0
    dt = rr * (rr - (ra - rb)^2 - 2.0 * ra * rb * (1.0 - r))
    if dt > 0
        bt = (bc * rr + ba * (r * rb - ra) + bb * (r * ra - rb)) / sqrt(dt)
        ft = (ba - r * bb)^2 / rr + bb * bb
        if nu < 1
            if bt > -10 && ft < 100
                retval = exp(-ft * 0.5)
                if bt < 10
                    retval *= normcdf(bt)
                end
            end
        else
            ft = sqrt(1.0 + ft / nu)
            retval = tcdf(nu, bt / ft) / ft^nu
        end
    end
    return retval
end

# # One Dimensional Globally Adaptive Integration Function

function adonet(f::Function, a::Float64, b::Float64, tol::Float64)
    ai = Vector{Float64}(100)
    bi = Vector{Float64}(100)
    ei = Vector{Float64}(100)
    fi = Vector{Float64}(100)
    ai[1] = a
    bi[1] = b
    err = 1.0
    ip = 1
    im = 1
    fin = 0.0
    while 4.0err > tol && im < 100
        im += 1
        bi[im] = bi[ip]
        ai[im] = (ai[ip] + bi[ip]) * 0.5
        bi[ip] = ai[im]
        fi[ip], ei[ip] = krnrdt(ai[ip], bi[ip], f)
        fi[im], ei[im] = krnrdt(ai[im], bi[im], f)
        err = 0.0
        fin = 0.0
        for i in 1:im
            if ei[i] > ei[ip]
                ip = i
            end
            fin += fi[i]
            err += ei[i]^2
        end
        err = sqrt(err)
    end
    return fin
end

# # Kronrod Rule

const kronrod_wg = [
    0.2729250867779007e+0,
    0.5566856711617449e-1,
    0.1255803694649048e+0,
    0.1862902109277352e+0,
    0.2331937645919914e+0,
    0.2628045445102478e+0,
]

const kronrod_xgk = [
    0.0e+0,
    0.9963696138895427e+0,
    0.978228658146057e+0,
    0.9416771085780681e+0,
    0.8870625997680953e+0,
    0.8160574566562211e+0,
    0.7301520055740492e+0,
    0.6305995201619651e+0,
    0.5190961292068118e+0,
    0.3979441409523776e+0,
    0.269543155952345e+0,
    0.1361130007993617e+0,
]

const kronrod_wgk = [
    0.1365777947111183e+0,
    0.976544104596129e-2,
    0.2715655468210443e-1,
    0.4582937856442671e-1,
    0.6309742475037484e-1,
    0.7866457193222764e-1,
    0.9295309859690074e-1,
    0.1058720744813894e+0,
    0.1167395024610472e+0,
    0.1251587991003195e+0,
    0.1312806842298057e+0,
    0.1351935727998845e+0,
]

function krnrdt(a::Float64, b::Float64, f::Function)
    wid = (b - a) * 0.5
    cen = (b + a) * 0.5
    fc = f(cen)
    resg = fc * kronrod_wg[1]
    resk = fc * kronrod_wgk[1]
    for j in 1:11
        t = wid * kronrod_xgk[j + 1]
        fc = f(cen - t) + f(cen + t)
        resk += kronrod_wgk[j + 1] * fc
        if mod(j, 2) == 0
            resg += kronrod_wg[div(j, 2) + 1] * fc
        end
    end
    retval = wid * resk
    err = abs(wid * (resk - resg))
    return retval, err
end

# # Student t Distribution Function

function tcdf(nu::Int, t::Float64)
    if nu < 1
        studnt = normcdf(t)
    elseif nu == 1
        studnt = (1.0 + 2.0atan(t) / pi) * 0.5
    elseif nu == 2
        studnt = (1.0 + t / sqrt(2.0 + t * t)) * 0.5
    else
        tt = t * t
        cssthe = 1.0 / (1.0 + tt / nu)
        polyn = 1.0
        for j in (nu - 2):-2:2
            polyn = 1.0 + (j - 1) * cssthe * polyn / j
        end
        if mod(nu, 2) == 1
            rn = nu
            ts = t / sqrt(rn)
            studnt = (1.0 + 2.0 * (atan(ts) + ts * cssthe * polyn) / pi) * 0.5
        else
            snthe = t / sqrt(nu + tt)
            studnt = (1.0 + snthe * polyn) * 0.5
        end
        studnt = max(0.0, min(studnt, 1.0))
    end
    return studnt
end

function bvtcdf(nu::Int, dh::Float64, dk::Float64, r::Float64)
    if nu < 1
        return bvnuppercdf(-dh, -dk, r)
    elseif 1.0 - r < eps()
        return tcdf(nu, min(dh, dk))
    elseif r + 1.0 < eps()
        if dh > -dk
            return tcdf(nu, dh) - tcdf(nu, -dk)
        else
            return 0.0
        end
    else
        snu = sqrt(nu)
        ors = 1.0 - r * r
        hrk = dh - r * dk
        krh = dk - r * dh
        if abs(hrk) + ors > 0
            xnhk = hrk^2 / (hrk^2 + ors * (nu + dk^2))
            xnkh = krh^2 / (krh^2 + ors * (nu + dh^2))
        else
            xnhk = 0.0
            xnkh = 0.0
        end
        hs = sign(hrk)
        ks = sign(krh)
        if mod(nu, 2) == 0
            bvt = atan(sqrt(ors), -r) / (2.0pi)
            gmph = dh / sqrt(16.0 * (nu + dh^2))
            gmpk = dk / sqrt(16.0 * (nu + dk^2))
            btnckh = 2.0atan(sqrt(xnkh), sqrt(1.0 - xnkh)) / pi
            btpdkh = 2.0sqrt(xnkh * (1.0 - xnkh)) / pi
            btnchk = 2.0atan(sqrt(xnhk), sqrt(1.0 - xnhk)) / pi
            btpdhk = 2.0sqrt(xnhk * (1.0 - xnhk)) / pi
            for j in 1:div(nu, 2)
                bvt += gmph * (1.0 + ks * btnckh)
                bvt += gmpk * (1.0 + hs * btnchk)
                btnckh += btpdkh
                btpdkh *= 2.0j * (1.0 - xnkh) / (2j + 1)
                btnchk += btpdhk
                btpdhk *= 2.0j * (1.0 - xnhk) / (2j + 1)
                gmph *= (2j - 1) / (2j * (1.0 + dh * dh / nu))
                gmpk *= (2j - 1) / (2j * (1.0 + dk * dk / nu))
            end
        else
            qhrk = sqrt(dh * dh + dk * dk - 2.0r * dh * dk + nu * ors)
            hkrn = dh * dk + r * nu
            hkn = dh * dk - nu
            hpk = dh + dk
            bvt = atan(-snu * (hkn * qhrk + hpk * hkrn), hkn * hkrn - nu * hpk * qhrk) / (2.0pi)
            if bvt < -eps()
                bvt += 1.0
            end
            gmph = dh / (2.0pi * snu * (1.0 + dh * dh / nu))
            gmpk = dk / (2.0pi * snu * (1.0 + dk * dk / nu))
            btnckh = sqrt(xnkh)
            btpdkh = btnckh
            btnchk = sqrt(xnhk)
            btpdhk = btnchk
            for j in 1:div(nu - 1, 2)
                bvt += gmph * (1.0 + ks * btnckh)
                bvt += gmpk * (1.0 + hs * btnchk)
                btpdkh *= (2j - 1) * (1.0 - xnkh) / (2 * j)
                btnckh += btpdkh
                btpdhk *= (2j - 1) * (1.0 - xnhk) / (2 * j)
                btnchk += btpdhk
                gmph *= 2.0j / ((2j + 1) * (1.0 + dh * dh / nu))
                gmpk *= 2.0j / ((2j + 1) * (1.0 + dk * dk / nu))
            end
        end
        return bvt
    end
end

# This function is based on the method described by
#     Drezner, Z and G.O. Wesolowsky, (1989),
#     On the computation of the bivariate normal integral,
#     Journal of Statist. Comput. Simul. 35, pp. 101-107,
# with major modifications for double precision, and for |R| close to 1.

const bvncdf_w_array = [
    0.1713244923791705e+0 0.4717533638651177e-1 0.1761400713915212e-1;
    0.3607615730481384e+0 0.1069393259953183e+0 0.4060142980038694e-1;
    0.4679139345726904e+0 0.1600783285433464e+0 0.6267204833410906e-1;
    0.0                    0.2031674267230659e+0 0.8327674157670475e-1;
    0.0                       0.2334925365383547e+0 0.1019301198172404e+0;
    0.0                       0.2491470458134029e+0 0.1181945319615184e+0;
    0.0                       0.0                      0.1316886384491766e+0;
    0.0                       0.0                      0.1420961093183821e+0;
    0.0                       0.0                      0.1491729864726037e+0;
    0.0                       0.0                      0.1527533871307259e+0
]

const bvncdf_x_array = [
    -0.9324695142031522e+0 -0.9815606342467191e+0 -0.9931285991850949e+0;
    -0.6612093864662647e+0 -0.904117256370475e+0 -0.9639719272779138e+0;
    -0.238619186083197e+0 -0.769902674194305e+0 -0.9122344282513259e+0;
    0.0                     -0.5873179542866171e+0 -0.8391169718222188e+0;
    0.0                     -0.3678314989981802e+0 -0.7463319064601508e+0;
    0.0                     -0.1252334085114692e+0 -0.636053680726515e+0;
    0.0                     0.0                     -0.5108670019508271e+0;
    0.0                     0.0                     -0.3737060887154196e+0;
    0.0                     0.0                     -0.2277858511416451e+0;
    0.0                     0.0                     -0.7652652113349733e-1
]

function bvnuppercdf(dh::T, dk::T, r::T)::T where {T <: Float64}

    if r < -one(T) || r > one(T)
        throw(DomainError("r must be ∈ [-1,1]"))
    end

    if isfinite(dh) && isfinite(dk)
        if abs(r) < 0.3
            ng = 1
            lg = 3
        elseif abs(r) < 0.75
            ng = 2
            lg = 6
        else
            ng = 3
            lg = 10
        end
        h = dh
        k = dk
        hk = h * k
        bvn = 0.0
        if abs(r) < 0.925
            if abs(r) > 0
                hs = (h * h + k * k) * 0.5
                asr = asin(r)
                for i in 1:lg
                    for j in -1:2:1
                        sn = sin(asr * (j * bvncdf_x_array[i, ng] + 1.0) * 0.5)
                        bvn += bvncdf_w_array[i, ng] * exp((sn * hk - hs) / (1.0 - sn * sn))
                    end
                end
                bvn *= asr / (4.0pi)
            end
            bvn += normcdf(-h) * normcdf(-k)
        else
            if r < 0
                k = -k
                hk = -hk
            end
            if abs(r) < 1
                as = (1.0 - r) * (1.0 + r)
                a = sqrt(as)
                bs = (h - k)^2
                c = (4.0 - hk) * 0.125
                d = (12.0 - hk) * 0.0625
                asr = -(bs / as + hk) * 0.5
                if asr > -100
                    bvn = a * exp(asr) * (1.0 - c * (bs - as) * (1.0 - d * bs / 5.0) / 3.0 + c * d * as * as / 5.0)
                end
                if -hk < 100
                    b = sqrt(bs)
                    bvn -= exp(-hk * 0.5) * sqrt(2.0pi) * normcdf(-b / a) * b * (1.0 - c * bs * (1.0 - d * bs / 5.0) / 3.0)
                end
                a /= 2.0
                for i in 1:lg
                    for j in -1:2:1
                        xs = (a * (j * bvncdf_x_array[i, ng] + 1.0))^2
                        rs = sqrt(1.0 - xs)
                        asr = -(bs / xs + hk) * 0.5
                        if asr > -100
                            bvn += a * bvncdf_w_array[i, ng] * exp(asr) * (exp(-hk * (1.0 - rs) / (2.0 * (1.0 + rs))) / rs - (1.0 + c * xs * (1.0 + d * xs)))
                        end
                    end
                end
                bvn /= -2.0pi
            end
            if r > 0
                bvn += normcdf(-max(h, k))
            else
                bvn = -bvn
                if k > h
                    bvn += normcdf(k) - normcdf(h)
                end
            end
        end
        return bvn

        # here we either have 0 or the marginal
    else
        if dh == typemax(T) || dk == typemax(T)
            return zero(T)
        elseif dh == typemin(T)
            return normcdf(-dk)
        elseif dk == typemin(T)
            return normcdf(-dh)
        else
            throw(error())
        end
    end
end

bvncdf(dh, dk, r) = bvnuppercdf(-dh, -dk, r)
