/// special functions coded for Yacas by Serge Winitzki

/////////////////////////////////////////////////
/// Euler's Gamma function
/////////////////////////////////////////////////

/// This procedure computes the uniform approximation for the Gamma function
/// due to Lanczos and Spouge (the so-called "less precise coefficients")
/// evaluated at arbitrary precision by using a large number of terms
/// See J. L. Spouge, SIAM J. of Num. Anal. 31, 931 (1994)
/// See also Paul Godfrey 2001 (unpublished): http://winnie.fit.edu/~gabdo/gamma.txt for a discussion

/// Calculate the uniform approximation to the logarithm of the Gamma function
/// in the Re z > 0 half-plane; argument z may be symbolic or complex
/// but current value of precision is used
/// Note that we return LnGamma(z), not of z+1
/// This function should not be used directly by applications
10 # LnGammaNum(_z, _a)_(N(Re(z))<0) <-- [
	If (Verbose, Echo({"LnGammaNum: using 1-z identity"}));
	N(Ln(Pi/Sin(Pi*z)) - LnGammaNum(1-z, a));
];
20 # LnGammaNum(_z, _a) <-- [
	Local(e, k, tmpcoeff, coeff, result);
	a := Max(a, 4);	// guard against low values
	If (Verbose, Echo({"LnGammaNum: precision parameter = ", a}));
	e := N(Exp(1));
	k:=Ceil(a);	// prepare k=N+1; the k=N term is probably never significant but we don't win much by excluding it
	result := 0;	// prepare for last term
	// use Horner scheme to prevent loss of precision
	While(k>1) [	// 'result' will accumulate just the sum for now
		k:=k-1;
		result := N( MathPower(a-k,k)/((z+k)*Sqrt(a-k))-result/(e*k) );
	];
	N(Ln(1+Exp(a-1)/Sqrt(2*Pi)*result) + Ln(2*Pi)/2 -a-z+(z+1/2)*Ln(z+a) - Ln(z));
];

/* this routine is much slower and less precise
20 # LnGammaNum0(_z, _a) <-- [
	Local(e, k, tmpcoeff, coeff0, coeff, result);
	e := N(Exp(1));
	a := Max(a, 4);	// guard against low values
	coeff0 := 1;
	result := coeff0;
	tmpcoeff := N(Exp(a-1)/Sqrt(2*Pi));
	For(k:=1, k<=Ceil(a)-1, k++) [
		coeff := N(tmpcoeff*(a-k)^(k-1/2));
//		Echo({"coeff c[", k, "] =",  coeff});
		result := N(result + coeff/(z+k));
//		Echo({"sum at step ", k, " =",  result});
		tmpcoeff := N(-tmpcoeff/(k*e));
	];
//	Echo({k, " coefficients, last is", tmpcoeff});
	N(Ln(result) + Ln(2*Pi)/2 - a  - z +(z+1/2)*Ln(z+a) - Ln(z));
];
*/

LnGammaNum(z) := [
	Local(a, prec, result);
	prec := GetPrecision();
	Precision(10);	// save time here
	a:= Floor(N( 0.9*prec*Ln(10)/Ln(2*Pi) )) + 0.4;	// fudge factor 0.9 :)
	/// same as parameter "g" in Godfrey 2001.
	/// Chosen to satisfy Spouge's error bound:
	/// error < Sqrt(a)/Real(a+z)/(2*Pi)^(a+1/2)
//	Echo({"parameter a = ", a, " setting precision to ", Ceil(prec*1.4)});
	Precision(Ceil(prec*1.4));	// need more precision b/c of roundoff errors
	result := LnGammaNum(z,a);
	Precision(prec);
	result;
];

GammaNum(z) := N(Exp(LnGammaNum(z)));
GammaNum(z,a) := N(Exp(LnGammaNum(z,a)));	/// should not be used by applications

//Retract("Gamma", 1);	// want to be able to Load() this many times
/// User visible functions: Gamma(x), LnGamma(x)
10 # Gamma(_n)_(IsInteger(n) And n<=0) <-- Infinity;
10 # LnGamma(_n)_(IsInteger(n) And n<=0) <-- Infinity;

