/* Author: Bill Gosper */

/*
  Initial version generated from bffac.lisp with the commands

  load("bffac.lisp");
  bffac_functions:[OBFAC,AZETB,VONSCHTOONK,DIVRLST,BURN,OBZETA,BZETA,
  BFPSI,BFFAC,BFHZETA,CBFFAC,BFPSI0,BFZETA];
  apply(stringout,cons("bffac.mac",map('fundef,bffac_functions))),grind:true;
*/


prodhack_product (expr, i%, i%0, i%1) :=
    (expr: subst ('i%, i%, expr),
    if i%0 > i%1 then
        subst (i%, 'i%, 1 / product (expr, i%, i%1 + 1, i%0 - 1))
    else
        subst (i%, 'i%, product (expr, i%, i%0, i%1)));

obfac(z,fpprec):=block([y:z-entier(z),x:entier(7*fpprec/3),m:0],
      for k from entier(26*fpprec/3) step -1 thru 1 do m:x*(1/(y+k)-m/k),
      bfloat(m)*x^y*prodhack_product(z-i+1,i,1,entier(z)));

azetb(s,fpp):=block([fpprec:15],
      if s > 0
	  then block([m:0,
		      p:print(entier(log(
				      bfloat(2*%pi)^s
				       *bfloat(10)^(fpp:entier(fpp))
				       /bfloat(%pi*(s-1)!))
				      /bfloat(2*%pi)))],fpprec:fpp,
		     for k from entier(ev(%pi*p,numer)) step -1 thru 0 do
			 m:(s+2*k)*(s+2*k-1)*m/((2*k+1)*(2*k+2)*p^2)
			   +p*bern(2*k)/(s-1),(1/2+m)/p^s+sum(k^-s,k,1,p-1),
		     bfloat(%\%))
	  else (if s = 0 then -1/2
		    else ((2*%pi)^s*sin(%pi*s/2)*bffac(-s,fpprec)
				   *bzeta(1-s,fpprec)
			   /%pi,bfloat(%\%))));

vonschtoonk(p):=apply("*",
	    subst(["*" = lambda([[l]],1),"^" = lambda([[l]],1)],
		  factor(1+divrlst(p))));

divrlst(p):=(
	args(expand(ratsimp(subst("^" = lambda([a,b],
					       (1-part(a)^(b/2+1))
						/(1-part(a))),factor(p^2))))),
	ev(%\%,part));

burn(p):=if evenp(p)
      then block([d:vonschtoonk(p)],
		 block([fpprec:entier(ev(
				       (log(8*%pi*p)/2+p*(log(p/(2*%pi))-1)
						      +2*log(d))
					/log(10),numer))
			       +1],
		       block([pi:bfloat(%pi)],
			     entier(2*d*p!*bfzeta(p,fpprec)/(2^p*pi^p)+1/2)
			      /d)))
      *(-1)^(p/2-1) else bern(p);

obzeta(s,fpprec):=if s > 0
        then block([m:0,
		    p:entier(ev((log(2*%pi)*s+log(10)*fpprec-log(%pi*(s-1)!))
				 /(2*%pi),numer))],
		   for k from entier(ev(%pi*p,numer)) step -1 thru 0 do
		       m:(s+2*k)*(s+2*k-1)*m/((2*k+1)*(2*k+2)*p^2)
			 +p*bern(2*k)/(s-1),(1/2+m)/p^s+sum(k^-s,k,1,p-1),
		   bfloat(%\%))
        else (if s = 0 then -1/2
		  else ((2*%pi)^s*sin(%pi*s/2)*bffac(-s,fpprec)
					*bzeta(1-s,fpprec)
				/%pi,bfloat(%\%)));

bzeta(s,fpp):=if s > 0
       then block([fpprec:7,m:0,t:0.0b0,p,
		   k:2*max(1,
			   entier(ev(3/2-(s-1/2)*log(s/(2*%pi))+log(10)*fpp
					-log(%pi),numer)
				   /2))],
		  p:1+entier(bfloat((2*10^fpp*product(s+k-i-2,i,0,k-2)
				     /(2*3.14159265b0)^k)
				     ^(1.0b0/(s+k-1)))),fpprec:fpp,
		  for k from k/2 step -1 thru 0 do
		      m:(s+2*k)*(s+2*k-1)*m/((2*k+1)*(2*k+2)*p^2)
			+p*bern(2*k)/(s-1),
		  if s < 25 then t:sum(k^-s,k,1,p-1)
		      else for k from p-1 step -1 thru 1 do
			       (fpprec:fpp-entier(ev(s*log(k)/log(10),numer)),
				t:t+k^-s),bfloat((1/2+m)/p^s+t))
       else (if s = 0 then -1/2
		 else ((2*%pi)^s*sin(%pi*s/2)*bffac(-s,fpprec)
				*bzeta(1-s,fpprec)
			/%pi,bfloat(%\%)));

bfpsi(n,z,fpprec):=if equal(n,0) then bfpsi0(z,fpprec)
       else bfhzeta(n+1,z,fpprec)*(-1)^(n-1)*n!;

bffac(z,fpprec):=if z < 0 then bfloat(%pi*z/sin(%pi*z))/bffac(-z,fpprec)
       else block([k:2*(entier(0.41*fpprec)+1)],
		  block([m:1,y:(z+k)^2,x:0.0b0],
			for i thru k/2 do
			    (m:m*(z+2*i-1)*(z+2*i),
			     x:(x+bern(k-2*i+2)/((k-2*i+1)*(k-2*i+2)))/y),
			bfloat(sqrt(2)*sqrt(%pi)*sqrt(z+k)
				      *%e^((z+k)*(log(z+k)+x-1)))
			 /m));

bfhzeta(s,h,fpprec):=if s > 0
	 then block([m:0,p,
		     q:entier(ev((-log(%pi*(s-1)!)+log(2*%pi)*s
						  +log(10)*fpprec)
				  /(2*%pi)
				  -h+1,numer))
		       +h],p:max(q,h+1),
		    for k from entier(ev(%pi*q,numer)) step -1 thru 0 do
		        m:m*(s+2*k-1)*(s+2*k)/((2*k+1)*(2*k+2)*(p-1)^2)
			  +bern(2*k)*(p-1)/(s-1),
		    (m+1/2)/(p-1)^s+sum(1/(k+h)^s,k,0,entier(p-h-1.9b0)),
		    bfloat(%\%))
	 else (if s = 0 then 1/2-h else funmake('bfhzeta,[s,h,fpprec]));

cbffac(z,fpprec):=rectform(
       if realpart(z:rectform(z)) < 0
	   then bfloat(%pi*z/sin(%pi*z))/cbffac(-z,fpprec)
	   else block([k:2*(entier(0.41*fpprec)+1)],
		      block([m:1,y:rectform(1/(z+k)^2),x:0.0b0],
			    for i thru k/2 do
			        (m:expand(m*(z+2*i-1)*(z+2*i)),
				 x:expand(
				   (x+bern(k-2*i+2)/((k-2*i+1)*(k-2*i+2)))
				    *y)),
			    bfloat(sqrt(2)*sqrt(%pi)*sqrt(z+k)
					  *%e^((z+k)*(log(z+k)+x-1)))
			     /m)));

bfpsi0(z,fpprec):=if z < 0 then bfloat(%pi*cot(%pi*(-z)))+bfpsi0(1-z,fpprec)
        else block([k:2*(entier(0.41*fpprec)+1)],
		   block([m:0,y:(z+k)^2,x:0.0b0],
			 for i thru k/2 do
			     (m:1/(z+2*i-1)+1/(z+2*i-2)+m,
			      x:(x+bern(k-2*i+2)/(k-2*i+2))/y),
			 bfloat(log(z+k)-1/(2*(z+k))-x-m)));

bfzeta(s,fpp):=if s > 0
        then block([fpprec:7,m:0,t:0.0b0,p,
		    k:2*max(1,
			    entier(ev(-(s-1/2)*log(s/(2*%pi))
				       +log(10)*fpp-log(%pi)+3/2,numer)
				    /2))],
		   p:entier(bfloat(2^(1/(s+k-1))*10^(fpp/(s+k-1))
						*product(s+k-i-2,i,0,k-2)
						 ^(1/(s+k-1))
				    /6.2831853b0^(k/(s+k-1))))
		     +1,fpprec:fpp,
		   for k from k/2 step -1 thru 0 do
		       m:m*(s+2*k-1)*(s+2*k)/((2*k+1)*(2*k+2)*p^2)
			 +bern(2*k)*p/(s-1),
		   if s < 25 then t:sum(1/k^s,k,1,p-1)
		       else for k from p-1 step -1 thru 1 do
			        (fpprec:fpp
					-entier(ev(log(k)*s/log(10),numer)),
				 t:t+1/k^s),bfloat(t+(m+1/2)/p^s))
        else (if s = 0 then -1/2
		  else (bfzeta(1-s,fpprec)*%pi^(s-1)*2^s*bffac(-s,fpprec)
					  *sin(%pi*s/2),bfloat(%\%)));
