# Numerical integration
# 
# The algorithms are described in:
# Numerical Analysis, 5th edition
# by Richard L. Burden and J. Douglas Faires
# PWS Publishing Company, Boston, 1993.
# Library of congress: QA 297 B84 1993

# In the below, f indicates the function whose integral we wish to determine,
# a,b indicate the left and right endpoints of the interval over which
# we wish to integrate, and n is the number of intervals into which we
# divide [a,b]

# These methods all return one value, the value of the integral

# Currently only works for real functions of a real variable

# Composite Simpson's Rule, Section 4.4, Algorithm 4.1, p. 186
# Note that this has error term = max(f'''')*h^4*(b-a)/180,
# where h=(b-a)/n
# If we can get maximums and derivatives, this would allow us to determine
# automatically what n should be.

# Composite simpson's rule is implemented as a built in function

SetHelp ("CompositeSimpsonsRuleTolerance", "calculus", "Integration of f by Composite Simpson's Rule on the interval [a,b] with the number of steps calculated by the fourth derivative bound and the desired tolerance")
function CompositeSimpsonsRuleTolerance(f,a,b,FourthDerivativeBound,Tolerance) =
(
	local *;
	# Error term = max(f'''')*h^4*(b-a)/180,
	# where h=(b-a)/n
	n = ceil(|FourthDerivativeBound*(b-a)^5 / (180*Tolerance)|^(1/4));

	# Note that this is done automatically by CompositeSimpsonsRule
	# function:
	#if IsOdd(n) then n = n+1;

	CompositeSimpsonsRule (f, a, b, n)
)

SetHelp ("CompositeSimpsonsRuleData", "calculus", "Integration by Composite Simpson's Rule of function given as a vector of values on equally spaced subintervals over an interval of length len, data f should have 3 or more values")
function CompositeSimpsonsRuleData(f,len) =
(
	local *;

	if(not IsVector(f) or elements(f) < 3 or not IsValueOnly(f)) then
		(error("CompositeSimpsonsRuleData: argument 1 must be a vector of size at least 3");bailout)
	else if(not IsReal(len) or len <= 0.0) then
		(error("CompositeSimpsonsRuleData: arguments 2 must be a positive real");bailout);

	k = ko = elements(f);
	if IsEven(k) then (
		ko = k-3;
	);
	deltax = len/(k-1);
	if ko > 1 then (
		s = (deltax/3) * (
		 	(f@(1) + f@(ko)) +
		 	(sum j=2 to ko-1 by 2 do 4*f@(j)) +
		 	(sum j=3 to ko-2 by 2 do 2*f@(j))
			)
	) else (
		s = 0
	);

	if ko != k then (
		s = s + (3*deltax/8) * ( f@(ko) + 3*f@(ko+1) + 3*f@(ko+2) + f@(ko+3) )
	);

	s
)

SetHelp ("MidpointRule", "calculus", "Integration by midpoint rule")
function MidpointRule(f,a,b,n...) =
(
  local *;
  if IsNull(n) then
    n = NumericalIntegralSteps
  else if elements(n) > 1 then
    (error("MidpointRule: no nore than 4 arguments");bailout)
  else
    n = n@(1);
  if(not IsFunction(f)) then
	(error("MidpointRule: argument 1 must be a function");bailout)
  else if(not IsReal(a) or not IsReal(b)) then
	(error("MidpointRule: arguments 2, 3 must be real values");bailout)
  else if(not IsInteger(n)) then
	(error("MidpointRule: argument 4 must be an integer");bailout);
  ## check bounds
  if(a>b) then (error("MidpointRule: argument 2 must be less than or equal to argument 3");bailout)
  else if(n<= 0) then (error("MidpointRule: argument 4 must be positive");bailout);

  len = float(b-a);
  s = sum i=1 to n do float(f(a+(len*(i-0.5))/n));
  (s*len)/n
)

SetHelp ("TrapezoidRule", "calculus", "Integration by trapezoid rule")
function TrapezoidRule(f,a,b,n...) =
(
  local *;
  if IsNull(n) then
    n = NumericalIntegralSteps
  else if elements(n) > 1 then
    (error("Trapezoid: no nore than 4 arguments");bailout)
  else
    n = n@(1);
  if(not IsFunction(f)) then
	(error("TrapezoidRule: argument 1 must be a function");bailout)
  else if(not IsReal(a) or not IsReal(b)) then
	(error("TrapezoidRule: arguments 2, 3 must be real values");bailout)
  else if(not IsInteger(n)) then
	(error("TrapezoidRule: argument 4 must be an integer");bailout);
  ## check bounds
  if(a>b) then (error("TrapezoidRule: argument 2 must be less than or equal to argument 3");bailout)
  else if(n<= 0) then (error("TrapezoidRule: argument 4 must be positive");bailout);

  len = float(b-a);
  s = sum i=1 to (n-1) do float(2*f(a+(len*i)/n));
  s = s+f(a)+f(b);
  (s*len)/(2*n)
)