20 # Gamma(n_IsRationalOrNumber)_(IsPositiveInteger(n) Or IsInteger(N(2*n))) <-- Eval((n-1)!);
20 # LnGamma(n_IsRationalOrNumber)_(IsPositiveInteger(n) Or IsInteger(N(2*n))) <-- Eval(Ln((n-1)!));

30 # Gamma(x_IsConstant)_(Numeric) <-- GammaNum(N(x));
30 # LnGamma(x_IsConstant)_(Numeric) <-- LnGammaNum(N(x));

/////////////////////////////////////////////////
/// Riemann's Zeta function
/////////////////////////////////////////////////

/// Analytic and numerical computations of Riemann's Zeta function
/// See: Bateman, Erdelyi: <i>Higher Transcendental Functions<i>, vol. 1;
/// P. Borwein, <i>An efficient algorithm for Riemann Zeta function<i> (1995).

/// Numerical computation of Zeta function using Borwein's "third" algorithm
/// The value of $n$ must be large enough to ensure required precision
/// Also $s$ must satisfy $Re(s)+n+1 > 0$
ZetaNum(_s, n_IsInteger) <-- [
	Local(result, j, sign);
	If (Verbose, Echo({"ZetaNum: Borwein's method, precision ", GetPrecision(), ", n = ", n}));
	result := 0;
	sign := 1;	// flipping sign
	For(j:=0, j<=2*n-1, j++)
	[	// this is suboptimal b/c we can compute the coefficients a lot faster in this same loop, but ok for now
		result := N(result + sign*ZetaNumCoeffEj(j,n)/(1+j)^s );
		sign := -sign;
	];
	N(result/(2^n)/(1-2^(1-s)));
];

/// direct method -- only good for large s
ZetaNum1(s, limit) := [
	Local(i, sum);
	If (Verbose, Echo({"ZetaNum: direct method (sum), precision ", GetPrecision(), ", N = ", limit}));
	sum := 0;
	limit := Ceil(N(limit));
	For(i:=2, i<=limit, i++) sum := sum+N(1/MathPower(i, s));
//	sum := sum + ( N( 1/MathPower(limit, s-1)) + N(1/MathPower(limit+1, s-1)) )/2/(s-1); 	 // these extra terms don't seem to help much
	sum+1;	// add small terms together and then add 1
];
/// direct method -- using infinite product. For internal math, ZetaNum2 is faster for Bernoulli numbers > 250 or so.
ZetaNum2(s, limit) := 
[
	Local(i, prod);
	If (Verbose, Echo({"ZetaNum: direct method (product), precision ", GetPrecision(), ", N = ", limit}));
	prod := N( (1-1/MathPower(2, s))*(1-1/MathPower(3,s)) );
	limit := Ceil(N(limit));
	For(i:=5, i<=limit, i:= NextPrime(i))
		prod := prod*N(1-1/MathPower(i, s));
	1/prod;
];

/// obtain the next prime number
NextPrime(i_IsOdd) <--
[
	Until(IsPrime(i)) i:= i + 2*Mod(-i, 3);
	i;
];
NextPrime(i_IsEven) <--
[
	i := i + 1;
	If(IsPrime(i), i, NextPrime(i));
];

/// Compute coefficients e[j] (see Borwein -- excluding (-1)^j )
ZetaNumCoeffEj(j,n) := [
	Local(k);
	2^n-If(j<n,
		0,
		Sum(k,0,j-n,Bin(n,k))	// this is suboptimal but ok for now
	);
];

/// User interface for ZetaNum(s,n)
10 # ZetaNum(_s) _ (N(s)=0) <-- -0.5;
10 # ZetaNum(_s) _ (N(s)=1) <-- Infinity;
20 # ZetaNum(_s) <-- [
	Local(n, prec, result);
	prec := GetPrecision();
	If(	// use identity if s<1/2 to replace with larger s. Also must be sn!=0 or else we get infinity * zero
		N(Re(s)) < 0.5,
		// call ourselves with a different argument
		[
			If(Verbose, Echo({"ZetaNum: using s->1-s identity, s=", s, ", precision ", prec}));
			result :=  2*Exp(LnGammaNum(1-s)-(1-s)*Ln(2*Pi()))*Sin(Pi()*s/2) * ZetaNum(1-s);
		],
		// choose between methods
		If (N(Re(s)) > N(1+(prec*Ln(10))/(Ln(prec)+0.1), 6),
			[	// use direct summation
				n:= N(10^(prec/(s-1)), 6)+2;	// 2 guard terms
				Precision(prec+2);	// 2 guard digits
				result := ZetaNum1(s, n);
			],
			[	// use ZetaNum(s, n)
				n := Ceil( N( prec*Ln(10)/Ln(8) + 2, 6 ) );	// add 2 digits just in case
				Precision(prec+2);	// 2 guard digits
				result := ZetaNum(s, n);
			]
		)
	);
	Precision(prec);
	result;
];

