## Copyright (C) 2000, 2001 Kai Habel
##
## 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 3 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.
##
## You should have received a copy of the GNU General Public License along with
## this program; if not, see <http://www.gnu.org/licenses/>.

## -*- texinfo -*-
## @deftypefn {Function File} {@var{pp} = } csape (@var{x}, @var{y}, @var{cond}, @var{valc})
## cubic spline interpolation with various end conditions.
## creates the pp-form of the cubic spline.
##
## @var{x} should be @var{n} by 1, @var{y} should be @var{n} by @var{m}, 
## @var{valc} should be 2 by @var{m} or 2 by 1
##
## The following end conditions as given in @var{cond} are possible:
## @table @asis
## @item 'complete'    
##    match slopes at first and last point as given in @var{valc}
##    (default; if @var{valc} is not given, the slopes matched are those 
##    of the cubic polynomials that interpolate the first and last four points)
## @item 'not-a-knot'     
##    third derivatives are continuous at the second and second last point
## @item 'periodic' 
##    match first and second derivative of first and last point
## @item 'second'
##    match second derivative at first and last point as given in @var{valc}
## @item 'variational'
##    set second derivative at first and last point to zero (natural cubic spline)
## @end table
##
## @seealso{ppval, spline}
## @end deftypefn

## Author:  Kai Habel <kai.habel@gmx.de>
## Date: 23 Nov 2000
## Algorithms taken from G. Engeln-Muellges, F. Uhlig:
## "Numerical Algorithms with C", Springer, 1996

