\documentclass{article}
\usepackage{axiom}
\begin{document}
\title{\$SPAD/src/algebra special2.spad}
\author{Waldek Hebisch}
\maketitle
\begin{abstract}
\end{abstract}
\eject
\tableofcontents
\eject
\section{Licence}
For legal info see {\tt src/etc/copyright}.

\section{package FSFUN FloatSpecialFunctions}
<<package FSFUN FloatSpecialFunctions>>=
)abbrev package FSFUN FloatSpecialFunctions

FloatSpecialFunctions() : Exports == Implementation where

  Exports ==> with
    logGamma : Float -> Float
      ++ logGamma(x) is the natural log of \spad{Gamma(x)}.
    logGamma : (Complex Float) -> (Complex Float)
      ++ logGamma(x) is the natural log of \spad{Gamma(x)}.
    Gamma : Float -> Float
      ++ Gamma(x) is the Euler Gamma function.
    Gamma : (Complex Float) -> (Complex Float)
      ++ Gamma(x) is the Euler Gamma function.
    Beta : (Float, Float) -> Float
      ++ Beta(x, y) is the Euler Beta function.
    Beta : (Complex Float, Complex Float) -> Complex Float
      ++ Beta(x, y) is the Euler Beta function.

  Implementation ==> add

    bernoulli__gamma__series(z : Complex Float, n : Integer): Complex Float ==
       zinv := 1/z
       zk := zinv
       z2inv := zinv*zinv
       s := zk*((1/12)::(Complex Float))
       for k in 1..n repeat
           zk := zk*z2inv
           kinv := (1::Float)/(((2*k +2)*(2*k+1))::Float)
           bk := (bernoulli(2*k+2)$IntegerNumberTheoryFunctions)::Float
           s := s + ((bk*kinv)::(Complex Float))*zk
       s

    logGamma__a1(z : Complex Float) : Complex Float ==
       (z - ((1/2)::(Complex Float)))*log(z) - z _
           + ((1/2)::(Complex Float))_
             *((log((2 :: Float)*pi()))::(Complex Float))

    logGamma__asymptotic(z : Complex Float, n : Integer): Complex Float ==
       lg1 := logGamma__a1(z)
       lg1 + bernoulli__gamma__series(z, n)

    gamma__series(z : Complex Float, l : Float, n : Integer) : Complex Float ==
       tk := exp(z*(log(l)::(Complex Float)))/z
       s := tk
       for k in 1..n repeat
          tk := tk*(l::(Complex Float))/(z + (k::(Complex Float)))
          s := s + tk
       s*(exp(-l)::(Complex Float))

    Gamma(z : Complex Float) : Complex Float ==
        (base()$Float ~= 2) =>
            error "Gamma can only handle base 2 Float-s"
        l0 := bits()
        l := max(l0 + 5, 20)
        re__z := real(z)
        re__z < (1/2)::Float =>
            bits (l + 5)
            re_zint := round(re__z)
            z1 := z - re_zint::Complex Float
            sign : Float :=
                odd?(retract(re_zint)@Integer) => -1
                1
            z1 = 0 =>
                bits(l0)
                error "Pole of Gamma"
            c__pi := (pi())::(Complex Float)
            one := 1::(Complex Float)
            result := (sign::Float)*c__pi/(Gamma(one - z)*sin(c__pi * z1))
            bits(l0)
            result
        abs__z := real(abs(z))
        l :: Float > 6*abs__z =>
            oz := max(order(abs__z), 5) :: PositiveInteger
            lz := length(oz) :: PositiveInteger
            bits(oz+lz+30)
            loss := real(logGamma__a1(real(z)::(Complex Float))) - _
                    real(logGamma__a1(z))
            len : Float := 2*real(z) + 2*(loss + log2() * (l :: Float)) + 3::Float
            l1a := (l + order(len) + wholePart(loss/log2()) + 12)
            l1 := max(l1a, wholePart(abs__z*log(len)/log2()) +
                           10)::PositiveInteger
            bits(l1)
            result := gamma__series(z, len, 3*wholePart(len) + 6)
            bits(l0)
            result
        llog := max(order(real(abs(logGamma__a1(z)))), 5) :: PositiveInteger
        -- we sum l term, so need length(l) extra bits to
        -- compensate roundoff error
        -- we need llog extra bits in logGamma to avoid loss of
        -- accuracy due to exponential
        -- 12 extra bits to compensate for constant factor
        -- and inaccuracy in computing number of bits
        l1 := l + llog + (length(l)::PositiveInteger) + 12
        bits(l1)
        result := exp(logGamma__asymptotic(z, l quo 6 + 1 ))
        bits(l0)
        result

    -- in exact arithmetic |imag(logGamma__a1(z) - logGamma(z))| < pi/2
    logGamma__lift(z : Complex Float, lg2 : Complex Float) : Complex Float ==
        lg2i := imag(lg2)
        k := round((imag(logGamma__a1(z)) - lg2i)/(2*pi()))
        lg2 + (imaginary()$(Complex Float))*((k*(2::Float)*pi())::(Complex Float))


    logGamma(z : Complex Float) : Complex Float ==
        (base()$Float ~= 2) =>
            error "Gamma can only handle base 2 Float-s"
        l0 := bits()
        l := max(l0 + 5, 20)
        re__z := real(z)
        one := 1::(Complex Float)
        re__z < (1/2)::Float =>
            bits (l + 5)
            re_zint := round(re__z)
            z1 := z - re_zint::Complex Float
            lsign : Float :=
                odd?(retract(re_zint)@Integer) => 1
                0
            z1 = 0 =>
                bits(l0)
                error "Pole of Gamma"
            bits (l + 5)
            c__pi := (pi())::(Complex Float)
            result := log(c__pi) + complex(0, lsign)*c__pi
                       - logGamma(one - z) - log(sin(c__pi * z1))
            result := logGamma__lift(z, result)
            bits(l0)
            result
        abs__z := real(abs(z))
        l :: Float > 6*abs__z =>
            l := l + 5
            if real(abs(z - one)) < ((1/4)::Float) or _
               real(abs(z - one - one)) < ((1/4)::Float) then
                l := 2*l
            bits(l)
            result := logGamma__lift(z, log(Gamma(z)))
            bits(l0)
            result
        -- we sum l term, so need length(l) extra bits to
        -- compensate roundoff error
        -- 12 extra bits to compensate for inaccuracy in computing
        -- number of bits and constant factor
        l1 := l + length(l)::PositiveInteger + 12
        bits(l1)
        result := logGamma__asymptotic(z, l quo 6 + 1 )
        bits(l0)
        result

    Gamma(x : Float) : Float ==
        real(Gamma(x :: (Complex Float)))

    logGamma(x : Float) : Float ==
        x <= 0 =>
            error "Argument to logGamma <= 0"
        real(logGamma(x :: (Complex Float)))

    Beta(x : Complex Float, y : Complex Float) : Complex Float ==
        (base()$Float ~= 2) =>
            error "Beta can only handle base 2 Float-s"
        l0 := bits()
        l1 := max(30, l0 + 10)
        bits(l1)
        -- FIXME : compensate for error in Gamma(x + y)
        res := Gamma(x)*Gamma(y)/Gamma(x + y)
        bits(l0)
        res

    Beta(x : Float, y : Float) : Float ==
        real(Beta(x::(Complex Float), y::(Complex Float)))