SetHelp ("LeftHandRule", "calculus", "Integration by left hand rule")
function LeftHandRule(f,a,b,n...) =
(
  local *;
  if IsNull(n) then
    n = NumericalIntegralSteps
  else if elements(n) > 1 then
    (error("LeftHandRule: no nore than 4 arguments");bailout)
  else
    n = n@(1);
  if(not IsFunction(f)) then
	(error("LeftHandRule: argument 1 must be a function");bailout)
  else if(not IsReal(a) or not IsReal(b)) then
	(error("LeftHandRule: arguments 2, 3 must be real values");bailout)
  else if(not IsInteger(n)) then
	(error("LeftHandRule: argument 4 must be an integer");bailout);
  ## check bounds
  if(a>b) then (error("LeftHandRule: argument 2 must be less than or equal to argument 3");bailout)
  else if(n<= 0) then (error("LeftHandRule: argument 4 must be positive");bailout);

  len = float(b-a);
  s = sum i=0 to (n-1) do float(f(a+(len*i)/n));
  (s*len)/n
)

SetHelp ("RightHandRule", "calculus", "Integration by right hand rule")
function RightHandRule(f,a,b,n) =
(
  local *;
  if IsNull(n) then
    n = NumericalIntegralSteps
  else if elements(n) > 1 then
    (error("RightHandRule: no nore than 4 arguments");bailout)
  else
    n = n@(1);
  if(not IsFunction(f)) then
	(error("RightHandRule: argument 1 must be a function");bailout)
  else if(not IsReal(a) or not IsReal(b)) then
	(error("RightHandRule: arguments 2, 3 must be real values");bailout)
  else if(not IsInteger(n)) then
	(error("RightHandRule: argument 4 must be an integer");bailout);
  ## check bounds
  if(a>b) then (error("RightHandRule: argument 2 must be less than or equal to argument 3");bailout)
  else if(n<= 0) then (error("RightHandRule: argument 4 must be positive");bailout);

  len = float(b-a);
  s = sum i=1 to n do float(f(a+(len*i)/n));
  (s*len)/n
)

SetHelp("GaussKronrodRule", "calculus", "Return the result of a single GaussKronrodRule (K15, G7), returns a vector with the estimate and the error estimate")
function GaussKronrodRule(f, a, b) = (
  local *;

  # see https://www.advanpix.com/2011/11/07/gauss-kronrod-quadrature-nodes-weights/  
  # nodes on [-1,1], only half (they are symmetric)
  x = [ 0.9914553711208126392068546975263285,
        0.9491079123427585245261896840478513,
        0.8648644233597690727897127886409262,
        0.7415311855993944398638647732807884,
        0.5860872354676911302941448382587296,
        0.4058451513773971669066064120769615,
        0.2077849550078984676006894037732449 ];

  # Gauss weights
  wg = [ 0.0,
         0.1294849661688696932706114326790820,
         0.0,
         0.2797053914892766679014677714237796,
         0.0,
         0.3818300505051189449503697754889751,
         0.0,
         0.4179591836734693877551020408163265 ];

  # Kronrod weights
  wk = [ 0.02293532201052922496373200805896959,
         0.06309209262997855329070066318920429,
         0.1047900103222501838398763225415180,
         0.1406532597155259187451895905102379,
         0.1690047266392679028265834265985503,
         0.1903505780647854099132564024210137,
         0.2044329400752988924141619992346491,
         0.2094821410847278280129991748917143 ];

  c = (a+b)/2.0;
  h = (b-a)/2.0;
    
  gauss = 0.0;
  kronrod = 0.0;
  
  fc = f(c);
  
  gauss = gauss + wg@(8)*fc*h;
  kronrod = kronrod + wk@(8)*fc*h;

  for n=1 to 7 do (
    fs = f(c-h*x@(n))+f(c+h*x@(n));
    
    gauss = gauss + wg@(n)*fs*h;
    kronrod = kronrod + wk@(n)*fs*h;
  );
  
  [kronrod, |gauss-kronrod|]
)

