/*               COPYRIGHT NOTICE

Copyright (C) 2005-2012 Mario Rodriguez Riotorto

This program is free software; you can redistribute
it and/or modify it under the terms of the
GNU General Public License as published by
the Free Software Foundation; either version 2 
of the License, or (at your option) any later version. 

This program is distributed in the hope that it
will be useful, but WITHOUT ANY WARRANTY;
without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the 
GNU General Public License for more details at
http://www.gnu.org/copyleft/gpl.html
*/


/*             INTRODUCTION

This package defines some interpolation techniques.

For questions, suggestions, bugs and the like, feel free
to contact me at

mario @@@ edu DOT xunta DOT es

*/



/* Returns de input in the form of a list of pairs, ordered wrt the first */
/* coordinate. The argument must be either:                               */
/*  a) a two column matrix, p:matrix([2,4],[5,6],[9,3])                   */
/*  b) a list of pairs, p: [[2,4],[5,6],[9,3]]                            */
/*  c) a list of numbers, p: [4,6,3], in which case the abscissas will be */
/*     assigned automatically to 1, 2, 3, etc.                            */
/* This is an uxiliary function for the 'interpol' package.               */
interpol_check_input(data,funame):=
 block([n,out],
   if not listp(data) and not matrixp(data)
      then error("Argument to '",funame,"' must be a list or matrix"),
   n: length(data),
   if n<2
      then error("Argument to '",funame,"' has too few sample points")
   elseif listp(data) and every('identity,map(lambda([x], listp(x) and length(x)=2),data))
      then out: sort(data)
   elseif matrixp(data) and length(data[1]) = 2
      then out: sort(args(data))
   elseif listp(data) and every('identity,map(lambda([x], not listp(x)),data)) 
      then out: makelist([i,data[i]],i,1,n)
      else error("Error in arguments to '",funame,"' function"),
   /* controlling duplicated x's */
   for i:2 thru n do
      if out[i-1][1] = out[i][1]
         then error("Duplicated abscissas are not allowed"),
   out )$



/* Lagrangian interpolation. The argument must be either:                      */
/*  a) a two column matrix, p:matrix([2,4],[5,6],[9,3])                        */
/*  b) a list of pairs, p: [[2,4],[5,6],[9,3]]                                 */
/*  c) a list of numbers, p: [4,6,3], in which case the abscissas will be      */
/*     assigned automatically to 1, 2, 3, etc.                                 */
/* In cases a) and b) the pairs are ordered wrt the 1st. coordinate before any */
/* computation is made. Option:                                                */
/*   'varname='x: the name of the independent variable                         */
/* Sample session:                                                             */
/* load(interpol);                                                             */
/* p:[[7,2],[8,2],[1,5],[3,2],[6,7]]$                                          */
/* lagrange(p);                                                                */
/* f(x):=''%;                                                                  */
/* map(f,[2.3,5/7,%pi]);                                                       */
/* load(draw)$;                                                                */
/* draw2d(                                                                     */
/*    explicit(f(x),x,0,9),                                                    */
/*    point_size = 3,                                                          */
/*    points(p)) $                                                             */
lagrange(tab,[select]) := block([n,sum:0,prod,options,defaults,ratprint:false,tab2],
   tab2: interpol_check_input(tab,"lagrange"),
   options:  ['varname],
   defaults: ['x],
   for i in select do(
      aux: ?position(lhs(i),options),
      if numberp(aux) and aux <= length(options) and aux >= 1
        then defaults[aux]: rhs(i)),
   if not symbolp(defaults[1])
      then error("Option 'varname' is not correct"),

   /* constructing the interpolating polynomial */
   n: length(tab2),
   for i:1 thru n do(
      prod: 1,
      for k:1 thru n do
         if k#i then prod: prod * (defaults[1]-tab2[k][1]) / (tab2[i][1]-tab2[k][1]),
      sum: sum + prod * tab2[i][2] ),
   sum )$



/* Characteristic function for intervals. Returns true iif  */
/* z belongs to [l1, l2). This is an auxiliary function to  */
/* be called from linearinterpol and cspline                */
charfun2(z,l1,l2):= charfun(l1 <= z and z < l2)$



/* Linear interpolation. The argument must be either:                          */
/*  a) a two column matrix, p:matrix([2,4],[5,6],[9,3])                        */
/*  b) a list of pairs, p: [[2,4],[5,6],[9,3]]                                 */
/*  c) a list of numbers, p: [4,6,3], in which case the abscissas will be      */
/*     assigned automatically to 1, 2, 3, etc.                                 */
/* In cases a) and b) the pairs are ordered wrt the 1st. coordinate before any */
/* computation is made. Option:                                                */
/*   'varname='x: the name of the independent variable                         */
/* Sample session:                                                             */
/* load(interpol);                                                             */
/* p:[[7,2],[8,2],[1,5],[3,2],[6,7]]$                                          */
/* linearinterpol(p);                                                          */
/* f(x):=''%;                                                                  */
/* map(f,[2.3,5/7,%pi]);                                                       */
/* load(draw)$;                                                                */
/* draw2d(                                                                     */
/*    explicit(f(x),x,0,9),                                                    */
/*    point_size = 3,                                                          */
/*    points(p)) $                                                             */
linearinterpol(tab,[select]) := block([n,s:0,a,b,options, defaults,ratprint:false,tab2],
   tab2: interpol_check_input(tab,"linearinterpol"),
   options:  ['varname],
   defaults: ['x],
   for i in select do(
      aux: ?position(lhs(i),options),
      if numberp(aux) and aux <= length(options) and aux >= 1
        then defaults[aux]: rhs(i)),
   if not symbolp(defaults[1])
      then error("Option 'varname' is not correct"),

   /* constructing the interpolating polynomial */
   n: length(tab2),
   if n=2 /* case of two points */
      then s: tab2[2][2] + (tab2[2][2]-tab2[1][2]) *
                          (defaults[1]-tab2[2][1]) /
                          (tab2[2][1]-tab2[1][1])
      else for i:2 thru n do(
               if i=2
                  then (a: 'minf, b: tab2[i][1])
                  else if i=n
                          then (a: tab2[i-1][1], b: 'inf)
                          else (a: tab2[i-1][1], b: tab2[i][1]),
               s: s + apply('charfun2,[defaults[1], a, b]) *
                      expand( tab2[i][2] + (tab2[i][2]-tab2[i-1][2]) *
                                    (defaults[1]-tab2[i][1]) /
                                    (tab2[i][1]-tab2[i-1][1]) )   ),
   s )$



/* Cubic splines interpolation. The argument must be either:                           */
/*  a) a two column matrix, p:matrix([2,4],[5,6],[9,3])                                */
/*  b) a list of pairs, p: [[2,4],[5,6],[9,3]]                                         */
/*  c) a list of numbers, p: [4,6,3], in which case the abscissas will be              */
/*     assigned automatically to 1, 2, 3, etc.                                         */
/* In cases a) and b) the pairs are ordered wrt the 1st. coordinate before any         */
/* computation is made. Options:                                                       */
/*   'd1='unknown: 1st derivative at x_1; if it is 'unknown, the second derivative     */
/*         at x_1 is made equal to 0 (natural cubic spline); if it is equal to a       */
/*         number, the second derivative is estimated based on this number             */
/*   'd2='unknown: 1st derivative at x_n; if it is 'unknown, the second derivative     */
/*         at x_n is made equal to 0 (natural cubic spline); if it is equal to a       */
/*         number, the second derivative is estimated based on this number             */
/*   'varname='x: the name of the independent variable                                 */
/* Reference: this algorithm is based on 'Numerical Recipes in C', section 3.3         */
/* Sample session:                                                                     */
/* load(interpol);                                                                     */
/* p:[[7,2],[8,2],[1,5],[3,2],[6,7]]$                                                  */
/* cspline(p); ==> natural cubic spline (second derivatives are zero in both extremes) */
/* f(x):=''%;                                                                          */
/* map(f,[2.3,5/7,%pi]);                                                               */
/* load(draw)$;                                                                        */
/* draw2d(                                                                             */
/*    explicit(f(x),x,0,9),                                                            */
/*    point_size = 3,                                                                  */
/*    points(p)) $                                                                     */
/* cspline(p,d1=0,dn=0);                                                               */
/* g(x):=''%;                                                                          */
/* draw2d(                                                                             */
/*    explicit(g(x),x,0,9),                                                            */
/*    point_size = 3,                                                                  */
/*    points(p)) $                                                                     */
cspline(tab,[select]):= block([options, defaults, n, aux, y2, u, sig, p,
                               qn, un, a, b, s:0, aj, bj, cj, dj, ratprint:false,tab2],
   tab2: interpol_check_input(tab,"cspline"),
   options:  ['d1, 'dn, 'varname],
   defaults: ['unknown, 'unknown, 'x],
   for i in select do(
      aux: ?position(lhs(i),options),
      if numberp(aux) and aux <= length(options) and aux >= 1
        then defaults[aux]: rhs(i)),
   if not numberp(defaults[1]) and  defaults[1] # 'unknown
      then error("Option 'd1' is not correct"),
   if not numberp(defaults[2]) and  defaults[2] # 'unknown
      then error("Option 'dn' is not correct"),
   if not symbolp(defaults[3])
      then error("Option 'varname' is not correct"),

   /* if tab2 contains only two points, linear interpolation */
   n: length(tab2),
   if n=2 /* case of two points */
      then return(ratsimp( tab2[2][2] + (tab2[2][2]-tab2[1][2]) *
                                       (defaults[3]-tab2[2][1]) /
                                       (tab2[2][1]-tab2[1][1]))),


   /* constructing the interpolating polynomial */
   y2: makelist(0,i,1,n),
   u: makelist(0,i,1,n-1),

   /* controlling the lower boundary condition */
   if /*d1*/ defaults[1] = 'unknown
      then (y2[1]: 0,
            u[1]: 0)
      else (y2[1]: -1/2,
            u[1]: 3 / (tab2[2][1]-tab2[1][1]) *
                      ((tab2[2][2] - tab2[1][2])/(tab2[2][1] - tab2[1][1]) - defaults[1]) ),

   /* decomposition loop of the triangular algorithm */
   for i:2 thru n-1 do (
      sig: (tab2[i][1] - tab2[i-1][1]) / (tab2[i+1][1] - tab2[i-1][1]),
      p: sig * y2[i-1] + 2,
      y2[i]: (sig - 1) / p,
      u[i]: (tab2[i+1][2] - tab2[i][2]) /(tab2[i+1][1] - tab2[i][1]) -
            (tab2[i][2] - tab2[i-1][2]) /(tab2[i][1] - tab2[i-1][1]),
      u[i]: (6 * u[i] / (tab2[i+1][1] - tab2[i-1][1]) - sig * u[i-1]) / p ) ,

   /* controlling the upper boundary condition */
   if /*dn*/ defaults[2] = 'unknown
      then (qn: 0,
            un: 0)
      else (qn: 1/2,
            un: 3 / (tab2[n][1] - tab2[n-1][1]) *
                (defaults[2] - (tab2[n][2] - tab2[n-1][2]) / (tab2[n][1] - tab2[n-1][1]))),
   y2[n]: (un - qn * u[n-1]) / (qn * y2[n-1] + 1),

   /* backsubstitution loop of the tridiagonal algorithm */
   for k: n-1 thru 1 step -1 do
      y2[k]: y2[k] * y2[k+1] + u[k],

   /* constructing the cubic splines */
   for j:2 thru n do (
      if j=2
          then (a: 'minf, b: tab2[j][1] )
          else if j=n
                  then (a: tab2[j-1][1], b: 'inf)
                  else (a: tab2[j-1][1], b: tab2[j][1]),
      /* in the following sentences, defaults[3] is variable's name */
      aux: (tab2[j][1] - tab2[j-1][1]),
      aj: (tab2[j][1] - defaults[3]) / aux,
      bj: (defaults[3] - tab2[j-1][1]) / aux,
      aux: aux * aux /6,
      cj: (aj^3 - aj) * aux,
      dj: (bj^3 - bj) * aux,

      s: s + charfun2(defaults[3], a, b) *
             expand(aj * tab2[j-1][2] + bj * tab2[j][2] + cj * y2[j-1] + dj * y2[j])  ),
   s )$



/* Rational interpolation, with interpolating function of the form             */
/*               r                                                             */
/*           p  x  + ... + p  x + p                                            */
/*            r             1      0                                           */
/*    R(x) = ------------------------                                          */
/*               m                                                             */
/*           q  x  + ... + q  x + q                                            */
/*            m             1      0                                           */
/* The 2nd. argument r is the degree of the numerator (r < sample size). The   */
/* degree of the denominator is calculated as m: sample_size - r - 1.          */
/* The 1st. argument must be either:                                           */
/*  a) a two column matrix, p:matrix([2,4],[5,6],[9,3])                        */
/*  b) a list of pairs, p: [[2,4],[5,6],[9,3]]                                 */
/*  c) a list of numbers, p: [4,6,3], in which case the abscissas will be      */
/*     assigned automatically to 1, 2, 3, etc.                                 */
/* In cases a) and b) the pairs are ordered wrt the 1st. coordinate before any */
/* computation is made. Option:                                                */
/*   'varname='x: the name of the independent variable                         */
/* Sample session:                                                             */
/* load(interpol)$                                                             */
/* load(draw)$                                                                 */
/* p: [[7.2, 2.5], [8.5, 2.1], [1.6, 5.1], [3.4, 2.4], [6.7, 7.9]]$            */
/* for k:0 thru length(p)-1 do                                                 */
/*   draw2d(explicit(ratinterpol(p,k),x,0,9),                                  */
/*          point_size = 3,                                                    */
/*          points(p),                                                         */
/*          title = concat("Degree of numerator = ",k),                        */
/*          yrange=[0,10])$                                                    */
ratinterpol(tab,r,[select]) :=
  block([n,m,coef,unk,sol,lovtab,lov,options,defaults,ratprint:false,tab2],
    tab2: interpol_check_input(tab,"ratinterpol"),
    options:  ['varname],
    defaults: ['x],
    for i in select do(
       aux: ?position(lhs(i),options),
       if numberp(aux) and aux <= length(options) and aux >= 1
         then defaults[aux]: rhs(i)),
    if not symbolp(defaults[1])
       then error("Option 'varname' is not correct"),

    /* constructing the interpolating rational function */
    n: length(tab2),
    if not integerp(r) or r > n-1 or r < 0
      then error("Degree of numerator must be a positive integer less than sample size"),
    m: n - r - 1, /* degree of denominator */

    /* coef is the matrix of an homogeneous linear system */
    coef: apply(matrix,
                makelist(block([x,y],
                           [x,y]: p,
                           append([1],
                                  makelist(x^k,k,1,r),
                                  [-y],
                                  makelist(-y*x^k,k,1,m))),
                         p, tab2)),
    unk: makelist(gensym(), k, r+m+2),
    sol: map(last, linsolve(flatten(args(coef.unk)),unk)),
    lovtab : listofvars(tab2),
    lov: listofvars(sol),
    lov: listify(setdifference(setify(lov),setify(lovtab))),
    sol: subst(map(lambda([z1,z2], z1=z2), lov, makelist(1, k, length(lov))), sol),
    makelist(sol[k],k,1,r+1) . makelist(defaults[1]^k,k,0,r) / 
        makelist(sol[k],k,r+2,r+2+m) . makelist(defaults[1]^k,k,0,m) )$