/// use identities for exact values of Zeta
10 # Zeta(1) <-- Infinity;
10 # Zeta(0) <-- -1/2;
10 # Zeta(n_IsEven)_(n>0) <-- Pi^n*(2^(n-1)/n! *Abs(Bernoulli(n)));
10 # Zeta(n_IsInteger)_(n<0) <-- -Bernoulli(-n+1)/(-n+1);

/// compute numeric value
20 # Zeta(_s)_(Numeric And IsNumber(N(s))) <-- N(ZetaNum(N(s)));

/////////////////////////////////////////////////
/// Bernoulli numbers and polynomials
/////////////////////////////////////////////////

/// Bernoulli(n): interface to Bernoulli numbers
10 # Bernoulli(0) <-- 1;
10 # Bernoulli(1) <-- -1/2;
15 # Bernoulli(n_IsInteger)_(n<0) <-- Undefined;
30 # Bernoulli(n_IsOdd) <-- 0;

/// numerical computations of Bernulli numbers use two different methods, one good for small numbers and one good only for very large numbers (using Zeta function)
20 # Bernoulli(n_IsEven)_(n<=Bernoulli1Threshold) <-- BernoulliArray(n)[n+1];
20 # Bernoulli(n_IsEven)_(n>Bernoulli1Threshold) <-- Bernoulli1(n);

/// Bernoulli1Threshold could in principle be set by the user
If(Not IsBound(Bernoulli1Threshold), Bernoulli1Threshold := 20);

/// Simple implementation of the recurrence relation: create an array of Bernoulli numbers
// special case: n=0 or n=1
10 # BernoulliArray(n_IsInteger)_(n=0 Or n=1) <-- [
	Local(B);
	B:=ArrayCreate(n+1,0);
	B[1] := 1;
	If(n=1, B[2] := -1/2);
	B;
];
/// Assume n>=2
20 # BernoulliArray(n_IsInteger) <-- [
	Local(B, i, k, k2, bin);
	If (Verbose, Echo({"BernoulliArray: using direct recursion, n = ", n}));
	B:=ArrayCreate(n+1, 0);	// array of B[k], k=1,2,... where B[1] is the 0th Bernoulli number
	// it would be better not to store the odd elements but let's optimize this later
	// we could also maintain a global cache of Bernoulli numbers computed so far, but it won't really speed up things at large n
	// all odd elements after B[2] are zero
	B[1] := 1;
	B[2] := -1/2;
	B[3] := 1/6;
	For(i:=4, i<=n, i := i+2)	// compute and store B[i]
	[	// maintain binomial coefficient
		bin := 1;	// Bin(i+1,0)
		// do not sum over odd elements that are zero anyway - cuts time in half
		B[i+1] := 1/2-1/(i+1)*(1 + Sum(k, 1, i/2-1,
			[
				bin := bin * (i+3-2*k) * (i+2-2*k)/ (2*k-1) / (2*k);
				B[2*k+1]*bin;	// *Bin(i+1, 2*k)
			]
		) );
	];
	B;
];

/// Bernoulli polynomials of degree n in variable x
Bernoulli(n_IsInteger, _x) <-- [
	Local(B, i, result);
	B := BernoulliArray(n);
	result := B[1];
	For(i:=n-1, i>=0, i--) [
		result := result * x + B[n-i+1]*Bin(n,i);
	];
	result;
];