SetHelp("AdaptiveGaussKronrodWithTolerance", "calculus", "Use adaptive composite Gauss-Kronrod (K15, G7) rule until error estimate is less than abstol and reltol times the value up to AdaptiveGaussKronrodMaxIterations times, if unsuccessful returns null")
function AdaptiveGaussKronrodWithTolerance(f, a, b, abstol, reltol) = (
  local *;

  if(not IsFunction(f)) then
	(error("AdaptiveGaussKronrodWithTolerance: argument 1 must be a function");bailout)
  else if(not IsReal(a) or not IsReal(b)) then
	(error("AdaptiveGaussKronrodWithTolerance: arguments 2, 3 must be real values");bailout)
  else if(not IsReal(abstol) or not IsReal(reltol)) then
	(error("AdaptiveGaussKronrodWithTolerance: arguments 4, 5 must be real values");bailout)
  else if (a>b) then (error("AdaptiveGaussKronrodWithTolerance: argument 2 must be less than or equal to argument 3");bailout);

  r = GaussKronrodRule (f, a, b);
  partlist = [a,b,r@(1),r@(2)];

  res = r@(1);

  iters = 0;
  while true do (
    totalerr = sum x in partlist@(,4) do x;

    if (totalerr <= max(abstol, reltol*res)) then
      return res;

    if iters > AdaptiveGaussKronrodMaxIterations then (
      error("AdaptiveGaussKronrod: Maximum iterations reached without reaching desired error tolerance");
      return null
    );

    maxerr = 0.0;
    maxpart = 1;
    # FIXME: this is not optimized at all
    # search for the worst interval to split
    for n = 1 to rows(partlist) do (
      if maxerr < partlist@(n,4) then (
        maxpart = n;
        maxerr = partlist@(n,4)
      )
    );

    aa = partlist@(maxpart,1);
    bb = partlist@(maxpart,2);
    c = (aa+bb)/2.0;

    r = GaussKronrodRule (f, aa, c);
    partlist@(maxpart,2) = c;
    partlist@(maxpart,3) = r@(1);
    partlist@(maxpart,4) = r@(2);

    r = GaussKronrodRule (f, c, bb);
    partlist = [partlist;[c,bb,r@(1),r@(2)]];

    res = sum x in partlist@(,3) do x;

    increment iters
  )
)

SetHelp("AdaptiveGaussKronrod", "calculus", "Use adaptive composite Gauss-Kronrod (K15, G7) rule until error estimate is less than AdaptiveGaussKronrodAbsoluteTolerance and AdaptiveGaussKronrodRelativeTolerance times the value up to AdaptiveGaussKronrodMaxIterations times, if unsuccessful returns null")
function AdaptiveGaussKronrod(f, a, b) = (
  AdaptiveGaussKronrodWithTolerance(f, a, b, AdaptiveGaussKronrodAbsoluteTolerance, AdaptiveGaussKronrodRelativeTolerance)
)

SetHelp ("AdaptiveGaussKronrodAbsoluteTolerance", "parameters", "Absolute tolerance for AdaptiveGaussKronrod, error should be less than this")
parameter AdaptiveGaussKronrodAbsoluteTolerance = 1e-12

SetHelp ("AdaptiveGaussKronrodRelativeTolerance", "parameters", "Relative tolerance for AdaptiveGaussKronrod, error should be less than this times the estimated value")
parameter AdaptiveGaussKronrodRelativeTolerance = 1e-12

SetHelp ("AdaptiveGaussKronrodMaxIterations", "parameters", "Maximum number of iterations to perform in AdaptiveGaussKronrod")
parameter AdaptiveGaussKronrodMaxIterations = 10000


SetHelp ("NumericalIntegralSteps", "parameters", "Default number of steps to perform in MidpointRule, TrapezoidRule, LeftHandRule, RightHandRule, and CompositeSimpsonsRule")
parameter NumericalIntegralSteps = 1000

SetHelp ("NumericalIntegralFunction", "parameters", "The function used for numerical integration in NumericalIntegral (by default AdaptiveGaussKronrod)")
parameter NumericalIntegralFunction = `AdaptiveGaussKronrod

SetHelp ("NumericalIntegral", "calculus", "Integration by rule set in NumericalIntegralFunction of f from a to b")
function NumericalIntegral(f,a,b) = (
	local *;
	NumericalIntegralFunction call (f,a,b)
)