function pp = csape (x, y, cond, valc)

  x = x(:);
  n = length(x);
  if (n < 3) 
    error ("csape requires at least 3 points");
  endif

  ## Check the size and shape of y
  ndy = ndims (y);
  szy = size (y);
  if (ndy == 2 && (szy(1) == n || szy(2) == n))
    if (szy(2) == n)
      a = y.';
    else
      a = y;
      szy = fliplr (szy);
    endif
  else
    a = shiftdim (reshape (y, [prod(szy(1:end-1)), szy(end)]), 1);
  endif
  m = size (a, 2);

  if exist("valc", "var") && size(valc) == [1 2]
    valc = valc';
  endif

  b = c = zeros (n, m);
  h = diff (x);
  idx = ones (columns(a),1);

  if (nargin < 3 || strcmp(cond,"complete"))

    # set first derivative at end points
    if (nargin < 4)
      valc = zeros(2, m);
      n_use = min(n, 4);
      for i = 1:m
        valc(1, i) = polyval(polyder(polyfit(x(1:n_use), a(1:n_use, i), n_use-1)), x(1));
        valc(2, i) = polyval(polyder(polyfit(x(end-n_use+1:end), a(end-n_use+1:end, i), n_use-1)), x(end));
      endfor
    endif

    if (n == 3)
      warning ("off", "Octave:broadcast", "local");
      e = 2 * [h(1) h(1:(end-1))+h(2:end) h(end)];
      A = spdiags([[h; 0], e(:), [0; h]], [-1,0,1], n, n);
      d = diff(a) ./ h; #uses broadcasting if columns(a) > 1
      g = 3 * diff(d);
      A(1, 1) = 2 * h(1);
      A(1, 2) = h(1);
      A(n, n) = 2 * h(end);
      A(end, end-1) = h(end);
      g = [3*(d(1, :) - valc(1, :)); g; 3*(valc(2, :) - d(end, :))];
      c = A \ g;
    else
      dg = 2 * (h(1:n - 2) + h(2:n - 1));
      dg(1) = dg(1) - 0.5 * h(1);
      dg(n - 2) = dg(n-2) - 0.5 * h(n - 1);

      e = h(2:n - 2);

      g = 3 * diff (a(2:n,:)) ./ h(2:n - 1,idx)...
        - 3 * diff (a(1:n - 1,:)) ./ h(1:n - 2,idx);
      g(1,:) = 3 * (a(3,:) - a(2,:)) / h(2) ...
          - 3 / 2 * (3 * (a(2,:) - a(1,:)) / h(1) - valc(1,:));
      g(n - 2,:) = 3 / 2 * (3 * (a(n,:) - a(n - 1,:)) / h(n - 1) - valc(2,:))...
          - 3 * (a(n - 1,:) - a(n - 2,:)) / h(n - 2);

      c(2:n - 1,:) = spdiags([[e(:);0],dg,[0;e(:)]],[-1,0,1],n-2,n-2) \ g;
      
      c(1,:) = (3 / h(1) * (a(2,:) - a(1,:)) - 3 * valc(1, :) - c(2,:) * h(1)) / (2 * h(1));
      c(n,:) = - (3 / h(n - 1) * (a(n,:) - a(n - 1,:)) - 3 * valc(2, :) + c(n - 1,:) * h(n - 1)) / (2 * h(n - 1));
    end
    b(1:n - 1,:) = diff (a) ./ h(1:n - 1, idx)...
      - h(1:n - 1,idx) / 3 .* (c(2:n,:) + 2 * c(1:n - 1,:));
    d = diff (c) ./ (3 * h(1:n - 1, idx));

  elseif (strcmp(cond,"variational") || strcmp(cond,"second"))

    if ((nargin < 4) || strcmp(cond,"variational"))
      ## set second derivatives at end points to zero
      valc = zeros (2, 1);
    endif

    c(1,:) = valc(1, :) / 2;
    c(n,:) = valc(2, :) / 2;

    g = 3 * diff (a(2:n,:)) ./ h(2:n - 1, idx)...
      - 3 * diff (a(1:n - 1,:)) ./ h(1:n - 2, idx);

    g(1,:) = g(1,:) - h(1) * c(1,:);
    g(n - 2,:) = g(n-2,:) - h(n - 1) * c(n,:);

    dg = 2 * (h(1:n - 2) + h(2:n - 1));
    e = h(2:n - 2);
    c(2:n - 1,:) = spdiags([[e(:);0],dg,[0;e(:)]],[-1,0,1],n-2,n-2) \ g;
        
    b(1:n - 1,:) = diff (a) ./ h(1:n - 1,idx)...
      - h(1:n - 1,idx) / 3 .* (c(2:n,:) + 2 * c(1:n - 1,:));
    d = diff (c) ./ (3 * h(1:n - 1, idx));
  
  elseif (strcmp(cond,"periodic"))
  
    D = diff(a) ./ h;
    A = sparse (n-1);
    v = zeros (n-1, m);
    for i = 2:(n-2)
      A(i, i-1) = h(i-1);
      A(i, i) = 2 * (h(i-1) + h(i));
      A(i, i+1) = h(i);
      v(i, :) = 3 * (D(i, :) - D(i-1, :));
    endfor
    A(1, 1) = 2 * (h(1) + h(n-1));
    A(1, 2) = h(1);
    A(1, n-1) += h(n-1);
    v(1, :) = 3 * (D(1, :) - D(n-1, :));
    A(n-1, 1) = h(n-1);
    A(n-1, n-2) += h(n-2);
    A(n-1, n-1) = 2 * (h(n-2) + h(n-1));
    v(n-1, :) = 3 * (D(n-1, :) - D(n-2, :));
    c = A \ v; #this is a cyclic tridiagonal system -- the Sherwood-Morrison formula
               #could be used to solve it if \ is too slow in this case
    
    c(n,:) = c(1,:);
    b = diff (a) ./ h(1:n - 1,idx)...
      - h(1:n - 1,idx) / 3 .* (c(2:n,:) + 2 * c(1:n - 1,:));
    b(n,:) = b(1,:);
    d = diff (c) ./ (3 * h(1:n - 1, idx));
    d(n,:) = d(1,:);

  elseif (strcmp(cond,"not-a-knot"))

    g = zeros(n - 2,columns(a));
    g(1,:) = 3 / (h(1) + h(2)) * (a(3,:) - a(2,:)...
          - h(2) / h(1) * (a(2,:) - a(1,:)));
    g(n - 2,:) = 3 / (h(n - 1) + h(n - 2)) *...
        (h(n - 2) / h(n - 1) * (a(n,:) - a(n - 1,:)) -...
         (a(n - 1,:) - a(n - 2,:)));

    if (n > 4)

      g(2:n - 3,:) = 3 * diff (a(3:n - 1,:)) ./ h(3:n - 2,idx)...
        - 3 * diff (a(2:n - 2,:)) ./ h(2:n - 3,idx);

      dg = 2 * (h(1:n - 2) + h(2:n - 1));
      dg(1) = dg(1) - h(1);
      dg(n - 2) = dg(n-2) - h(n - 1);

      ldg = udg = h(2:n - 2);
      udg(1) = udg(1) - h(1);
      ldg(n - 3) = ldg(n-3) - h(n - 1);
      c(2:n - 1,:) = spdiags([[ldg(:);0],dg,[0;udg(:)]],[-1,0,1],n-2,n-2) \ g;

    elseif (n == 4)

      dg = [h(1) + 2 * h(2); 2 * h(2) + h(3)];
      ldg = h(2) - h(3);
      udg = h(2) - h(1);
      c(2:n - 1,:) = spdiags([[ldg(:);0],dg,[0;udg(:)]],[-1,0,1],n-2,n-2) \ g;
      
    else # n == 3
    #with only 3 points, the not-a-knot cubic spline is not unique;
    #we choose the one where the cubic coefficients are zero,
    #which is the interpolating quadratic polynomial
      c = repmat ((a(1,:) - a(3,:)) / ((x(3) - x(1)) * (x(2) - x(3))) ...
          + (a(2,:) - a(1,:)) / ((x(2) - x(1)) * (x(2) - x(3))), [3 1]);
    endif
    if n == 3
      d = zeros (n, m);
    else
      c(1,:) = c(2,:) + h(1) / h(2) * (c(2,:) - c(3,:));
      c(n,:) = c(n - 1,:) + h(n - 1) / h(n - 2) * (c(n - 1,:) - c(n - 2,:));
      d = diff (c) ./ (3 * h(1:n - 1, idx));
    endif
    b = diff (a) ./ h(1:n - 1, idx)...
      - h(1:n - 1, idx) / 3 .* (c(2:n,:) + 2 * c(1:n - 1,:));
  else
    msg = sprintf("unknown end condition: %s",cond);
    error (msg);
  endif

  d = d(1:n-1,:); c=c(1:n-1,:); b=b(1:n-1,:); a=a(1:n-1,:);
  pp = mkpp (x, cat (2, d'(:), c'(:), b'(:), a'(:)), szy(1:end-1));

