polynomial-0.7.2/0000755000000000000000000000000012516343153012074 5ustar0000000000000000polynomial-0.7.2/polynomial.cabal0000644000000000000000000000363612516343153015253 0ustar0000000000000000name: polynomial version: 0.7.2 stability: provisional cabal-version: >= 1.6 build-type: Simple author: James Cook maintainer: James Cook license: PublicDomain homepage: https://github.com/mokus0/polynomial category: Math, Numerical synopsis: Polynomials description: A type for representing polynomials, several functions for manipulating and evaluating them, and several interesting polynomial sequences. source-repository head type: git location: git://github.com/mokus0/polynomial.git Library ghc-options: -Wall -fno-warn-name-shadowing if impl(ghc >= 7.4) ghc-options: -fwarn-unsafe hs-source-dirs: src exposed-modules: Math.Polynomial Math.Polynomial.Bernstein Math.Polynomial.Bernoulli Math.Polynomial.Chebyshev Math.Polynomial.Hermite Math.Polynomial.Interpolation Math.Polynomial.Lagrange Math.Polynomial.Legendre Math.Polynomial.Newton Math.Polynomial.NumInstance Math.Polynomial.Type Math.Polynomial.VectorSpace other-modules: Data.List.ZipSum Data.VectorSpace.WrappedNum Math.Polynomial.Pretty build-depends: base >= 3 && <5, deepseq, vector, vector-space, vector-th-unbox >= 0.2.1 if impl(ghc < 7.10) build-depends: pretty < 1.1.2, prettyclass else build-depends: pretty >= 1.1.2 polynomial-0.7.2/Setup.lhs0000644000000000000000000000011612516343153013702 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain polynomial-0.7.2/src/0000755000000000000000000000000012516343153012663 5ustar0000000000000000polynomial-0.7.2/src/Data/0000755000000000000000000000000012516343153013534 5ustar0000000000000000polynomial-0.7.2/src/Data/List/0000755000000000000000000000000012516343153014447 5ustar0000000000000000polynomial-0.7.2/src/Data/List/ZipSum.hs0000644000000000000000000000111512516343153016230 0ustar0000000000000000module Data.List.ZipSum where import Data.AdditiveGroup -- like @zipWith (+)@ except that when the end of either list is -- reached, the rest of the output is the rest of the longer input list. zipSum :: Num t => [t] -> [t] -> [t] zipSum xs [] = xs zipSum [] ys = ys zipSum (x:xs) (y:ys) = (x+y) : zipSum xs ys -- like @zipWith (^+^)@ except that when the end of either list is -- reached, the rest of the output is the rest of the longer input list. zipSumV :: AdditiveGroup t => [t] -> [t] -> [t] zipSumV xs [] = xs zipSumV [] ys = ys zipSumV (x:xs) (y:ys) = (x^+^y) : zipSumV xs ys polynomial-0.7.2/src/Data/VectorSpace/0000755000000000000000000000000012516343153015752 5ustar0000000000000000polynomial-0.7.2/src/Data/VectorSpace/WrappedNum.hs0000644000000000000000000000200012516343153020360 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, TypeFamilies, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Data.VectorSpace.WrappedNum (WrappedNum(..)) where import Data.VectorSpace import qualified Data.Vector.Unboxed as U -- Template Haskell in GHC 7.4 requires these imports to bring -- the `Vector` and `MVector` classes into scope import qualified Data.Vector.Generic import qualified Data.Vector.Generic.Mutable import Data.Vector.Unboxed.Deriving newtype WrappedNum a = WrapNum { unwrapNum :: a } deriving (Eq, Ord, Read, Show, Bounded , Enum, Num, Fractional, Real, RealFrac , Floating, RealFloat) derivingUnbox "Wrapped" [t| (U.Unbox a) => WrappedNum a -> a |] [| unwrapNum |] [| \ a -> WrapNum a |] instance Num a => AdditiveGroup (WrappedNum a) where zeroV = 0 (^+^) = (+) negateV = negate instance Num a => VectorSpace (WrappedNum a) where type Scalar (WrappedNum a) = WrappedNum a (*^) = (*) polynomial-0.7.2/src/Math/0000755000000000000000000000000012516343153013554 5ustar0000000000000000polynomial-0.7.2/src/Math/Polynomial.hs0000644000000000000000000001471012516343153016236 0ustar0000000000000000{-# LANGUAGE ParallelListComp, ViewPatterns, FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Math.Polynomial ( Endianness(..) , Poly, poly, polyDegree , polyCoeffs, polyIsZero, polyIsOne , zero, one, constPoly, x , scalePoly, negatePoly , composePoly , addPoly, sumPolys, multPoly, powPoly , quotRemPoly, quotPoly, remPoly , evalPoly, evalPolyDeriv, evalPolyDerivs , contractPoly , monicPoly , gcdPoly, separateRoots , polyDeriv, polyDerivs, polyIntegral ) where import Math.Polynomial.Type import Math.Polynomial.Pretty ({- instance -}) import Math.Polynomial.VectorSpace (one, x) -- to re-export import qualified Math.Polynomial.VectorSpace as VS import Data.VectorSpace.WrappedNum -- |Given some constant 'k', construct the polynomial whose value is -- constantly 'k'. constPoly :: (Num a, Eq a) => a -> Poly a constPoly x = unwrapPoly (VS.constPoly (WrapNum x)) -- |Given some scalar 's' and a polynomial 'f', computes the polynomial 'g' -- such that: -- -- > evalPoly g x = s * evalPoly f x scalePoly :: (Num a, Eq a) => a -> Poly a -> Poly a scalePoly x f = unwrapPoly (VS.scalePoly (WrapNum x) (wrapPoly f)) -- |Given some polynomial 'f', computes the polynomial 'g' such that: -- -- > evalPoly g x = negate (evalPoly f x) negatePoly :: (Num a, Eq a) => Poly a -> Poly a negatePoly f = unwrapPoly (VS.negatePoly (wrapPoly f)) -- |Given polynomials 'f' and 'g', computes the polynomial 'h' such that: -- -- > evalPoly h x = evalPoly f x + evalPoly g x addPoly :: (Num a, Eq a) => Poly a -> Poly a -> Poly a addPoly p q = unwrapPoly (VS.addPoly (wrapPoly p) (wrapPoly q)) {-# RULES "sum Poly" forall ps. foldl addPoly zero ps = sumPolys ps #-} sumPolys :: (Num a, Eq a) => [Poly a] -> Poly a sumPolys ps = unwrapPoly (VS.sumPolys (map wrapPoly ps)) -- |Given polynomials 'f' and 'g', computes the polynomial 'h' such that: -- -- > evalPoly h x = evalPoly f x * evalPoly g x multPoly :: (Num a, Eq a) => Poly a -> Poly a -> Poly a multPoly p q = unwrapPoly (VS.multPolyWith (*) (wrapPoly p) (wrapPoly q)) -- |Given a polynomial 'f' and exponent 'n', computes the polynomial 'g' -- such that: -- -- > evalPoly g x = evalPoly f x ^ n powPoly :: (Num a, Eq a, Integral b) => Poly a -> b -> Poly a powPoly p n = unwrapPoly (VS.powPolyWith 1 (*) (wrapPoly p) n) -- |Given polynomials @a@ and @b@, with @b@ not 'zero', computes polynomials -- @q@ and @r@ such that: -- -- > addPoly (multPoly q b) r == a quotRemPoly :: (Fractional a, Eq a) => Poly a -> Poly a -> (Poly a, Poly a) quotRemPoly u v = (unwrapPoly q, unwrapPoly r) where ~(q, r) = VS.quotRemPolyWith (*) (/) (wrapPoly u) (wrapPoly v) quotPoly :: (Fractional a, Eq a) => Poly a -> Poly a -> Poly a quotPoly u v = unwrapPoly (VS.quotPolyWith (*) (/) (wrapPoly u) (wrapPoly v)) remPoly :: (Fractional a, Eq a) => Poly a -> Poly a -> Poly a remPoly u v = unwrapPoly (VS.remPolyWith (*) (/) (wrapPoly u) (wrapPoly v)) -- |@composePoly f g@ constructs the polynomial 'h' such that: -- -- > evalPoly h = evalPoly f . evalPoly g -- -- This is a very expensive operation and, in general, returns a polynomial -- that is quite a bit more expensive to evaluate than @f@ and @g@ together -- (because it is of a much higher order than either). Unless your -- polynomials are quite small or you are quite certain you need the -- coefficients of the composed polynomial, it is recommended that you -- simply evaluate @f@ and @g@ and explicitly compose the resulting -- functions. This will usually be much more efficient. composePoly :: (Num a, Eq a) => Poly a -> Poly a -> Poly a composePoly p q = unwrapPoly (VS.composePolyWith (*) (wrapPoly p) (wrapPoly q)) -- |Evaluate a polynomial at a point or, equivalently, convert a polynomial -- to the function it represents. For example, @evalPoly 'x' = 'id'@ and -- @evalPoly ('constPoly' k) = 'const' k.@ evalPoly :: (Num a, Eq a) => Poly a -> a -> a evalPoly f x = unwrapNum (VS.evalPoly (wrapPoly f) (WrapNum x)) -- |Evaluate a polynomial and its derivative (respectively) at a point. evalPolyDeriv :: (Num a, Eq a) => Poly a -> a -> (a,a) evalPolyDeriv f x = (unwrapNum y, unwrapNum y') where ~(y, y') = VS.evalPolyDeriv (wrapPoly f) (WrapNum x) -- |Evaluate a polynomial and all of its nonzero derivatives at a point. -- This is roughly equivalent to: -- -- > evalPolyDerivs p x = map (`evalPoly` x) (takeWhile (not . polyIsZero) (iterate polyDeriv p)) evalPolyDerivs :: (Num a, Eq a) => Poly a -> a -> [a] evalPolyDerivs f x = map unwrapNum (VS.evalPolyDerivs (wrapPoly f) (WrapNum x)) -- |\"Contract\" a polynomial by attempting to divide out a root. -- -- @contractPoly p a@ returns @(q,r)@ such that @q*(x-a) + r == p@ contractPoly :: (Num a, Eq a) => Poly a -> a -> (Poly a, a) contractPoly p a = (unwrapPoly q, unwrapNum r) where (q, r) = VS.contractPoly (wrapPoly p) (WrapNum a) -- |@gcdPoly a b@ computes the highest order monic polynomial that is a -- divisor of both @a@ and @b@. If both @a@ and @b@ are 'zero', the -- result is undefined. gcdPoly :: (Fractional a, Eq a) => Poly a -> Poly a -> Poly a gcdPoly a b = unwrapPoly (VS.gcdPolyWith 1 (*) (/) (wrapPoly a) (wrapPoly b)) -- |Normalize a polynomial so that its highest-order coefficient is 1 monicPoly :: (Fractional a, Eq a) => Poly a -> Poly a monicPoly p = unwrapPoly (VS.monicPolyWith 1 (/) (wrapPoly p)) -- |Compute the derivative of a polynomial. polyDeriv :: (Num a, Eq a) => Poly a -> Poly a polyDeriv p = unwrapPoly (VS.polyDeriv (wrapPoly p)) -- |Compute all nonzero derivatives of a polynomial, starting with its -- \"zero'th derivative\", the original polynomial itself. polyDerivs :: (Num a, Eq a) => Poly a -> [Poly a] polyDerivs p = map unwrapPoly (VS.polyDerivs (wrapPoly p)) -- |Compute the definite integral (from 0 to x) of a polynomial. polyIntegral :: (Fractional a, Eq a) => Poly a -> Poly a polyIntegral p = unwrapPoly (VS.polyIntegral (wrapPoly p)) -- |Separate a nonzero polynomial into a set of factors none of which have -- multiple roots, and the product of which is the original polynomial. -- Note that if division is not exact, it may fail to separate roots. -- Rational coefficients is a good idea. -- -- Useful when applicable as a way to simplify root-finding problems. separateRoots :: (Fractional a, Eq a) => Poly a -> [Poly a] separateRoots p | polyIsZero q = error "separateRoots: zero polynomial" | polyIsOne q = [p] | otherwise = p `quotPoly` q : separateRoots q where q = gcdPoly p (polyDeriv p) polynomial-0.7.2/src/Math/Polynomial/0000755000000000000000000000000012516343153015677 5ustar0000000000000000polynomial-0.7.2/src/Math/Polynomial/Bernoulli.hs0000644000000000000000000000154112516343153020167 0ustar0000000000000000module Math.Polynomial.Bernoulli (bernoulliPoly) where import Math.Polynomial import Data.VectorSpace {- | Bernoulli polynomial with a nonstandard normalization > b_i = bernoulliPoly !! i Has the following generating function (C.2 in IH Sloan & S Joe "Lattice Methods for multiple integration" 1994 page 227) > t exp(x*t) / (exp(t) - 1) = sum_{i=0} b_i t^i The standard normalization would have @= sum_{i=0} B_i t^i / i!@ -} bernoulliPoly :: (Fractional a, Eq a) => [Poly a] bernoulliPoly = map fst biIntegralBi biIntegralBi :: (Fractional a, Eq a) => [(Poly a, Poly a)] biIntegralBi = (constPoly 1, polyIntegral (constPoly 1)) : map f biIntegralBi where f (p, ip) = case polyIntegral ip of ip2 -> case constPoly $ evalPoly ip2 0 - evalPoly ip2 1 of c -> (c `addPoly` ip, polyIntegral c `addPoly` ip2) polynomial-0.7.2/src/Math/Polynomial/Bernstein.hs0000644000000000000000000000547112516343153020173 0ustar0000000000000000{-# LANGUAGE ParallelListComp #-} module Math.Polynomial.Bernstein ( bernstein , evalBernstein , bernsteinFit , evalBernsteinSeries , deCasteljau , splitBernsteinSeries ) where import Math.Polynomial import Data.List -- |The Bernstein basis polynomials. The @n@th inner list is a basis for -- the polynomials of order @n@ or lower. The @n@th basis consists of @n@ -- polynomials of order @n@ which sum to @1@, and have roots of varying -- multiplicities at @0@ and @1@. bernstein :: [[Poly Integer]] bernstein = [ [ scalePoly nCv p `multPoly` q | q <- reverse qs | p <- ps | nCv <- bico ] | ps <- tail $ inits [poly BE (1 : zs) | zs <- inits (repeat 0)] | qs <- tail $ inits (iterate (multPoly (poly LE [1,-1])) one) | bico <- ptri ] where -- pascal's triangle ptri = [1] : [ 1 : zipWith (+) row (tail row) ++ [1] | row <- ptri] -- |@evalBernstein n v x@ evaluates the @v@'th Bernstein polynomial of order @n@ -- at the point @x@. evalBernstein :: (Integral a, Num b) => a -> a -> b -> b evalBernstein n v t | n < 0 || v > n = 0 | otherwise = fromInteger nCv * t^v * (1-t)^(n-v) where n' = toInteger n v' = toInteger v nCv = product [1..n'] `div` (product [1..v'] * product [1..n'-v']) -- |@bernsteinFit n f@: Approximate a function @f@ as a linear combination of -- Bernstein polynomials of order @n@. This approximation converges slowly -- but uniformly to @f@ on the interval [0,1]. bernsteinFit :: (Fractional b, Integral a) => a -> (b -> b) -> [b] bernsteinFit n f = [f (fromIntegral v / fromIntegral n) | v <- [0..n]] -- |Evaluate a polynomial given as a list of @n@ coefficients for the @n@th -- Bernstein basis. Roughly: -- -- > evalBernsteinSeries cs = sum (zipWith scalePoly cs (bernstein !! (length cs - 1))) evalBernsteinSeries :: Num a => [a] -> a -> a evalBernsteinSeries [] = const 0 evalBernsteinSeries cs = head . last . deCasteljau cs -- |de Casteljau's algorithm, returning the whole tableau. Used both for -- evaluating and splitting polynomials in Bernstein form. deCasteljau :: Num a => [a] -> a -> [[a]] deCasteljau [] _ = [] deCasteljau cs t = cs : deCasteljau (zipWith (interp t) cs (tail cs)) t where interp t x0 x1 = (1-t)*x0 + t*x1 -- |Given a polynomial in Bernstein form (that is, a list of coefficients -- for a basis set from 'bernstein', such as is returned by 'bernsteinFit') -- and a parameter value @x@, split the polynomial into two halves, mapping -- @[0,x]@ and @[x,1]@ respectively onto @[0,1]@. -- -- A typical use for this operation would be to split a Bezier curve -- (inserting a new knot at @x@). splitBernsteinSeries :: Num a => [a] -> a -> ([a], [a]) splitBernsteinSeries cs t = (map head betas, map last (reverse betas)) where betas = deCasteljau cs t polynomial-0.7.2/src/Math/Polynomial/Chebyshev.hs0000644000000000000000000001061712516343153020160 0ustar0000000000000000{-# LANGUAGE ParallelListComp, BangPatterns #-} module Math.Polynomial.Chebyshev where import Math.Polynomial import Data.List -- |The Chebyshev polynomials of the first kind with 'Integer' coefficients. ts :: [Poly Integer] ts = poly LE [1] : [ addPoly (x `multPoly` t_n) (poly LE [-1,0,1] `multPoly` u_n) | t_n <- ts | u_n <- poly LE [0] : us ] -- The Chebyshev polynomials of the second kind with 'Integer' coefficients. us :: [Poly Integer] us = [ addPoly t_n (multPoly x u_n) | t_n <- ts | u_n <- poly LE [0] : us ] -- |Compute the coefficients of the n'th Chebyshev polynomial of the first kind. t :: (Num a, Eq a) => Int -> Poly a t n | n >= 0 = poly LE . map fromInteger . polyCoeffs LE $ ts !! n | otherwise = error "t: negative index" -- |Compute the coefficients of the n'th Chebyshev polynomial of the second kind. u :: (Num a, Eq a) => Int -> Poly a u n | n >= 0 = poly LE . map fromInteger . polyCoeffs LE $ us !! n | otherwise = error "u: negative index" -- |Evaluate the n'th Chebyshev polynomial of the first kind at a point X. -- Both more efficient and more numerically stable than computing the -- coefficients and evaluating the polynomial. evalT :: Num a => Int -> a -> a evalT n x = fst (evalTU n x) -- |Evaluate all the Chebyshev polynomials of the first kind at a point X. evalTs :: Num a => a -> [a] evalTs = fst . evalTsUs -- |Evaluate the n'th Chebyshev polynomial of the second kind at a point X. -- Both more efficient and more numerically stable than computing the -- coefficients and evaluating the polynomial. evalU :: Num a => Int -> a -> a evalU n x = snd (evalTU n x) -- |Evaluate all the Chebyshev polynomials of the second kind at a point X. evalUs :: Num a => a -> [a] evalUs = snd . evalTsUs -- |Evaluate the n'th Chebyshev polynomials of both kinds at a point X. evalTU :: Num a => Int -> a -> (a,a) evalTU n x = go n 1 0 where go !0 !t_n !u_n = (t_n, u_n) go !n !t_n !u_n = go (n-1) t_np1 u_np1 where t_np1 = x * t_n - (1-x*x)*u_n u_np1 = x * u_n + t_n -- |Evaluate all the Chebyshev polynomials of both kinds at a point X. evalTsUs :: Num a => a -> ([a], [a]) evalTsUs x = (ts, tail us) where ts = 1 : [x * t_n - (1-x*x)*u_n | t_n <- ts | u_n <- us] us = 0 : [x * u_n + t_n | t_n <- ts | u_n <- us] -- |Compute the roots of the n'th Chebyshev polynomial of the first kind. tRoots :: Floating a => Int -> [a] tRoots n = [cos (pi / fromIntegral n * (fromIntegral k + 0.5)) | k <- [0..n-1]] -- |Compute the extreme points of the n'th Chebyshev polynomial of the first kind. tExtrema :: Floating a => Int -> [a] tExtrema n = [cos (pi / fromIntegral n * fromIntegral k ) | k <- [0..n]] -- |@chebyshevFit n f@ returns a list of N coefficients @cs@ such that -- @f x@ ~= @sum (zipWith (*) cs (evalTs x))@ on the interval -1 < x < 1. -- -- The N roots of the N'th Chebyshev polynomial are the fitting points at -- which the function will be evaluated and at which the approximation will be -- exact. These points always lie within the interval -1 < x < 1. Outside -- this interval, the approximation will diverge quickly. -- -- This function deviates from most chebyshev-fit implementations in that it -- returns the first coefficient pre-scaled so that the series evaluation -- operation is a simple inner product, since in most other algorithms -- operating on chebyshev series, that factor is almost always a nuissance. chebyshevFit :: Floating a => Int -> (a -> a) -> [a] chebyshevFit n f = [ oneOrTwo / fromIntegral n * sum (zipWith (*) ts fxs) | ts <- transpose txs | oneOrTwo <- 1 : repeat 2 ] where txs = map (take n . evalTs) xs fxs = map f xs xs = tRoots n -- |Evaluate a Chebyshev series expansion with a finite number of terms. -- -- Note that this function expects the first coefficient to be pre-scaled -- by 1/2, which is what is produced by 'chebyshevFit'. Thus, this computes -- a simple inner product of the given list with a matching-length sequence of -- chebyshev polynomials. evalChebyshevSeries :: Num a => [a] -> a -> a evalChebyshevSeries [] _ = 0 evalChebyshevSeries (c0:cs) x = let b1:b2:_ = reverse bs in x*b1 - b2 + c0 where -- Clenshaw's recurrence formula bs = 0 : 0 : [2*x*b1 - b2 + c | b2:b1:_ <- tails bs | c <- reverse cs] polynomial-0.7.2/src/Math/Polynomial/Hermite.hs0000644000000000000000000000261112516343153017630 0ustar0000000000000000module Math.Polynomial.Hermite where import Math.Polynomial import Data.VectorSpace probHermite :: [Poly Integer] probHermite = one : [ multPoly x h_n ^-^ polyDeriv h_n | h_n <- probHermite ] physHermite :: [Poly Integer] physHermite = one : [ scalePoly 2 (multPoly x h_n) ^-^ polyDeriv h_n | h_n <- physHermite ] evalProbHermite :: (Integral a, Num b) => a -> b -> b evalProbHermite n = fst . evalProbHermiteDeriv n evalProbHermiteDeriv :: (Integral a, Num b) => a -> b -> (b, b) evalProbHermiteDeriv 0 _ = (1, 0) evalProbHermiteDeriv 1 x = (x, 1) evalProbHermiteDeriv n x | n < 0 = error "evalProbHermite: n < 0" | otherwise = loop 1 x 1 where loop k h_k h_km1 | k == n = (h_k, k' * h_km1) | otherwise = loop (k+1) (x * h_k - k' * h_km1) h_k where k' = fromIntegral k evalPhysHermite :: (Integral a, Num b) => a -> b -> b evalPhysHermite n = fst . evalPhysHermiteDeriv n evalPhysHermiteDeriv :: (Integral a, Num b) => a -> b -> (b,b) evalPhysHermiteDeriv 0 _ = (1, 0) evalPhysHermiteDeriv 1 x = (2*x, 2) evalPhysHermiteDeriv n x | n < 0 = error "evalProbHermite: n < 0" | otherwise = loop 1 (2*x) 1 where loop k h_k h_km1 | k == n = (h_k, 2 * k' * h_km1) | otherwise = loop (k+1) (2 * (x * h_k - k' * h_km1)) h_k where k' = fromIntegral k polynomial-0.7.2/src/Math/Polynomial/Interpolation.hs0000644000000000000000000000741112516343153021065 0ustar0000000000000000{-# 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 polynomial-0.7.2/src/Math/Polynomial/Lagrange.hs0000644000000000000000000000424012516343153017753 0ustar0000000000000000{-# LANGUAGE ParallelListComp #-} module Math.Polynomial.Lagrange ( lagrangeBasis , lagrange , lagrangeWeights ) where import Math.Polynomial -- given a list, return one list containing each element of the original list -- paired with all the other elements of the list. select :: [a] -> [(a,[a])] select [] = [] select (x:xs) = (x, xs) : [(y, x:ys) | (y, ys) <- select xs] -- |Returns the Lagrange basis set of polynomials associated with a set of -- points. This is the set of polynomials each of which is @1@ at its -- corresponding point in the input list and @0@ at all others. -- -- These polynomials are especially convenient, mathematically, for -- interpolation. The interpolating polynomial for a set of points @(x,y)@ -- is given by using the @y@s as coefficients for the basis given by -- @lagrangeBasis xs@. Computationally, this is not an especially stable -- procedure though. 'Math.Polynomial.Interpolation.lagrangePolyFit' -- implements a slightly better algorithm based on the same idea. -- -- Generally it is better to not compute the coefficients at all. -- 'Math.Polynomial.Interpolation.polyInterp' evaluates the interpolating -- polynomial directly, and is both quicker and more stable than any method -- I know of that computes the coefficients. lagrangeBasis :: (Fractional a, Eq a) => [a] -> [Poly a] lagrangeBasis xs = [ foldl1 multPoly [ if q /= 0 then poly LE [negate x_j/q, 1/q] else error ("lagrangeBasis: duplicate root") | x_j <- otherXs , let q = x_i - x_j ] | (x_i, otherXs) <- select xs ] -- |Construct the Lagrange "master polynomial" for the Lagrange barycentric form: -- That is, the monic polynomial with a root at each point in the input list. lagrange :: (Num a, Eq a) => [a] -> Poly a lagrange [] = one lagrange xs = foldl1 multPoly [ poly LE [negate x_i, 1] | x_i <- xs ] -- |Compute the weights associated with each abscissa in the Lagrange -- barycentric form. lagrangeWeights :: Fractional a => [a] -> [a] lagrangeWeights xs = [ recip $ product [ x_i - x_j | x_j <- otherXs ] | (x_i, otherXs) <- select xs ] polynomial-0.7.2/src/Math/Polynomial/Legendre.hs0000644000000000000000000000541212516343153017762 0ustar0000000000000000{-# LANGUAGE ParallelListComp #-} module Math.Polynomial.Legendre where import Math.Polynomial -- |The Legendre polynomials with 'Rational' coefficients. These polynomials -- form an orthogonal basis of the space of all polynomials, relative to the -- L2 inner product on [-1,1] (which is given by integrating the product of -- 2 polynomials over that range). legendres :: [Poly Rational] legendres = one : x : [ multPoly (poly LE [recip (n' + 1)]) (addPoly (poly LE [0, 2 * n' + 1] `multPoly` p_n) (poly LE [-n'] `multPoly` p_nm1) ) | n <- [1..], let n' = fromInteger n | p_n <- tail legendres | p_nm1 <- legendres ] -- |Compute the coefficients of the n'th Legendre polynomial. legendre :: (Fractional a, Eq a) => Int -> Poly a legendre n = poly LE . map fromRational . polyCoeffs LE $ legendres !! n -- |Evaluate the n'th Legendre polynomial at a point X. Both more efficient -- and more numerically stable than computing the coefficients and evaluating -- the polynomial. evalLegendre :: Fractional a => Int -> a -> a evalLegendre n t = evalLegendres t !! n -- |Evaluate all the Legendre polynomials at a point X. evalLegendres :: Fractional a => a -> [a] evalLegendres t = ps where ps = 1 : t : [ ((2 * n + 1) * t * p_n - n * p_nm1) / (n + 1) | n <- iterate (1+) 1 | p_n <- tail ps | p_nm1 <- ps ] -- |Evaluate the n'th Legendre polynomial and its derivative at a point X. -- Both more efficient and more numerically stable than computing the -- coefficients and evaluating the polynomial. evalLegendreDeriv :: Fractional a => Int -> a -> (a,a) evalLegendreDeriv 0 _ = (1,0) evalLegendreDeriv n t = case drop (n-1) (evalLegendres t) of (p2:p1:_) -> (p1, fromIntegral n * (t * p1 - p2) / (t*t - 1)) _ -> error "evalLegendreDeriv: evalLegendres didn't return a long enough list" {- should be infinite -} -- |Zeroes of the n'th Legendre polynomial. legendreRoots :: (Fractional b, Ord b) => Int -> b -> [b] legendreRoots n eps = map negate mRoots ++ reverse (take (n-m) mRoots) where -- the roots are symmetric in the interval so we only have to find 'm' of them. -- The rest are reflections. m = (n + 1) `div` 2 mRoots = [improveRoot (z0 i) | i <- [0..m-1]] -- Initial guess for i'th root of the n'th Legendre polynomial z0 i = realToFrac (cos (pi * (fromIntegral i + 0.75) / (fromIntegral n + 0.5)) :: Double) -- Improve estimate of a root by newton's method improveRoot z1 | abs (z2-z1) <= eps = z2 | otherwise = improveRoot z2 where (y, dy) = evalLegendreDeriv n z1 z2 = z1 - y/dy polynomial-0.7.2/src/Math/Polynomial/Newton.hs0000644000000000000000000000071412516343153017507 0ustar0000000000000000module Math.Polynomial.Newton where import Math.Polynomial import Data.List -- |Returns the Newton basis set of polynomials associated with a set of -- abscissas. This is the set of monic polynomials each of which is @0@ -- at all previous points in the input list. newtonBasis :: (Num a, Eq a) => [a] -> [Poly a] newtonBasis xs = [ foldl multPoly (poly LE [1]) [ poly LE [-x_i, 1] | x_i <- xs' ] | xs' <- inits xs ] polynomial-0.7.2/src/Math/Polynomial/NumInstance.hs0000644000000000000000000000124412516343153020460 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} -- |This module exports a 'Num' instance for the 'Poly' type. -- This instance does not implement all operations, because 'abs' and 'signum' -- are simply not definable, so I have placed it into a separate module so -- that I can make people read this caveat ;). -- -- Use at your own risk. module Math.Polynomial.NumInstance where import Math.Polynomial instance (Num a, Eq a) => Num (Poly a) where fromInteger i = poly LE [fromInteger i] (+) = addPoly negate = negatePoly (*) = multPoly abs = error "abs cannot be defined for the Poly type" signum = error "signum cannot be defined for the Poly type" polynomial-0.7.2/src/Math/Polynomial/Pretty.hs0000644000000000000000000000465112516343153017530 0ustar0000000000000000{-# LANGUAGE ParallelListComp, ViewPatterns, FlexibleInstances, FlexibleContexts, IncoherentInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} -- This code is a big ugly mess, but it more or less works. Someday I might -- get around to cleaning it up. -- |This module exports a 'Pretty' instance for the 'Poly' type. module Math.Polynomial.Pretty () where import Math.Polynomial.Type import Data.Complex import Text.PrettyPrint import Text.PrettyPrint.HughesPJClass instance (Pretty a, Num a, Ord a) => Pretty (Poly a) where pPrintPrec l p x = ppr where ppr = pPrintPolyWith p BE (pPrintOrdTerm pPrNum 'x') x pPrNum = pPrintPrec l 11 instance (RealFloat a, Pretty a) => Pretty (Complex a) where pPrintPrec l p (a :+ b) = ppr where x = poly LE [a,b] ppr = pPrintPolyWith p LE (pPrintOrdTerm pPrNum 'i') x pPrNum = pPrintPrec l 11 instance (RealFloat a, Pretty (Complex a)) => Pretty (Poly (Complex a)) where pPrintPrec l p x = ppr where ppr = pPrintPolyWith p BE (pPrintUnOrdTerm pPrNum 'x') x pPrNum = pPrintPrec l 11 pPrintPolyWith prec end v p = parenSep (prec > 5) $ filter (not . isEmpty) [ v first coeff exp | (coeff, exp) <- (if end == BE then reverse else dropWhile ((0==).fst)) (zip (polyCoeffs LE p) [0..]) | first <- True : repeat False ] parenSep p xs = prettyParen (p && not (null (drop 1 xs))) (hsep xs) pPrintOrdTerm _ _ _ 0 _ = empty pPrintOrdTerm num _ f c 0 = sign f c <> num (abs c) pPrintOrdTerm _ v f c 1 | abs c == 1 = sign f c <> char v pPrintOrdTerm num v f c 1 = sign f c <> num (abs c) <> char v pPrintOrdTerm _ v f c e | abs c == 1 = sign f c <> char v <> text "^" <> int e pPrintOrdTerm num v f c e = sign f c <> num (abs c) <> char v <> text "^" <> int e sign True x | x < 0 = char '-' | otherwise = empty sign False x | x < 0 = text "- " | otherwise = text "+ " pPrintUnOrdTerm _ _ _ 0 _ = empty pPrintUnOrdTerm num _ f c 0 = sign f 1 <> num c pPrintUnOrdTerm _ v f 1 1 = sign f 1 <> char v pPrintUnOrdTerm num v f c 1 = sign f 1 <> num c <> char v pPrintUnOrdTerm _ v f 1 e = sign f 1 <> char v <> text "^" <> int e pPrintUnOrdTerm num v f c e = sign f 1 <> num c <> char v <> text "^" <> int e polynomial-0.7.2/src/Math/Polynomial/Type.hs0000644000000000000000000002261512516343153017162 0ustar0000000000000000{-# LANGUAGE ViewPatterns, TypeFamilies, GADTs, UndecidableInstances #-} -- |Low-level interface for the 'Poly' type. module Math.Polynomial.Type ( Endianness(..) , Poly , zero , poly, polyN , unboxedPoly, unboxedPolyN , mapPoly , rawMapPoly , wrapPoly , unwrapPoly , unboxPoly , rawListPoly , rawListPolyN , rawVectorPoly , rawUVectorPoly , trim , vTrim , polyIsZero , polyIsOne , polyCoeffs , vPolyCoeffs , rawCoeffsOrder , rawPolyCoeffs , untrimmedPolyCoeffs , polyDegree , rawPolyDegree , rawPolyLength ) where import Control.DeepSeq -- import Data.List.Extras.LazyLength import Data.AdditiveGroup import Data.VectorSpace import Data.VectorSpace.WrappedNum import Data.List.ZipSum import qualified Data.Vector as V import qualified Data.Vector.Unboxed as UV -- 'unsafeCoerce' is only used in 'wrapPoly' and 'unwrapPoly', which are -- type-safe alternatives to 'fmap'ing the 'WrappedNum' newtype constructor/projector import Unsafe.Coerce (unsafeCoerce) data Endianness = BE -- ^ Big-Endian (head is highest-order term) | LE -- ^ Little-Endian (head is const term) deriving (Eq, Ord, Enum, Bounded, Show) instance NFData Endianness where rnf x = seq x () data Poly a where ListPoly :: { trimmed :: !Bool , endianness :: !Endianness , listCoeffs :: ![a] } -> Poly a VectorPoly :: { trimmed :: !Bool , endianness :: !Endianness , vCoeffs :: !(V.Vector a) } -> Poly a UVectorPoly :: UV.Unbox a => { trimmed :: !Bool , endianness :: !Endianness , uvCoeffs :: !(UV.Vector a) } -> Poly a instance NFData a => NFData (Poly a) where rnf (ListPoly _ _ c) = rnf c rnf (VectorPoly _ _ c) = V.foldr' seq () c rnf (UVectorPoly _ _ _) = () instance Show a => Show (Poly a) where showsPrec p f = showParen (p > 10) ( showString "poly " . showsPrec 11 (rawCoeffsOrder f) . showChar ' ' . showsPrec 11 (rawPolyCoeffs f) ) -- TODO: specialize for case where one is a list and other is a vector; -- use native order of the list -- TODO: think about plain Num support... instance (AdditiveGroup a, Eq a) => Eq (Poly a) where p == q | rawCoeffsOrder p == rawCoeffsOrder q = rawPolyCoeffs (trim (zeroV==) p) == rawPolyCoeffs (trim (zeroV==) q) | otherwise = vPolyCoeffs LE p == vPolyCoeffs LE q -- -- Ord would be nice for some purposes, but it really just doesn't -- -- make sense (there is no natural order that is much better than any -- -- other, AFAIK), so I'm leaving it out. -- instance (Num a, Ord a) => Ord (Poly a) where -- compare p q = mconcat -- [ lengthCompare pCoeffs qCoeffs -- , compare pCoeffs qCoeffs -- ] -- where -- pCoeffs = polyCoeffs BE p -- qCoeffs = polyCoeffs BE q instance Functor Poly where fmap f (ListPoly _ end cs) = ListPoly False end (map f cs) fmap f (VectorPoly _ end cs) = VectorPoly False end (V.map f cs) -- TODO: make sure this gets fused fmap f (UVectorPoly _ end cs) = VectorPoly False end (V.fromListN n . map f $ UV.toList cs) where n = UV.length cs -- |Like fmap, but able to preserve unboxedness mapPoly :: (Num a, Eq a) => (a -> a) -> Poly a -> Poly a mapPoly f = trim (0==) . rawMapPoly f rawMapPoly :: (a -> a) -> Poly a -> Poly a rawMapPoly f (ListPoly _ e cs) = ListPoly False e ( map f cs) rawMapPoly f (VectorPoly _ e cs) = VectorPoly False e ( V.map f cs) rawMapPoly f (UVectorPoly _ e cs) = UVectorPoly False e (UV.map f cs) {-# RULES "wrapPoly/unwrapPoly" forall x. wrapPoly (unwrapPoly x) = x #-} {-# RULES "unwrapPoly/wrapPoly" forall x. unwrapPoly (wrapPoly x) = x #-} {-# RULES "wrapPoly.unwrapPoly" wrapPoly . unwrapPoly = id #-} {-# RULES "unwrapPoly.wrapPoly" unwrapPoly . wrapPoly = id #-} -- |like @fmap WrapNum@ but using 'unsafeCoerce' to avoid a pointless traversal wrapPoly :: Poly a -> Poly (WrappedNum a) wrapPoly = unsafeCoerce -- |like @fmap unwrapNum@ but using 'unsafeCoerce' to avoid a pointless traversal unwrapPoly :: Poly (WrappedNum a) -> Poly a unwrapPoly = unsafeCoerce instance AdditiveGroup a => AdditiveGroup (Poly a) where zeroV = ListPoly True LE [] (untrimmedPolyCoeffs LE -> a) ^+^ (untrimmedPolyCoeffs LE -> b) = ListPoly False LE (zipSumV a b) negateV = fmap negateV instance (Eq a, VectorSpace a, AdditiveGroup (Scalar a), Eq (Scalar a)) => VectorSpace (Poly a) where type Scalar (Poly a) = Scalar a s *^ v | s == zeroV = zeroV | otherwise = vTrim (rawMapPoly (s *^) v) -- |Trim zeroes from a polynomial (given a predicate for identifying zero). -- In particular, drops zeroes from the highest-order coefficients, so that -- @0x^n + 0x^(n-1) + 0x^(n-2) + ... + ax^k + ...@, @a /= 0@ -- is normalized to @ax^k + ...@. -- -- The 'Eq' instance for 'Poly' and all the standard constructors / destructors -- are defined using @trim (0==)@. trim :: (a -> Bool) -> Poly a -> Poly a trim _ p | trimmed p = p trim isZero (ListPoly _ LE cs) = ListPoly True LE (dropEnd isZero cs) trim isZero (ListPoly _ BE cs) = ListPoly True BE (dropWhile isZero cs) trim isZero (VectorPoly _ LE cs) = VectorPoly True LE (V.reverse . V.dropWhile isZero . V.reverse $ cs) trim isZero (VectorPoly _ BE cs) = VectorPoly True BE (V.dropWhile isZero cs) trim isZero (UVectorPoly _ LE cs) = UVectorPoly True LE (UV.reverse . UV.dropWhile isZero . UV.reverse $ cs) trim isZero (UVectorPoly _ BE cs) = UVectorPoly True BE (UV.dropWhile isZero cs) vTrim :: (Eq a, AdditiveGroup a) => Poly a -> Poly a vTrim = trim (zeroV ==) -- |The polynomial \"0\" zero :: Poly a zero = ListPoly True LE [] -- |Make a 'Poly' from a list of coefficients using the specified coefficient order. poly :: (Num a, Eq a) => Endianness -> [a] -> Poly a poly end = trim (0==) . rawListPoly end -- |Make a 'Poly' from a list of coefficients, at most 'n' of which are significant. polyN :: (Num a, Eq a) => Int -> Endianness -> [a] -> Poly a polyN n end = trim (0==) . rawVectorPoly end . V.fromListN n unboxedPoly :: (UV.Unbox a, Num a, Eq a) => Endianness -> [a] -> Poly a unboxedPoly end = trim (0==) . rawUVectorPoly end . UV.fromList unboxedPolyN :: (UV.Unbox a, Num a, Eq a) => Int -> Endianness -> [a] -> Poly a unboxedPolyN n end = trim (0==) . rawUVectorPoly end . UV.fromListN n unboxPoly :: UV.Unbox a => Poly a -> Poly a unboxPoly (ListPoly t e cs) = UVectorPoly t e (UV.fromList cs) unboxPoly (VectorPoly t e cs) = UVectorPoly t e (UV.fromListN (V.length cs) (V.toList cs)) unboxPoly p@UVectorPoly{} = p -- |Make a 'Poly' from a list of coefficients using the specified coefficient order, -- without the 'Num' context (and therefore without trimming zeroes from the -- coefficient list) rawListPoly :: Endianness -> [a] -> Poly a rawListPoly = ListPoly False rawListPolyN :: Int -> Endianness -> [a] -> Poly a rawListPolyN n e = rawVectorPoly e . V.fromListN n rawVectorPoly :: Endianness -> V.Vector a -> Poly a rawVectorPoly = VectorPoly False rawUVectorPoly :: UV.Unbox a => Endianness -> UV.Vector a -> Poly a rawUVectorPoly = UVectorPoly False -- |Get the degree of a a 'Poly' (the highest exponent with nonzero coefficient) polyDegree :: (Num a, Eq a) => Poly a -> Int polyDegree p = rawPolyDegree (trim (0==) p) rawPolyDegree :: Poly a -> Int rawPolyDegree p = rawPolyLength p - 1 rawPolyLength :: Poly a -> Int rawPolyLength (ListPoly _ _ cs) = length cs rawPolyLength (VectorPoly _ _ cs) = V.length cs rawPolyLength (UVectorPoly _ _ cs) = UV.length cs -- |Get the coefficients of a a 'Poly' in the specified order. polyCoeffs :: (Num a, Eq a) => Endianness -> Poly a -> [a] polyCoeffs end p = untrimmedPolyCoeffs end (trim (0 ==) p) -- |Get the coefficients of a a 'Poly' in the specified order. vPolyCoeffs :: (Eq a, AdditiveGroup a) => Endianness -> Poly a -> [a] vPolyCoeffs end p = untrimmedPolyCoeffs end (vTrim p) polyIsZero :: (Num a, Eq a) => Poly a -> Bool polyIsZero = null . rawPolyCoeffs . trim (0==) polyIsOne :: (Num a, Eq a) => Poly a -> Bool polyIsOne = ([1]==) . rawPolyCoeffs . trim (0==) rawCoeffsOrder :: Poly a -> Endianness rawCoeffsOrder = endianness rawPolyCoeffs :: Poly a -> [a] rawPolyCoeffs p@ListPoly{} = listCoeffs p rawPolyCoeffs p@VectorPoly{} = V.toList (vCoeffs p) rawPolyCoeffs p@UVectorPoly{} = UV.toList (uvCoeffs p) -- TODO: make sure (V.toList . V.reverse) gets fused untrimmedPolyCoeffs :: Endianness -> Poly a -> [a] untrimmedPolyCoeffs e1 (VectorPoly _ e2 cs) | e1 == e2 = V.toList cs | otherwise = V.toList (V.reverse cs) untrimmedPolyCoeffs e1 (UVectorPoly _ e2 cs) | e1 == e2 = UV.toList cs | otherwise = UV.toList (UV.reverse cs) untrimmedPolyCoeffs e1 (ListPoly _ e2 cs) | e1 == e2 = cs | otherwise = reverse cs dropEnd :: (a -> Bool) -> [a] -> [a] -- dropEnd p = reverse . dropWhile p . reverse dropEnd p = go id where go t (x:xs) -- if p x, stash x (will only be used if 'not (any p xs)') | p x = go (t.(x:)) xs -- otherwise insert x and all stashed values in output and reset the stash | otherwise = t (x : go id xs) -- at end of string discard the stash go _ [] = [] polynomial-0.7.2/src/Math/Polynomial/VectorSpace.hs0000644000000000000000000002525012516343153020455 0ustar0000000000000000{-# LANGUAGE ParallelListComp, ViewPatterns, FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- TODO: update all haddock comments -- |Same general interface as Math.Polynomial, but using AdditiveGroup, -- VectorSpace, etc., instead of Num where sensible. module Math.Polynomial.VectorSpace ( Endianness(..) , Poly, poly, polyDegree , vPolyCoeffs, polyIsZero, polyIsOne , zero, one, constPoly, x , scalePoly, negatePoly , composePolyWith , addPoly, sumPolys, multPolyWith, powPolyWith , quotRemPolyWith, quotPolyWith, remPolyWith , evalPoly, evalPolyDeriv, evalPolyDerivs , contractPoly , monicPolyWith , gcdPolyWith , polyDeriv, polyDerivs, polyIntegral ) where import Math.Polynomial.Type hiding (poly, polyDegree, polyIsZero) import Math.Polynomial.Pretty ({- instance -}) import Data.List import Data.List.ZipSum import Data.VectorSpace vPolyN :: (Eq a, AdditiveGroup a) => Int -> Endianness -> [a] -> Poly a vPolyN n e = vTrim . rawListPolyN n e poly :: (Eq a, AdditiveGroup a) => Endianness -> [a] -> Poly a poly e = vTrim . rawListPoly e polyDegree :: (Eq a, AdditiveGroup a) => Poly a -> Int polyDegree p = rawPolyDegree (vTrim p) polyIsZero :: (Eq a, AdditiveGroup a) => Poly a -> Bool polyIsZero = null . rawPolyCoeffs . vTrim -- |The polynomial \"1\" one :: (Num a, Eq a) => Poly a one = polyN 1 LE [1] -- |The polynomial (in x) \"x\" x :: (Num a, Eq a) => Poly a x = polyN 2 LE [0,1] -- |Given some constant 'k', construct the polynomial whose value is -- constantly 'k'. constPoly :: (Eq a, AdditiveGroup a) => a -> Poly a constPoly x = vPolyN 1 LE [x] -- |Given some scalar 's' and a polynomial 'f', computes the polynomial 'g' -- such that: -- -- > evalPoly g x = s * evalPoly f x scalePoly :: (Eq a, VectorSpace a, AdditiveGroup (Scalar a), Eq (Scalar a)) => Scalar a -> Poly a -> Poly a scalePoly = (*^) -- |Given some polynomial 'f', computes the polynomial 'g' such that: -- -- > evalPoly g x = negate (evalPoly f x) negatePoly :: (AdditiveGroup a, Eq a) => Poly a -> Poly a negatePoly = vTrim . rawMapPoly negateV -- |Given polynomials 'f' and 'g', computes the polynomial 'h' such that: -- -- > evalPoly h x = evalPoly f x + evalPoly g x addPoly :: (AdditiveGroup a, Eq a) => Poly a -> Poly a -> Poly a addPoly p@(vPolyCoeffs LE -> a) q@(vPolyCoeffs LE -> b) = vPolyN n LE (zipSumV a b) where n = max (rawPolyLength p) (rawPolyLength q) {-# RULES "sum Poly" forall ps. foldl addPoly zero ps = sumPolys ps #-} sumPolys :: (AdditiveGroup a, Eq a) => [Poly a] -> Poly a sumPolys [] = zero sumPolys ps = poly LE (foldl1 zipSumV (map (vPolyCoeffs LE) ps)) -- |Given polynomials 'f' and 'g', computes the polynomial 'h' such that: -- -- > evalPoly h x = evalPoly f x * evalPoly g x multPolyWith :: (AdditiveGroup a, Eq a) => (a -> a -> a) -> Poly a -> Poly a -> Poly a multPolyWith multiplyV p@(vPolyCoeffs LE -> xs) q@(vPolyCoeffs LE -> ys) = vPolyN n LE (multPolyWithLE multiplyV xs ys) where n = 1 + rawPolyDegree p + rawPolyDegree q -- |(Internal): multiply polynomials in LE order. O(length xs * length ys). multPolyWithLE :: (AdditiveGroup a, Eq a) => (a -> a -> a) -> [a] -> [a] -> [a] multPolyWithLE _ _ [] = [] multPolyWithLE multiplyV xs (y:ys) = foldr mul [] xs where mul x bs | x == zeroV = zeroV : bs | otherwise = (multiplyV x y) : zipSumV (map (multiplyV x) ys) bs -- |Given a polynomial 'f' and exponent 'n', computes the polynomial 'g' -- such that: -- -- > evalPoly g x = evalPoly f x ^ n powPolyWith :: (AdditiveGroup a, Eq a, Integral b) => a -> (a -> a -> a) -> Poly a -> b -> Poly a powPolyWith one multiplyV p n | n < 0 = error "powPolyWith: negative exponent" | otherwise = powPoly p n where multPoly = multPolyWith multiplyV powPoly p 0 = constPoly one powPoly p 1 = p powPoly p n | odd n = p `multPoly` powPoly p (n-1) | otherwise = (\x -> multPoly x x) (powPoly p (n`div`2)) -- |Given polynomials @a@ and @b@, with @b@ not 'zero', computes polynomials -- @q@ and @r@ such that: -- -- > addPoly (multPoly q b) r == a quotRemPolyWith :: (AdditiveGroup a, Eq a) => (a -> a -> a) -> (a -> a -> a) -> Poly a -> Poly a -> (Poly a, Poly a) quotRemPolyWith _ _ _ b | polyIsZero b = error "quotRemPoly: divide by zero" quotRemPolyWith multiplyV divideV p@(vPolyCoeffs BE -> u) q@(vPolyCoeffs BE -> v) = go [] u (polyDegree p - polyDegree q) where v0 | null v = zeroV | otherwise = head v go q u n | null u || n < 0 = (poly LE q, poly BE u) | otherwise = go (q0:q) u' (n-1) where q0 = divideV (head u) v0 u' = tail (zipSumV u (map (multiplyV (negateV q0)) v)) quotPolyWith :: (AdditiveGroup a, Eq a) => (a -> a -> a) -> (a -> a -> a) -> Poly a -> Poly a -> Poly a quotPolyWith multiplyV divideV u v | polyIsZero v = error "quotPoly: divide by zero" | otherwise = fst (quotRemPolyWith multiplyV divideV u v) remPolyWith :: (AdditiveGroup a, Eq a) => (a -> a -> a) -> (a -> a -> a) -> Poly a -> Poly a -> Poly a remPolyWith _ _ _ b | polyIsZero b = error "remPoly: divide by zero" remPolyWith multiplyV divideV (vPolyCoeffs BE -> u) (vPolyCoeffs BE -> v) = go u (length u - length v) where v0 | null v = zeroV | otherwise = head v go u n | null u || n < 0 = poly BE u | otherwise = go u' (n-1) where q0 = divideV (head u) v0 u' = tail (zipSumV u (map (multiplyV (negateV q0)) v)) -- |@composePoly f g@ constructs the polynomial 'h' such that: -- -- > evalPoly h = evalPoly f . evalPoly g -- -- This is a very expensive operation and, in general, returns a polynomial -- that is quite a bit more expensive to evaluate than @f@ and @g@ together -- (because it is of a much higher order than either). Unless your -- polynomials are quite small or you are quite certain you need the -- coefficients of the composed polynomial, it is recommended that you -- simply evaluate @f@ and @g@ and explicitly compose the resulting -- functions. This will usually be much more efficient. composePolyWith :: (AdditiveGroup a, Eq a) => (a -> a -> a) -> Poly a -> Poly a -> Poly a composePolyWith multiplyV (vPolyCoeffs LE -> cs) (vPolyCoeffs LE -> ds) = poly LE (foldr mul [] cs) where -- Implementation note: this is a hand-inlining of the following -- (with the 'Num' instance in "Math.Polynomial.NumInstance"): -- > composePoly f g = evalPoly (fmap constPoly f) g -- -- This is a very expensive operation, something like -- O(length cs ^ 2 * length ds) I believe. There may be some more -- tricks to improve that, but I suspect there isn't much room for -- improvement. The number of terms in the resulting polynomial is -- O(length cs * length ds) already, and each one is the sum of -- quite a few terms. mul c acc = addScalarLE c (multPolyWithLE multiplyV acc ds) -- |(internal) add a scalar to a list of polynomial coefficients in LE order addScalarLE :: (AdditiveGroup a, Eq a) => a -> [a] -> [a] addScalarLE a bs | a == zeroV = bs addScalarLE a [] = [a] addScalarLE a (b:bs) = (a ^+^ b) : bs -- |Evaluate a polynomial at a point or, equivalently, convert a polynomial -- to the function it represents. For example, @evalPoly 'x' = 'id'@ and -- @evalPoly ('constPoly' k) = 'const' k.@ evalPoly :: (VectorSpace a, Eq a, AdditiveGroup (Scalar a), Eq (Scalar a)) => Poly a -> Scalar a -> a evalPoly (vPolyCoeffs LE -> cs) x | x == zeroV = if null cs then zeroV else head cs | otherwise = foldr mul zeroV cs where mul c acc = c ^+^ acc ^* x -- |Evaluate a polynomial and its derivative (respectively) at a point. evalPolyDeriv :: (VectorSpace a, Eq a) => Poly a -> Scalar a -> (a,a) evalPolyDeriv (vPolyCoeffs LE -> cs) x = foldr mul (zeroV, zeroV) cs where mul c (p, dp) = ((x *^ p) ^+^ c, (x *^ dp) ^+^ p) -- |Evaluate a polynomial and all of its nonzero derivatives at a point. -- This is roughly equivalent to: -- -- > evalPolyDerivs p x = map (`evalPoly` x) (takeWhile (not . polyIsZero) (iterate polyDeriv p)) evalPolyDerivs :: (VectorSpace a, Eq a, Num (Scalar a)) => Poly a -> Scalar a -> [a] evalPolyDerivs (vPolyCoeffs LE -> cs) x = trunc . zipWith (*^) factorials $ foldr mul [] cs where trunc list = zipWith const list cs factorials = scanl (*) 1 (iterate (+1) 1) mul c pds@(p:pd) = (x *^ p ^+^ c) : map (x *^) pd `zipSumV` pds mul c [] = [c] -- |\"Contract\" a polynomial by attempting to divide out a root. -- -- @contractPoly p a@ returns @(q,r)@ such that @q*(x-a) + r == p@ contractPoly :: (VectorSpace a, Eq a) => Poly a -> Scalar a -> (Poly a, a) contractPoly p@(vPolyCoeffs LE -> cs) a = (vPolyN n LE q, r) where n = rawPolyLength p cut remainder swap = (swap ^+^ (a *^ remainder), remainder) (r,q) = mapAccumR cut zeroV cs -- |@gcdPoly a b@ computes the highest order monic polynomial that is a -- divisor of both @a@ and @b@. If both @a@ and @b@ are 'zero', the -- result is undefined. gcdPolyWith :: (AdditiveGroup a, Eq a) => a -> (a -> a -> a) -> (a -> a -> a) -> Poly a -> Poly a -> Poly a gcdPolyWith oneV multiplyV divideV a b | polyIsZero b = if polyIsZero a then error "gcdPolyWith: gcdPoly zero zero is undefined" else monicPolyWith oneV divideV a | otherwise = gcdPolyWith oneV multiplyV divideV b (a `remPoly` b) where remPoly = remPolyWith multiplyV divideV -- |Normalize a polynomial so that its highest-order coefficient is 1 monicPolyWith :: (AdditiveGroup a, Eq a) => a -> (a -> a -> a) -> Poly a -> Poly a monicPolyWith oneV divideV p = case vPolyCoeffs BE p of [] -> vPolyN n BE [] (c:cs) -> vPolyN n BE (oneV : map (`divideV` c) cs) where n = rawPolyLength p -- |Compute the derivative of a polynomial. polyDeriv :: (VectorSpace a, Eq a, Num (Scalar a)) => Poly a -> Poly a polyDeriv p@(vPolyCoeffs LE -> cs) = vPolyN (rawPolyDegree p) LE [ n *^ c | c <- drop 1 cs | n <- iterate (1+) 1 ] -- |Compute all nonzero derivatives of a polynomial, starting with its -- \"zero'th derivative\", the original polynomial itself. polyDerivs :: (VectorSpace a, Eq a, Num (Scalar a)) => Poly a -> [Poly a] polyDerivs p = take (1 + polyDegree p) (iterate polyDeriv p) -- |Compute the definite integral (from 0 to x) of a polynomial. polyIntegral :: (VectorSpace a, Eq a, Fractional (Scalar a)) => Poly a -> Poly a polyIntegral p@(vPolyCoeffs LE -> cs) = vPolyN (1 + rawPolyLength p) LE $ zeroV : [ c ^/ n | c <- cs | n <- iterate (1+) 1 ]