module Data.Maclaurin
(
(:>), powVal, derivative
, (:~>), dZero, pureD
, fmapD, (<$>>), liftD2, liftD3
, idD, fstD, sndD
, linearD, distrib
, (>-<)
)
where
import Control.Applicative
import Data.VectorSpace
import Data.NumInstances ()
import Data.MemoTrie
import Data.Basis
import Data.LinearMap
infixr 9 `D`
data a :> b = D { powVal :: b, derivative :: a :-* (a :> b) }
type a :~> b = a -> (a:>b)
noOv :: String -> a
noOv op = error (op ++ ": not defined on a :> b")
dZero :: (AdditiveGroup b, HasBasis a, HasTrie (Basis a)) => a:>b
dZero = pureD zeroV
pureD :: (AdditiveGroup b, HasBasis a, HasTrie (Basis a)) => b -> a:>b
pureD b = b `D` pure dZero
infixl 4 <$>>
fmapD, (<$>>) :: (HasTrie (Basis a), VectorSpace b) =>
(b -> c) -> (a :> b) -> (a :> c)
fmapD f (D b0 b') = D (f b0) ((fmap.fmapD) f b')
(<$>>) = fmapD
liftD2 :: (HasTrie (Basis a), VectorSpace b, VectorSpace c, VectorSpace d) =>
(b -> c -> d) -> (a :> b) -> (a :> c) -> (a :> d)
liftD2 f (D b0 b') (D c0 c') = D (f b0 c0) (liftA2 (liftD2 f) b' c')
liftD3 :: ( HasTrie (Basis a)
, VectorSpace b, VectorSpace c
, VectorSpace d, VectorSpace e ) =>
(b -> c -> d -> e)
-> (a :> b) -> (a :> c) -> (a :> d) -> (a :> e)
liftD3 f (D b0 b') (D c0 c') (D d0 d') = D (f b0 c0 d0) (liftA3 (liftD3 f) b' c' d')
idD :: ( VectorSpace u, s ~ Scalar u
, VectorSpace (u :> u), VectorSpace s
, HasBasis u, HasTrie (Basis u)) =>
u :~> u
idD = linearD id
linearD :: ( HasBasis u, HasTrie (Basis u)
, VectorSpace v ) =>
(u -> v) -> (u :~> v)
linearD f = \ u -> f u `D` d
where
d = linear (pureD . f)
fstD :: ( HasBasis a, HasTrie (Basis a)
, HasBasis b, HasTrie (Basis b)
, Scalar a ~ Scalar b
) => (a,b) :~> a
fstD = linearD fst
sndD :: ( HasBasis a, HasTrie (Basis a)
, HasBasis b, HasTrie (Basis b)
, Scalar a ~ Scalar b
) => (a,b) :~> b
sndD = linearD snd
distrib :: ( HasBasis a, HasTrie (Basis a), VectorSpace u
) => (b -> c -> u) -> (a :> b) -> (a :> c) -> (a :> u)
distrib op u@(D u0 u') v@(D v0 v') =
D (u0 `op` v0) (trie (\ da -> distrib op u (v' `untrie` da) ^+^
distrib op (u' `untrie` da) v))
instance Show b => Show (a :> b) where show = noOv "show"
instance Eq b => Eq (a :> b) where (==) = noOv "(==)"
instance Ord b => Ord (a :> b) where compare = noOv "compare"
instance (HasBasis a, HasTrie (Basis a), VectorSpace u) => AdditiveGroup (a :> u) where
zeroV = pureD zeroV
negateV = fmapD negateV
(^+^) = liftD2 (^+^)
instance ( HasBasis a, HasTrie (Basis a)
, VectorSpace u, s ~ Scalar u
)
=> VectorSpace (a :> u) where
type Scalar (a :> u) = (a :> Scalar u)
(*^) = distrib (*^)
instance ( InnerSpace u, s ~ Scalar u, InnerSpace s, s ~ Scalar s
, HasBasis a, HasTrie (Basis a)) =>
InnerSpace (a :> u) where
(<.>) = distrib (<.>)
infix 0 >-<
(>-<) :: (HasBasis a, HasTrie (Basis a), VectorSpace u) =>
(u -> u) -> ((a :> u) -> (a :> Scalar u))
-> (a :> u) -> (a :> u)
f >-< f' = \ u@(D u0 u') -> D (f u0) (f' u *^ u')
instance ( HasBasis a, s ~ Scalar a, HasTrie (Basis a)
, Num s, VectorSpace s, Scalar s ~ s)
=> Num (a:>s) where
fromInteger = pureD . fromInteger
(+) = liftD2 (+)
() = liftD2 ()
(*) = distrib (*)
negate = negate >-< 1
abs = abs >-< signum
signum = signum >-< 0
instance ( HasBasis a, s ~ Scalar a, HasTrie (Basis a)
, Fractional s, VectorSpace s, Scalar s ~ s)
=> Fractional (a:>s) where
fromRational = pureD . fromRational
recip = recip >-< recip sqr
sqr :: Num a => a -> a
sqr x = x*x
instance ( HasBasis a, s ~ Scalar a, HasTrie (Basis a)
, Floating s, VectorSpace s, Scalar s ~ s)
=> Floating (a:>s) where
pi = pureD pi
exp = exp >-< exp
log = log >-< recip
sqrt = sqrt >-< recip (2 * sqrt)
sin = sin >-< cos
cos = cos >-< sin
sinh = sinh >-< cosh
cosh = cosh >-< sinh
asin = asin >-< recip (sqrt (1sqr))
acos = acos >-< recip ( sqrt (1sqr))
atan = atan >-< recip (1+sqr)
asinh = asinh >-< recip (sqrt (1+sqr))
acosh = acosh >-< recip ( sqrt (sqr1))
atanh = atanh >-< recip (1sqr)