/// Find the fractional part of Bernoulli number with even index >=2
/// return negative if the sign of the Bernoulli number is negative
BernoulliFracPart(n_IsEven)_(n>=2) <-- [
	Local(p, sum);
	// always 2 and 3
	sum := 1/2+1/3;
	// check whether n+1 and n/2+1 are prime
	If(IsPrime(n+1), sum := sum+1/(n+1));
	If(IsPrime(n/2+1), sum := sum+1/(n/2+1));
	// sum over all primes p such that n / p-1 is integer
	// enough to check up to n/3 now
	For(p:=5, p<=n/3+1, p:=NextPrime(p))
		If(Mod(n, p-1)=0, sum := sum + 1/p);
	// for negative Bernoulli numbers, let's change sign
	// Mod(n/2, 2) is 0 for negative Bernoulli numbers and 1 for positive ones
	Div(Numer(sum), Denom(sum)) - sum
		 + Mod(n/2,2);	// we'll return a negative number if the Bernoulli itself is negative -- slightly against our definitions in the manual
		//+ 1;	// this would be exactly like the manual says
];

/// Find one Bernoulli number for large index
/// compute Riemann's zeta function and combine with the fractional part
Bernoulli1(n_IsEven)_(n>=2) <-- [
	Local(B, prec);
	prec := GetPrecision();
	// estimate the size of B[n] using Stirling formula
	// and compute Ln(B[n])/Ln(10) to find the number of digits
	Precision(10);
	Precision(
		Ceil(N((1/2*Ln(8*Pi*n)-n+n*Ln(n/2/Pi))/Ln(10)))+3	// 3 guard digits
	);
	If (Verbose, Echo({"Bernoulli: using zeta funcion, precision ", GetPrecision(), ", n = ", n}));
	B := Floor(N(	// compute integer part of B
		If(	// use different methods to compute Zeta function
			n>250,	// threshold is roughly right for internal math
			ZetaNum2(n, n/17+1),	// with this method, a single Bernoulli number n is computed in O(n*M(P)) operations where P = O(n*Ln(n)) is the required precision
			// Brent's method requires n^2*P+n*M(P)
			// simple array method requires 
			ZetaNum1(n, n/17+1)	// this gives O(n*Ln(n)*M(P))
		)
		*N(2*n! /(2*Pi)^n)))
		// 2*Pi*e is approx. 17, add 1 to guard precision
		* (2*Mod(n/2,2)-1)	// sign of B
		+ BernoulliFracPart(n);	// this already has the right sign
	Precision(prec);	// restore old precision
	B;
];

/// Bernoulli numbers; algorithm from: R. P. Brent, "A FORTRAN multiple-precision arithmetic package", ACM TOMS vol. 4, no. 1, p. 57 (1978).
/// this may be good for floating-point (not exact) evaluation of B[n] at large n
/// but is not good at all for exact evaluation! (too slow)
/// Brent claims that the usual recurrence is numerically unstable
/// but we can't check this because Yacas internal math is fixed-point and Brent's algorithm needs real floating point (C[k] are very small and then multiplied by (2*k)! )
BernoulliArray1(n_IsEven) _ (n>=2) <--
[
	Local(C, f, k, j, denom, sum);
	C := ArrayCreate(n+1, 0);
	f := ArrayCreate(n/2, 0);
	C[1] := 1;
	C[2] := -1/2;
	C[3] := 1/12;	// C[2*k+1] = B[2*k]/(2*k)!
	f[1] := 2;	// f[k] = (2k)!
	For(k:=2, k<=n/2, k++)	// we could start with k=1 but it would be awkward to compute f[] recursively
	[
		// compute f[k]
		f[k] := f[k-1] * (2*k)*(2*k-1);
		// compute C[k]
		C[2*k+1] := 1/(1-4^(-k))/2*(
			[
				denom := 4;	// = 4^1
				sum := 0;
				For(j:=1, j<=k-1, j++)
				[
					sum := sum + C[2*(k-j)+1]/denom/f[j];	// + C[k-j]/(2*j)! /4^j
					denom := denom * 4;
				];
				(2*k-1)/denom/f[k] - sum;
			]
		);
//	Echo({n, k, denom, C[k]});
	];
	// multiply C's with factorials to get B's
	For(k:=1, k<=n/2, k++)
		C[2*k+1] := C[2*k+1] * f[k];
	// return array object
	C;
];
