Interpolation.hs

{-# LANGUAGE ParallelListComp #-}
module Math.Polynomial.Interpolation where

import Math.Polynomial
import Math.Polynomial.Lagrange
import Data.List

-- |Evaluate a polynomial passing through the specified set of points.  The
-- order of the interpolating polynomial will (at most) be one less than 
-- the number of points given.
polyInterp :: Fractional a => [(a,a)] -> a -> a
polyInterp xys = head . last . neville xys

-- |Computes the tableau generated by Neville's algorithm.  Each successive
-- row of the table is a list of interpolants one order higher than the previous,
-- using a range of input points starting at the same position in the input
-- list as the interpolant's position in the output list.
neville :: Fractional a => [(a,a)] -> a -> [[a]]
neville xys x = table
    where
        (xs,ys) = unzip xys
        table = ys :
            [ [ ((x - x_j) * p1 + (x_i - x) * p0) / (x_i - x_j)
              | p0:p1:_ <- tails row
              | x_j     <- xs
              | x_i     <- x_is
              ]
            | row  <- table
            | x_is <- tail (tails xs)
            , not (null x_is)
            ]

-- |Computes the tableau generated by a modified form of Neville's algorithm
-- described in Numerical Recipes, Ch. 3, Sec. 2, which records the differences
-- between interpolants at each level.  Each pair (c,d) is the amount to add
-- to the previous level's interpolant at either the same or the subsequent
-- position (respectively) in order to obtain the new level's interpolant.
-- Mathematically, either sum yields the same value, but due to numerical
-- errors they may differ slightly, and some \"paths\" through the table
-- may yield more accurate final results than others.
nevilleDiffs :: Fractional a => [(a,a)] -> a -> [[(a,a)]]
nevilleDiffs xys x = table
    where
        (xs,ys) = unzip xys
        table = zip ys ys :
            [ [ ( {-c-} (x_j - x) * (c1 - d0) / (x_j - x_i)
                , {-d-} (x_i - x) * (c1 - d0) / (x_j - x_i)
                )
              | (_c0,d0):(c1,_d1):_ <- tails row
              | x_j     <- xs
              | x_i     <- x_is
              ]
            | row  <- table
            | x_is <- tail (tails xs)
            , not (null x_is)
            ]

-- |Fit a polynomial to a set of points by iteratively evaluating the 
-- interpolated polynomial (using 'polyInterp') at 0 to establish the
-- constant coefficient and reducing the polynomial by subtracting that
-- coefficient from all y's and dividing by their corresponding x's.
-- 
-- Slower than 'lagrangePolyFit' but stable under different sets of 
-- conditions.
-- 
-- Note that computing the coefficients of a fitting polynomial is an 
-- inherently ill-conditioned problem.  In most cases it is both faster and 
-- more accurate to use 'polyInterp' or 'nevilleDiffs' instead of evaluating
-- a fitted polynomial.
iterativePolyFit :: (Fractional a, Eq a) => [(a,a)] -> Poly a
iterativePolyFit = poly LE . loop
    where
        loop  [] = []
        loop xys = c0 : loop (drop 1 xys')
            where
                c0   = polyInterp xys 0
                xys' = 
                    [ (x,(y - c0) / x)
                    | (x,y) <- xys
                    ]

-- |Fit a polynomial to a set of points using barycentric Lagrange polynomials.
-- 
-- Note that computing the coefficients of a fitting polynomial is an 
-- inherently ill-conditioned problem.  In most cases it is both faster and 
-- more accurate to use 'polyInterp' or 'nevilleDiffs' instead of evaluating
-- a fitted polynomial.
lagrangePolyFit :: (Fractional a, Eq a) => [(a,a)] -> Poly a
lagrangePolyFit xys = sumPolys
    [ scalePoly f (fst (contractPoly p x))
    | f <- zipWith (/) ys phis
    | x <- xs
    ]
    where
        (xs,ys) = unzip xys
        p = lagrange xs
        phis = map (snd . evalPolyDeriv p) xs