endfunction


%!shared x,x2,y,cond,pp,pp1,pp2,h,valc,xi,yi
%! x = linspace(0,2*pi,5); y = sin(x); x2 = linspace(0,2*pi,16);

%!assert (ppval(csape(x,y),x), y, 10*eps);
%!assert (ppval(csape(x,y),x'), y', 10*eps);
%!assert (ppval(csape(x',y'),x'), y', 10*eps);
%!assert (ppval(csape(x',y'),x), y, 10*eps);
%!assert (ppval(csape(x,[y;y]),x), ...
%!        [ppval(csape(x,y),x);ppval(csape(x,y),x)], 10*eps)
%!assert (ppval(csape(x,[y;y]),x2),  ...
%!        [ppval(csape(x,y),x2);ppval(csape(x,y),x2)], 10*eps)
%!assert (ppval(csape([1 2 4],[2, 3, 6]), 3), 13/3, 10*eps);

%!test cond='complete';
%!assert (ppval(csape(x,y,cond),x), y, 10*eps);
%!assert (ppval(csape(x,y,cond),x'), y', 10*eps);
%!assert (ppval(csape(x',y',cond),x'), y', 10*eps);
%!assert (ppval(csape(x',y',cond),x), y, 10*eps);
%!assert (ppval(csape(x,[y;y],cond),x),  ...
%!        [ppval(csape(x,y,cond),x);ppval(csape(x,y,cond),x)], 10*eps)
%!assert (ppval(csape(x,[y;y],cond),x2),  ...
%!        [ppval(csape(x,y,cond),x2);ppval(csape(x,y,cond),x2)], 10*eps)
%!assert (ppval(csape([1 2 4],[2, 3, 6], cond, [2 1]), 3), 215/48, 10*eps);

%!test cond='variational';
%!assert (ppval(csape(x,y,cond),x), y, 10*eps);
%!assert (ppval(csape(x,y,cond),x'), y', 10*eps);
%!assert (ppval(csape(x',y',cond),x'), y', 10*eps);
%!assert (ppval(csape(x',y',cond),x), y, 10*eps);
%!assert (ppval(csape(x,[y;y],cond),x),  ...
%!        [ppval(csape(x,y,cond),x);ppval(csape(x,y,cond),x)], 10*eps)
%!assert (ppval(csape(x,[y;y],cond),x2),  ...
%!        [ppval(csape(x,y,cond),x2);ppval(csape(x,y,cond),x2)], 10*eps)
%!assert (ppval(csape([1 2 3],[2, 3, 5],cond), 1.5), 2.40625, 10*eps);
%!assert (ppval(csape([1 2 4],[2, 3, 6], cond), 3), 4.375, 10*eps);

%!test cond='second';
%!assert (ppval(csape(x,y,cond),x), y, 10*eps);
%!assert (ppval(csape(x,y,cond),x'), y', 10*eps);
%!assert (ppval(csape(x',y',cond),x'), y', 10*eps);
%!assert (ppval(csape(x',y',cond),x), y, 10*eps);
%!assert (ppval(csape(x,[y;y],cond),x),  ...
%!        [ppval(csape(x,y,cond),x);ppval(csape(x,y,cond),x)], 10*eps)
%!assert (ppval(csape(x,[y;y],cond),x2),  ...
%!        [ppval(csape(x,y,cond),x2);ppval(csape(x,y,cond),x2)], 10*eps)
%!assert (ppval(csape([1 2 4],[2, 3, 6], cond, [1 2]), 3), 49/12, 10*eps);

%!test cond='periodic';
%!assert (ppval(csape(x,y,cond),x), y, 10*eps);
%!assert (ppval(csape(x,y,cond),x'), y', 10*eps);
%!assert (ppval(csape(x',y',cond),x'), y', 10*eps);
%!assert (ppval(csape(x',y',cond),x), y, 10*eps);
%!assert (ppval(csape(x,[y;y],cond),x),  ...
%!        [ppval(csape(x,y,cond),x);ppval(csape(x,y,cond),x)], 10*eps)
%!assert (ppval(csape(x,[y;y],cond),x2),  ...
%!        [ppval(csape(x,y,cond),x2);ppval(csape(x,y,cond),x2)], 10*eps)

%!test cond='not-a-knot';
%!assert (ppval(csape(x,y,cond),x), y, 10*eps);
%!assert (ppval(csape(x,y,cond),x'), y', 10*eps);
%!assert (ppval(csape(x',y',cond),x'), y', 10*eps);
%!assert (ppval(csape(x',y',cond),x), y, 10*eps);
%!assert (ppval(csape(x,[y;y],cond),x),  ...
%!        [ppval(csape(x,y,cond),x);ppval(csape(x,y,cond),x)], 10*eps)
%!assert (ppval(csape(x,[y;y],cond),x2),  ...
%!        [ppval(csape(x,y,cond),x2);ppval(csape(x,y,cond),x2)], 10*eps)
%!assert (ppval(csape(x(1:4),y(1:4),cond),x(1:4)), y(1:4), 10*eps);
%!assert (ppval(csape(x(1:4)',y(1:4)',cond),x(1:4)), y(1:4), 10*eps);
%!test assert (ppval(csape([1 2 4],[2, 3, 6], 'not-a-knot'), 3), 13/3, 10*eps);
%!test assert (ppval(csape([1 2 4 5],[2, 3, 6, 5], 'not-a-knot'), 3), 29/6, 10*eps);
%!test assert (ppval(csape([1 2 4 5 6],[2, 3, 6, 5, 6], 'not-a-knot'), 3), 141/28, 10*eps);

%!test cond='complete';
%! h = pi/6; n = 3; x = linspace(0,(n-1)*h,n)'; y = sin(x); valc = cos([x(1) x(end)]); pp = csape(x, y, cond, valc);
%!assert (ppval(csape(x,[y y],cond, valc),x)',  ...
%!        repmat(ppval(pp, x), [1 2]), 10*eps)
%!assert (polyval(pp.coefs(1, :), [0 h])', y(1:2), 10*eps)
%!assert (polyval(pp.coefs(2, :), [0 h])', y(2:3), 10*eps)
%!assert (polyval([3*pp.coefs(1, 1) 2*pp.coefs(1, 2) pp.coefs(1, 3)], 0), valc(1), 10*eps)
%!assert (polyval([3*pp.coefs(2, 1) 2*pp.coefs(2, 2) pp.coefs(2, 3)], h), valc(2), 10*eps)
%!assert (polyval([3*pp.coefs(1, 1) 2*pp.coefs(1, 2) pp.coefs(1, 3)], h), polyval([3*pp.coefs(2, 1) 2*pp.coefs(2, 2) pp.coefs(2, 3)], 0), 10*eps)
%!assert (polyval([6*pp.coefs(1, 1) 2*pp.coefs(1, 2)], h), polyval([6*pp.coefs(2, 1) 2*pp.coefs(2, 2)], 0), 10*eps)
%! y = cos(x); valc = -sin([x(1) x(end)]); pp1 = csape(x, y, cond, valc);
%!assert (ppval(csape(x,[y y],cond, valc),x)',  ...
%!        repmat(ppval(pp1, x), [1 2]), 10*eps)
%!assert (polyval(pp1.coefs(1, :), [0 h])', y(1:2), 10*eps)
%!assert (polyval(pp1.coefs(2, :), [0 h])', y(2:3), 10*eps)
%!assert (polyval([3*pp1.coefs(1, 1) 2*pp1.coefs(1, 2) pp1.coefs(1, 3)], 0), valc(1), 10*eps)
%!assert (polyval([3*pp1.coefs(2, 1) 2*pp1.coefs(2, 2) pp1.coefs(2, 3)], h), valc(2), 10*eps)
%!assert (polyval([3*pp1.coefs(1, 1) 2*pp1.coefs(1, 2) pp1.coefs(1, 3)], h), polyval([3*pp1.coefs(2, 1) 2*pp1.coefs(2, 2) pp1.coefs(2, 3)], 0), 10*eps)
%!assert (polyval([6*pp1.coefs(1, 1) 2*pp1.coefs(1, 2)], h), polyval([6*pp1.coefs(2, 1) 2*pp1.coefs(2, 2)], 0), 10*eps)
%! y = [sin(x) cos(x)]; valc = [cos([x(1); x(end)]) -sin([x(1); x(end)])]; pp2 = csape(x, y, cond, valc);
%!assert (pp2.coefs([1 3], :), pp.coefs)
%!assert (pp2.coefs([2 4], :), pp1.coefs)

# more tests of correctness for periodic boundary conditions
%!test cond='periodic';
%! x = [1 2 4 5 6]'; y = [2 3 6 5 6]'; xi = 3; yi = 129/26; pp = csape (x, y, cond);
%!assert (ppval(pp, x), y, 10*eps);
%!assert (ppval(pp, xi), yi, 10*eps);
%!assert (ppval(ppder(pp), x(1)), ppval(ppder(pp), x(end)), 10*eps);
%!assert (ppval(ppder(pp, 2), x(1)), ppval(ppder(pp, 2), x(end)), 10*eps);
%! x = [1 2 4 6]'; y = [2 3 4 2]'; xi = 3; yi = 4 + 1/64; pp = csape (x, y, cond);
%!assert (ppval(pp, x), y, 10*eps);
%!assert (ppval(pp, xi), yi, 10*eps);
%!assert (ppval(ppder(pp), x(1)), ppval(ppder(pp), x(end)), 10*eps);
%!assert (ppval(ppder(pp, 2), x(1)), ppval(ppder(pp, 2), x(end)), 10*eps);
%! x = [1 2 4 5]'; y = [2 3 6 5]'; xi = 3; yi = 5.1; pp = csape (x, y, cond);
%!assert (ppval(pp, x), y, 10*eps);
%!assert (ppval(pp, xi), yi, 10*eps);
%!assert (ppval(ppder(pp), x(1)), ppval(ppder(pp), x(end)), 10*eps);
%!assert (ppval(ppder(pp, 2), x(1)), ppval(ppder(pp, 2), x(end)), 10*eps);
%! x = [1 2 4]'; y = [2 3 2]'; xi = 3; yi = 2.5; pp = csape (x, y, cond);
%!assert (ppval(pp, x), y, 10*eps);
%!assert (ppval(pp, xi), yi, 10*eps);
%!assert (ppval(ppder(pp), x(1)), ppval(ppder(pp), x(end)), 10*eps);
%!assert (ppval(ppder(pp, 2), x(1)), ppval(ppder(pp, 2), x(end)), 10*eps);