@

\section{package FELFUN FloatEllipticFunctions}
<<package FELFUN FloatEllipticFunctions>>=

)abbrev package FELFUN FloatEllipticFunctions
++ Description:
++   This package implements arbitrary precision numerical elliptic
++   functions.  The method is based on descending Landen transform.
FloatEllipticFunctions() : with
    jacobiSn : (Float, Float) -> Float
      ++ jacobiSn(z, m) is the Jacobi sn function
    jacobiCn : (Float, Float) -> Float
      ++ jacobiCn(z, m) is the Jacobi cn function
    jacobiDn : (Float, Float) -> Float
      ++ jacobiDn(z, m) is the Jacobi dn function
    ellipticK : Float -> Float
      ++ ellipticK(m) is the complete elliptic integral of the first kind
    ellipticK : Complex Float -> Complex Float
      ++ ellipticK(m) is the complete elliptic integral of the first kind
    -- Functions below should be local but overloaded
    rabs : Float -> Float
      ++ Undocumented.
    rabs : Complex Float -> Float
      ++ Undocumented.
    landen1 : Float -> List Float
      ++ Undocumented.
    landen1 : Complex Float -> List Complex Float
      ++ Undocumented.
    landen2 : (Float, List Float, Float) -> List Float
      ++ Undocumented.
    landen2 : (Complex Float, List Complex Float, Float) -> List Complex Float
      ++ Undocumented.
    landen : (Float, Float) -> List Float
      ++ Undocumented.
    landen : (Complex Float, Float) -> List Complex Float
      ++ Undocumented.
    kprod : List Float -> Float
      ++ Undocumented.
    kprod : List Complex Float -> Complex Float
      ++ Undocumented.

 == add

    rabs(r : Float) : Float == abs(r)

    rabs(r : Complex Float) : Float == real(abs(r))

    Funs ==>
      landen1(m1 : NT) : List NT ==
        res : List NT := []
        while rabs(m1) < 0.25 repeat
            kp := sqrt(m1)
            kn1 := 2*kp/(1+kp)
            res := cons(1 - kn1, res)
            m1 := 2*kn1 - kn1^2
        cons(m1, res)

      landen2(m : NT, res : List NT, eps : Float) : List NT ==
        repeat
            -- rm := real(m)
            -- im := imag(m)
            -- abs(rm) < eps and abs(im) < eps =>
            am := rabs(m)
            am < eps =>
                kn := (1/4)*m
                res := cons(kn, res)
                break
            kp := sqrt(1 - m)
            -- if am > 0.25 then
            if true then
                kn := (1 - kp)/(1 + kp)
            else
                kn := m/(2 - m + 2*kp)
            res := cons(kn, res)
            m := kn^2
        res

      landen(m : NT, eps : Float) : List NT ==
        res : List NT := []
        if rabs(m1 := 1 - m) < 0.25 then
            res := landen1(m1)
            m := 1 - first(res)
            res := rest(res)
        landen2(m, res, eps)

      kprod(ll : List NT) : NT ==
        reduce(_*, [1 + k for k in ll])

    Funs where NT ==> Float

    Funs where NT ==> Complex Float

    pimod(z : Float) : Float ==
        pi2 := 2*pi()
        nn := retract(round(z/pi2))@Integer
        z - nn*pi2

    two_to_minus_n(n : Integer) : Float ==
        base() ~= 2 => error "Only base 2 is supported"
        float(1, - n)

    ellipticK(m : Float) : Float ==
        m >= 1.0 => error "ellipticK : m >= 1.0"
        obits := bits()
        prec := obits + 20
        eps := two_to_minus_n(prec quo 2)
        ll := landen(m, eps)
        res := (1/2)*pi()*kprod(ll)
        bits(obits)
        res

    ellipticK(m : Complex Float) : Complex Float ==
        m = 1 => error "ellipticK : m = 1.0"
        obits := bits()
        prec := obits + 20
        eps := two_to_minus_n(prec quo 2)
        ll := landen(m, eps)
        res := (1/2)*pi()*kprod(ll)
        bits(obits)
        res

    sn2(z : Float, ll : List Float) : Float ==
        res := sin(z)
        for k in ll repeat
            res := (1 + k)*res/(1 + k*res^2)
        res

    -- Compute 1-sin(z) for z in [0,\pi] with small relative error
    sin1(z : Float) : Float ==
        if z < 1 or z > 2.0 then
            1 - sin(z)
        else
            z1 := z - pi()/2.0
            z1 := z1/2
            2*sin(z1)^2

    -- assumption z \in [0,\pi]
    sn21(z : Float, ll : List Float) : Float==
        res := sin1(z)
        for k in ll repeat
            res0 := 1 - res
            -- 1 + k*res0^2 - (1 + k)*res0 =
            -- 1 + k*(1 - res)^2 - (1 + k)*(1 - res) =
            -- 1 + k*(1 -2*res + res^2) - 1 - k + res + k*res =
            -- k - 2*k*res + k*res^2 - k + res + k*res =
            -- -k*res + k*res^2 + res
            kres := k*res
            res := (res - kres + kres*res)/(1 + k*res0^2)
            -- res0 := (1 + k)*res0/(1 + k*res0^2)
        res

    -- assumption: m < 1
    sn1(z : Float, m : Float, prec : PositiveInteger) : Float ==
        if m > 0.8 or m < -4.0 then
            prec := prec + 20
            bits(prec)
        eps := two_to_minus_n(prec quo 2)
        if m < -48.0 then
            kp := sqrt(1 - m)
            -- 1 + k1
            kp1 := 2.0/(1 + kp)
            m1 := 2*kp1 - kp1^2
            z := z/kp1
            if m1 < 0.25 then
                ll := landen1(m1)
                m := 1 - first(ll)
                ll := landen2(m, rest(ll), eps)
            else
                ll := landen(1 - m1, eps)
            kk := kprod(ll)
            z1 := z/kk
            z1 := pimod(z1)
            if z1 < 0 then
                sign := -1
                z1 := -z1
            else
                sign := 1
            z0 := z1*kk
            if z0 < 0.5 then
                res := sn2(z1, ll)
                sign*kp1*res/(1 + (kp1 - 1)*res^2)
            else
                res1 := sn21(z1, ll)
                -- res = 1 - res1
                -- 1 + k1*res^2 = 1 + (kp1 - 1)*(1 - res1)^2 =
                -- 1 + (kp1 - 1)*(1 -2*res1 + res1^2) =
                -- 1 + (kp1 - 1) + (kp1 - 1)*(-2*res1 +res1^2) =
                -- kp1 + (kp1 - 1)*(res1 - 2)*res1
                sign*kp1*(1 - res1)/(kp1 + (kp1 - 1)*(res1 - 2.0)*res1)
        else
            ll := landen(m, eps)
            kk := kprod(ll)
            z1 := z/kk
            sn2(z1, ll)

    cn1(z : Float, m : Float, prec : PositiveInteger) : Float ==
        if z < 0 then z := -z
        prec := 2*prec
        if m > 0.8 or m < -4.0 then
            prec := prec + 20
        bits(prec)
        eps := two_to_minus_n(prec quo 2)
        ll := landen(m, eps)
        kk := kprod(ll)
        z1 := z/kk
        pih := 0.5*pi()$Float
        nn := retract(round(z1/pih)$Float)@Integer
        if odd?(nn) then
            z2 := z1 - nn*pih
            nn := nn quo 2
            sgn := (odd?(nn) => 1 ; -1)
            sgn := sign(z2)*sgn
        else
            nn := nn quo 2
            sgn := (odd?(nn) => -1 ; 1)
        res0 := sn2(z1, ll)
        sgn*sqrt(1 - res0^2) 

    dn1(z : Float, m : Float, prec : PositiveInteger) : Float ==
        -- Usually overkill, but needed if m close to 1
        prec := 2*prec
        bits(prec)
        res0 := sn1(z, m, prec)
        sqrt(1 - m*res0^2)

    jacobiSn(z : Float, m : Float) ==
        obits := bits()
        prec := obits + 20
        m = 1.0 =>
            bits(prec)
            res := tanh(z)
            bits(obits)
            res
        bits(prec)
        cc := 1.0
        if m > 1 then
            m := 1/m
            k := sqrt(m)
            z := z/k
            res := k*sn1(z, m, prec)
        else
            res := sn1(z, m, prec)
        bits(obits)
        res

    jacobiCn(z : Float, m : Float) : Float ==
        obits := bits()
        prec := obits + 20
        m = 1.0 =>
            bits(prec)
            res := 1/cosh(z)
            bits(obits)
            res
        bits(prec)
        if m > 1 then
            m := 1/m
            k := sqrt(m)
            z := z/k
            res := dn1(z, m, prec)
        else
            res := cn1(z, m, prec)
        bits(obits)
        res

    jacobiDn(z : Float, m : Float) : Float ==
        obits := bits()
        prec := obits + 20
        m = 1.0 =>
            bits(prec)
            res := 1/cosh(z)
            bits(obits)
            res
        bits(prec)
        if m > 1 then
            m := 1/m
            k := sqrt(m)
            z := z/k
            res := cn1(z, m, prec)
        else
            res := dn1(z, m, prec)
        bits(obits)
        res

@

\eject
\begin{thebibliography}{99}
\bibitem{1} nothing
\end{thebibliography}
\end{document}
