packages feed

ad 0.33.0 → 0.40

raw patch · 10 files changed

+330/−210 lines, 10 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

- Numeric.AD.Internal.Iterated: (:|) :: a -> f (Iterated f a) -> Iterated f a
- Numeric.AD.Internal.Iterated: bind :: (Traversable f, Num a) => (f (AD (Iterated Forward) a) -> b) -> f a -> f b
- Numeric.AD.Internal.Iterated: bundle :: (Num a) => a -> a -> AD (Iterated Forward) a
- Numeric.AD.Internal.Iterated: data Iterated f a
- Numeric.AD.Internal.Iterated: instance (Foldable f) => Foldable (Iterated f)
- Numeric.AD.Internal.Iterated: instance (Functor f) => Comonad (Iterated f)
- Numeric.AD.Internal.Iterated: instance (Functor f) => Copointed (Iterated f)
- Numeric.AD.Internal.Iterated: instance (Functor f) => Functor (Iterated f)
- Numeric.AD.Internal.Iterated: instance (Mode f) => Lifted (Iterated f)
- Numeric.AD.Internal.Iterated: instance (Mode f) => Mode (Iterated f)
- Numeric.AD.Internal.Iterated: instance (Mode f, Floating a) => Floating (Iterated f a)
- Numeric.AD.Internal.Iterated: instance (Mode f, Fractional a) => Fractional (Iterated f a)
- Numeric.AD.Internal.Iterated: instance (Mode f, Num a) => Num (Iterated f a)
- Numeric.AD.Internal.Iterated: instance (Mode f, Real a) => Real (Iterated f a)
- Numeric.AD.Internal.Iterated: instance (Mode f, RealFloat a) => RealFloat (Iterated f a)
- Numeric.AD.Internal.Iterated: instance (Mode f, RealFrac a) => RealFrac (Iterated f a)
- Numeric.AD.Internal.Iterated: instance (Mode f, Show a) => Show (Iterated f a)
- Numeric.AD.Internal.Iterated: instance (Num a, Mode f, Bounded a) => Bounded (Iterated f a)
- Numeric.AD.Internal.Iterated: instance (Num a, Mode f, Enum a) => Enum (Iterated f a)
- Numeric.AD.Internal.Iterated: instance (Num a, Mode f, Eq a) => Eq (Iterated f a)
- Numeric.AD.Internal.Iterated: instance (Num a, Mode f, Ord a) => Ord (Iterated f a)
- Numeric.AD.Internal.Iterated: instance (Traversable f) => Traversable (Iterated f)
- Numeric.AD.Internal.Iterated: instance (Typeable1 f) => Typeable1 (Iterated f)
- Numeric.AD.Internal.Iterated: instance (Typeable1 f, Data (f (Iterated f a)), Data a) => Data (Iterated f a)
- Numeric.AD.Internal.Iterated: instance (Typeable1 f, Typeable a) => Typeable (Iterated f a)
- Numeric.AD.Internal.Iterated: instance Primal (Iterated f)
- Numeric.AD.Internal.Iterated: tailI :: (Iterated f a) -> f (Iterated f a)
- Numeric.AD.Internal.Iterated: unfoldI :: (Functor f) => (a -> (b, f a)) -> a -> Iterated f b
- Numeric.AD.Mode.Mixed: AD :: f a -> AD f a
- Numeric.AD.Mode.Mixed: newtype AD f a
- Numeric.AD.Mode.Mixed: runAD :: AD f a -> f a
- Numeric.AD.Mode.Mixed: type UF f a = forall s. (Mode s) => AD s a -> f (AD s a)
- Numeric.AD.Mode.Mixed: type FF f g a = forall s. (Mode s) => f (AD s a) -> g (AD s a)
+ Numeric.AD.Internal.Dense: Dense :: a -> (f a) -> Dense f a
+ Numeric.AD.Internal.Dense: Lift :: a -> Dense f a
+ Numeric.AD.Internal.Dense: apply :: (Traversable f, Num a) => (f (AD (Dense f) a) -> b) -> f a -> b
+ Numeric.AD.Internal.Dense: data Dense f a
+ Numeric.AD.Internal.Dense: ds :: f a -> AD (Dense f) a -> f a
+ Numeric.AD.Internal.Dense: ds' :: f a -> AD (Dense f) a -> (a, f a)
+ Numeric.AD.Internal.Dense: instance (Show a) => Show (Dense f a)
+ Numeric.AD.Internal.Dense: instance (Traversable f) => Lifted (Dense f)
+ Numeric.AD.Internal.Dense: instance (Traversable f, Lifted (Dense f)) => Jacobian (Dense f)
+ Numeric.AD.Internal.Dense: instance (Traversable f, Lifted (Dense f)) => Mode (Dense f)
+ Numeric.AD.Internal.Dense: instance Primal (Dense f)
+ Numeric.AD.Internal.Dense: vars :: (Traversable f, Num a) => f a -> f (AD (Dense f) a)
+ Numeric.AD.Internal.Sparse: Index :: (IntMap Int) -> Index
+ Numeric.AD.Internal.Sparse: Sparse :: a -> (IntMap (Sparse a)) -> Sparse a
+ Numeric.AD.Internal.Sparse: addToIndex :: Int -> Index -> Index
+ Numeric.AD.Internal.Sparse: d :: (Traversable f, Num a) => f b -> AD Sparse a -> f a
+ Numeric.AD.Internal.Sparse: d' :: (Traversable f, Num a) => f a -> AD Sparse a -> (a, f a)
+ Numeric.AD.Internal.Sparse: data Sparse a
+ Numeric.AD.Internal.Sparse: ds :: (Traversable f, Num a) => f b -> AD Sparse a -> Stream f a
+ Numeric.AD.Internal.Sparse: emptyIndex :: Index
+ Numeric.AD.Internal.Sparse: indices :: Index -> [Int]
+ Numeric.AD.Internal.Sparse: instance (Data a) => Data (Sparse a)
+ Numeric.AD.Internal.Sparse: instance (Lifted Sparse) => Jacobian Sparse
+ Numeric.AD.Internal.Sparse: instance (Lifted Sparse) => Mode Sparse
+ Numeric.AD.Internal.Sparse: instance (Show a) => Show (Sparse a)
+ Numeric.AD.Internal.Sparse: instance Lifted Sparse
+ Numeric.AD.Internal.Sparse: instance Primal Sparse
+ Numeric.AD.Internal.Sparse: instance Typeable1 Sparse
+ Numeric.AD.Internal.Sparse: newtype Index
+ Numeric.AD.Internal.Sparse: partial :: (Num a) => [Int] -> Sparse a -> a
+ Numeric.AD.Internal.Sparse: skeleton :: (Traversable f) => f a -> f Int
+ Numeric.AD.Internal.Sparse: spartial :: (Num a) => [Int] -> Sparse a -> Maybe a
+ Numeric.AD.Internal.Sparse: vars :: (Traversable f, Num a) => f a -> f (AD Sparse a)
+ Numeric.AD.Mode.Mixed: gradients :: (Traversable f, Num a) => FU f a -> f a -> Stream f a
- Numeric.AD.Internal.Classes: deriveLifted :: Q Type -> Q [Dec]
+ Numeric.AD.Internal.Classes: deriveLifted :: ([Q Pred] -> [Q Pred]) -> Q Type -> Q [Dec]

Files

Numeric/AD/Internal/Classes.hs view
@@ -179,9 +179,13 @@ -- > instance Lifted $t => Jacobian $t where ... -- -- The seemingly redundant @'Lifted' $t@ constraints are caused by Template Haskell staging restrictions.-deriveLifted :: Q Type -> Q [Dec]-deriveLifted _t = [d|-    instance Lifted $_t where+deriveLifted :: ([Q Pred] -> [Q Pred]) -> Q Type -> Q [Dec]+deriveLifted f _t = do+        [InstanceD cxt0 type0 dec0] <- lifted+        return <$> instanceD (cxt (f (return <$> cxt0))) (return type0) (return <$> dec0)+    where +      lifted = [d| +       instance Lifted $_t where         (==!)         = (==) `on` primal         compare1      = compare `on` primal         maxBound1     = lift maxBound@@ -247,8 +251,7 @@         truncate1 = discrete1 truncate         round1    = discrete1 round         ceiling1  = discrete1 ceiling-        floor1    = discrete1 floor-    |]+        floor1    = discrete1 floor |]  varA :: Q Type varA = varT (mkName "a")
+ Numeric/AD/Internal/Dense.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE Rank2Types, TypeFamilies, FlexibleContexts, UndecidableInstances, TemplateHaskell, DeriveDataTypeable, BangPatterns #-}+-- {-# OPTIONS_HADDOCK hide, prune #-}+-----------------------------------------------------------------------------+-- |+-- Module      : Numeric.AD.Internal.Dense+-- Copyright   : (c) Edward Kmett 2010+-- License     : BSD3+-- Maintainer  : ekmett@gmail.com+-- Stability   : experimental+-- Portability : GHC only+--+-- Dense Forward AD. Useful when the result involves the majority of the input+-- elements. Do not use for 'Numeric.AD.Mode.Mixed.hessian' and beyond, since+-- they only contain a small number of unique @n@th derivatives --+-- @(n + k - 1) `choose` k@ for functions of @k@ inputs rather than the+-- @k^n@ that would be generated by using 'Dense', not to mention the redundant+-- intermediate derivatives that would be+-- calculated over and over during that process!+--+-- Assumes all instances of 'f' have the same number of elements.+--+-- NB: We don't need the full power of 'Traversable' here, we could get+-- by with a notion of zippable that can plug in 0's for the missing+-- entries. This might allow for gradients where @f@ has exponentials like @((->) a)@+-----------------------------------------------------------------------------++module Numeric.AD.Internal.Dense+    ( Dense(..)+    , ds+    , ds'+    , vars+    , apply+    ) where++import Language.Haskell.TH+import Data.Typeable ()+import Data.Traversable (Traversable, mapAccumL)+import Data.Data ()+import Numeric.AD.Internal.Types+import Numeric.AD.Internal.Combinators+import Numeric.AD.Internal.Classes+import Numeric.AD.Internal.Identity++data Dense f a+    = Lift a+    | Dense a (f a)++instance Show a => Show (Dense f a) where+    showsPrec n (Lift a) = showsPrec n a+    showsPrec n (Dense a _) = showsPrec n a++ds :: f a -> AD (Dense f) a -> f a+ds _    (AD (Dense _ da)) = da+ds z _                = z+{-# INLINE ds #-}++ds' :: f a -> AD (Dense f) a -> (a, f a)+ds' _    (AD (Dense a da)) = (a, da)+ds' z (AD (Lift a))    = (a, z)+{-# INLINE ds' #-}++-- Bind variables and count inputs+vars :: (Traversable f, Num a) => f a -> f (AD (Dense f) a)+vars as = snd $ mapAccumL outer (0 :: Int) as+    where+        outer !i a = (i + 1, AD $ Dense a $ snd $ mapAccumL (inner i) 0 as)+        inner !i !j _ = (j + 1, if i == j then 1 else 0)+{-# INLINE vars #-}++apply :: (Traversable f, Num a) => (f (AD (Dense f) a) -> b) -> f a -> b+apply f as = f (vars as)+{-# INLINE apply #-}++instance Primal (Dense f) where+    primal (Lift a) = a+    primal (Dense a _) = a++instance (Traversable f, Lifted (Dense f)) => Mode (Dense f) where+    lift = Lift+    Lift a <+> Lift b = Lift (a + b)+    Lift a <+> Dense b db = Dense (a + b) db+    Dense a da <+> Lift b = Dense (a + b) da+    Dense a da <+> Dense b db = Dense (a + b) $ zipWithT (+) da db+    a *^ Lift b    = Lift (a * b)+    a *^ Dense b db = Dense (a * b) $ fmap (a*) db+    Lift a    ^* b = Lift (a * b)+    Dense a da ^* b = Dense (a * b) $ fmap (*b) da+    Lift a    ^/ b = Lift (a / b)+    Dense a da ^/ b = Dense (a / b) $ fmap (/b) da++instance (Traversable f, Lifted (Dense f)) => Jacobian (Dense f) where+    type D (Dense f) = Id+    unary f _         (Lift b)    = Lift (f b)+    unary f (Id dadb) (Dense b db) = Dense (f b) (fmap (dadb *) db)++    lift1 f _  (Lift b)    = Lift (f b)+    lift1 f df (Dense b db) = Dense (f b) (fmap (dadb *) db)+        where+            Id dadb = df (Id b)++    lift1_ f _  (Lift b)     = Lift (f b)+    lift1_ f df (Dense b db) = Dense a (fmap (dadb *) db)+        where+            a = f b+            Id dadb = df (Id a) (Id b)++    binary f _ _ (Lift b) (Lift c)+        = Lift (f b c)+    binary f _ (Id dadc) (Lift b) (Dense c dc)+        = Dense (f b c) $ fmap (* dadc) dc+    binary f (Id dadb) _ (Dense b db) (Lift c)+        = Dense (f b c) $ fmap (dadb *) db+    binary f (Id dadb) (Id dadc) (Dense b db) (Dense c dc)+        = Dense (f b c) $ zipWithT productRule db dc+        where+            productRule dbi dci = dadb * dbi + dci * dadc++    lift2 f _  (Lift b) (Lift c)+        = Lift (f b c)+    lift2 f df (Lift b) (Dense c dc)+        = Dense (f b c) $ fmap (*dadc) dc+        where+            (_, Id dadc) = df (Id b) (Id c)+    lift2 f df (Dense b db) (Lift c)+        = Dense (f b c) $ fmap (dadb*) db+        where+            (Id dadb, _) = df (Id b) (Id c)+    lift2 f df (Dense b db) (Dense c dc) = Dense (f b c) da+        where+            (Id dadb, Id dadc) = df (Id b) (Id c)+            da = zipWithT productRule db dc+            productRule dbi dci = dadb * dbi + dci * dadc++    lift2_ f _  (Lift b) (Lift c) = Lift (f b c)+    lift2_ f df (Lift b) (Dense c dc)+        = Dense a $ fmap (*dadc) dc+        where+            a = (f b c)+            (_, Id dadc) = df (Id a) (Id b) (Id c)+    lift2_ f df (Dense b db) (Lift c)+        = Dense a $ fmap (dadb*) db+        where+            a = (f b c)+            (Id dadb, _) = df (Id a) (Id b) (Id c)+    lift2_ f df (Dense b db) (Dense c dc)+        = Dense a $ zipWithT productRule db dc+        where+            a = f b c+            (Id dadb, Id dadc) = df (Id a) (Id b) (Id c)+            productRule dbi dci = dadb * dbi + dci * dadc++let f = varT (mkName "f") in+    deriveLifted+        (classP ''Traversable [f]:)+        (conT ''Dense `appT` f)
Numeric/AD/Internal/Forward.hs view
@@ -90,7 +90,7 @@             (Id dadb, Id dadc) = df (Id a) (Id b) (Id c)             da = dadb * db + dc * dadc -deriveLifted $ conT ''Forward+deriveLifted id $ conT ''Forward  bind :: (Traversable f, Num a) => (f (AD Forward a) -> b) -> f a -> f b bind f as = snd $ mapAccumL outer (0 :: Int) as
− Numeric/AD/Internal/Iterated.hs
@@ -1,185 +0,0 @@-{-# LANGUAGE BangPatterns, TemplateHaskell, ScopedTypeVariables, DeriveDataTypeable, FlexibleContexts, UndecidableInstances #-}--- {-# OPTIONS_HADDOCK hide #-}--------------------------------------------------------------------------------- |--- Module      :  Numeric.AD.Internal.Iterated--- Copyright   :  (c) Edward Kmett 2010--- License     :  BSD3--- Maintainer  :  ekmett@gmail.com--- Stability   :  experimental--- Portability :  GHC only-----------------------------------------------------------------------------------module Numeric.AD.Internal.Iterated-    ( Iterated(..)-    , tailI-    , unfoldI-    , bundle-    , bind-    ) where--import Control.Applicative-import Data.Monoid-import Data.Foldable-import Data.Traversable-import Data.Data (Data(..), mkDataType, DataType, mkConstr, Constr, constrIndex, Fixity(Infix))-import Data.Typeable (Typeable1(..), Typeable(..), TyCon, mkTyCon, mkTyConApp, typeOfDefault, gcast1)-import Numeric.AD.Internal.Types-import Numeric.AD.Internal.Classes-import Numeric.AD.Internal.Comonad-import Numeric.AD.Internal.Combinators (on)--- import qualified Numeric.AD.Internal.Forward-import Numeric.AD.Internal.Forward (Forward(..))-import Language.Haskell.TH--infixl 3 :|--data Iterated f a = a :| f (Iterated f a)--bundle :: Num a => a -> a -> AD (Iterated Forward) a-bundle a b = AD (a :| Forward (lift a) (lift b))--bind :: (Traversable f, Num a) => (f (AD (Iterated Forward) a) -> b) -> f a -> f b-bind f as = snd $ mapAccumL outer (0 :: Int) as-    where-        outer !i _ = (i + 1, f $ snd $ mapAccumL (inner i) 0 as)-        inner !i !j a = (j + 1, bundle a $ if i == j then 1 else 0)--instance Functor f => Functor (Iterated f) where-    fmap f (a :| as) = f a :| fmap f <$> as--instance Functor f => Copointed (Iterated f) where-    extract (a :| _) = a--instance Functor f => Comonad (Iterated f) where-    duplicate aas@(_ :| as) = aas :| duplicate <$> as-    extend f aas@(_ :| as) = f aas :| extend f <$> as--instance Foldable f => Foldable (Iterated f) where-    foldMap f (a :| as) = f a `mappend` foldMap (foldMap f) as--instance Traversable f => Traversable (Iterated f) where-    traverse f (a :| as) = (:|) <$> f a <*> traverse (traverse f) as---- tails of the f-branching stream comonad/cofree comonad-tailI :: (Iterated f a) -> f (Iterated f a)-tailI (_ :| as) = as--unfoldI :: Functor f => (a -> (b, f a)) -> a -> Iterated f b-unfoldI f a = h :| unfoldI f <$> t-    where-        (h, t) = f a--instance Primal (Iterated f) where-    primal (a :| _) = a--instance Mode f => Mode (Iterated f) where-    lift a = as-        where as = a :| lift as-    (a :| as) <+> (b :| bs) = (a + b) :| (as <+> bs)-    a *^ (b :| bs) = (a * b) :| (lift a *^ bs)-    (a :| as) ^* b = (a * b) :| (as ^* lift b)-    (a :| as) ^/ b = (a / b) :| (as ^/ lift b)--instance Mode f => Lifted (Iterated f) where-    showsPrec1 n (a :| _) = showsPrec n a-    (==!) = (==) `on` primal-    compare1 = compare `on` primal-    fromInteger1 a = fromInteger a :| fromInteger1 a-    (a :| as) +! (b :| bs) = (a + b) :| (as +! bs)-    (a :| as) -! (b :| bs) = (a - b) :| (as -! bs)-    (a :| as) *! (b :| bs) = (a * b) :| (as *! bs)-    negate1 (a :| as) = negate a :| negate1 as-    abs1 (a :| as) = abs a :| abs1 as-    signum1 (a :| as) = signum a :| signum1 as-    (a :| as) /! (b :| bs) = (a / b) :| (as /! bs)-    recip1 (a :| as) = recip a :| recip1 as-    fromRational1 n = fromRational n :| fromRational1 n-    toRational1 = toRational . primal-    pi1 = pi :| pi1-    exp1 (a :| as) = exp a :| exp1 as-    log1 (a :| as) = log a :| log1 as-    sqrt1 (a :| as) = sqrt a :| sqrt1 as-    (a :| as) **! (b :| bs) = (a ** b) :| (as **! bs)-    logBase1 (a :| as) (b :| bs) = logBase a b :| logBase1 as bs-    sin1 (a :| as) = sin a :| sin1 as-    cos1 (a :| as) = cos a :| cos1 as-    tan1 (a :| as) = tan a :| tan1 as-    asin1 (a :| as) = asin a :| asin1 as-    acos1 (a :| as) = acos a :| acos1 as-    atan1 (a :| as) = atan a :| atan1 as-    sinh1 (a :| as) = sinh a :| sinh1 as-    cosh1 (a :| as) = cosh a :| cosh1 as-    tanh1 (a :| as) = tanh a :| tanh1 as-    asinh1 (a :| as) = asinh a :| asinh1 as-    acosh1 (a :| as) = acosh a :| acosh1 as-    atanh1 (a :| as) = atanh a :| atanh1 as-    properFraction1 (a :| as) = (b, c :| cs)-        where-            (b, c) = properFraction a-            (_ :: Int, cs) = properFraction1 as-    truncate1 = truncate . primal-    round1 = round . primal-    ceiling1 = ceiling . primal-    floor1  = floor . primal-    floatRadix1 = floatRadix . primal-    floatDigits1 = floatDigits . primal-    floatRange1 = floatRange . primal-    decodeFloat1 = decodeFloat . primal-    encodeFloat1 m e = encodeFloat m e :| encodeFloat1 m e-    exponent1 = exponent . primal-    significand1 (a :| as) = significand a :| significand1 as-    scaleFloat1 n (a :| as) = scaleFloat n a :| scaleFloat1 n as-    isNaN1 = isNaN . primal-    isInfinite1 = isInfinite . primal-    isDenormalized1 = isDenormalized . primal-    isNegativeZero1 = isNegativeZero . primal-    isIEEE1 = isIEEE . primal-    atan21 (a :| as) (b :| bs) = atan2 a b :| atan21 as bs-    succ1 (a :| as) = succ a :| succ1 as-    pred1 (a :| as) = pred a :| pred1 as-    toEnum1 n = toEnum n :| toEnum1 n-    fromEnum1 = fromEnum . primal-    enumFrom1 = error "TODO"-    enumFromThen1 = error "TODO"-    enumFromTo1 = error "TODO"-    enumFromThenTo1 = error "TODO"-    minBound1 = minBound :| minBound1-    maxBound1 = maxBound :| maxBound1-    -- TODO:---- instance (Mode f, Foo a) => Foo (Iterated f) ...-deriveNumeric-    (classP (mkName "Mode") [varT $ mkName "f"]:)-    (conT (mkName "Iterated") `appT` varT (mkName "f"))--instance Typeable1 f => Typeable1 (Iterated f) where-    typeOf1 tfa = mkTyConApp iteratedTyCon [typeOf1 (undefined `asArgsType` tfa)]-        where asArgsType :: f a -> t f a -> f a-              asArgsType = const--instance (Typeable1 f, Typeable a) => Typeable (Iterated f a) where-    typeOf = typeOfDefault-    -iteratedTyCon :: TyCon-iteratedTyCon = mkTyCon "Numeric.AD.Internal.Iterated.Iterated"-{-# NOINLINE iteratedTyCon #-}--consConstr :: Constr-consConstr = mkConstr iteratedDataType "(:|)" [] Infix-{-# NOINLINE consConstr #-}--iteratedDataType :: DataType-iteratedDataType = mkDataType "Numeric.AD.Internal.Iterated.Iterated" [consConstr]-{-# NOINLINE iteratedDataType #-}--instance (Typeable1 f, Data (f (Iterated f a)), Data a) => Data (Iterated f a) where-    gfoldl f z (a :| as) = z (:|) `f` a `f` as-    toConstr _ = consConstr-    gunfold k z c = case constrIndex c of-        1 -> k (k (z (:|)))-        _ -> error "gunfold"-    dataTypeOf _ = iteratedDataType-    dataCast1 f = gcast1 f-
Numeric/AD/Internal/Reverse.hs view
@@ -116,8 +116,7 @@             a = f pb pc             (dadb, dadc) = df (Id a) (Id pb) (Id pc) -deriveLifted (conT ''Reverse)--- deriveNumeric  ''Reverse+deriveLifted id (conT ''Reverse)  derivative :: Num a => AD Reverse a -> a derivative = sum . map snd . partials
+ Numeric/AD/Internal/Sparse.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE BangPatterns, TemplateHaskell, TypeFamilies, TypeOperators, FlexibleContexts, UndecidableInstances, DeriveDataTypeable #-}+module Numeric.AD.Internal.Sparse +    ( Index(..)+    , emptyIndex+    , addToIndex+    , indices+    , Sparse(..)+    , vars+    , d+    , d'+    , ds+    , skeleton+    , spartial+    , partial+    ) where++import Prelude hiding (lookup)+import Control.Applicative+import Numeric.AD.Internal.Classes+import Numeric.AD.Internal.Stream+import Numeric.AD.Internal.Types+import Data.Data+import Data.Typeable ()+import qualified Data.IntMap as IntMap +import Data.IntMap (IntMap, mapWithKey, unionWith, findWithDefault, toAscList, singleton, insertWith, lookup)+import Data.Traversable+import Language.Haskell.TH++newtype Index = Index (IntMap Int)++emptyIndex :: Index+emptyIndex = Index IntMap.empty+{-# INLINE emptyIndex #-}++addToIndex :: Int -> Index -> Index+addToIndex k (Index m) = Index (insertWith (+) k 1 m)+{-# INLINE addToIndex #-}++indices :: Index -> [Int]+indices (Index as) = uncurry (flip replicate) `concatMap` toAscList as+{-# INLINE indices #-}++-- | We only store partials in sorted order, so the map contained in a partial+-- will only contain partials with equal or greater keys to that of the map in+-- which it was found. This should be key for efficiently computing sparse hessians.+-- there are only (n + k - 1) choose k distinct nth partial derivatives of a +-- function with k inputs.+data Sparse a = Sparse a (IntMap (Sparse a)) deriving (Show, Data, Typeable)++-- | drop keys below a given value+dropMap :: Int -> IntMap a -> IntMap a+dropMap n = snd . IntMap.split (n - 1) +{-# INLINE dropMap #-}++times :: Num a => Sparse a -> Int -> Sparse a -> Sparse a+times (Sparse a as) n (Sparse b bs) = Sparse (a * b) $+    unionWith (<+>) +        (fmap (^* b) (dropMap n as))+        (fmap (a *^) (dropMap n bs))+{-# INLINE times #-}++vars :: (Traversable f, Num a) => f a -> f (AD Sparse a)+vars = snd . mapAccumL var 0 +    where+        var !n a = (n + 1, AD $ Sparse a $ singleton n $ lift 1)+{-# INLINE vars #-}++skeleton :: Traversable f => f a -> f Int+skeleton = snd . mapAccumL (\ !n _ -> (n + 1, n)) 0+{-# INLINE skeleton #-}++d :: (Traversable f, Num a) => f b -> AD Sparse a -> f a+d fs (AD (Sparse _ da)) = snd $ mapAccumL (\ !n _ -> (n + 1, maybe 0 primal $ lookup n da)) 0 fs+{-# INLINE d #-}++d' :: (Traversable f, Num a) => f a -> AD Sparse a -> (a, f a)+d' fs (AD (Sparse a da)) = (a , snd $ mapAccumL (\ !n _ -> (n + 1, maybe 0 primal $ lookup n da)) 0 fs)+{-# INLINE d' #-}++ds :: (Traversable f, Num a) => f b -> AD Sparse a -> Stream f a+ds fs (AD as@(Sparse a _)) = a :< (go emptyIndex <$> fns)+    where+        fns = skeleton fs+        -- go :: Index -> Int -> Stream f a+        go ix i = partial (indices ix') as :< (go ix' <$> fns)+            where ix' = addToIndex i ix+{-# INLINE ds #-}++partial :: Num a => [Int] -> Sparse a -> a+partial []     (Sparse a _)  = a+partial (n:ns) (Sparse _ da) = partial ns $ findWithDefault (lift 0) n da+{-# INLINE partial #-}++spartial :: Num a => [Int] -> Sparse a -> Maybe a+spartial [] (Sparse a _) = Just a+spartial (n:ns) (Sparse _ da) = do+    a' <- lookup n da+    spartial ns a'+{-# INLINE spartial #-}++instance Primal Sparse where+    primal (Sparse a _) = a++instance Lifted Sparse => Mode Sparse where+    lift a = Sparse a (IntMap.empty)+    Sparse a as <+> Sparse b bs = Sparse (a + b) $ unionWith (<+>) as bs+    Sparse a as ^* b = Sparse (a * b) $ fmap (^* b) as+    a *^ Sparse b bs = Sparse (a * b) $ fmap (a *^) bs+    Sparse a as ^/ b = Sparse (a / b) $ fmap (^/ b) as++instance Lifted Sparse => Jacobian Sparse where+    type D Sparse = Sparse+    unary f dadb (Sparse pb bs) = Sparse (f pb) $ mapWithKey (times dadb) bs+    lift1 f df b@(Sparse pb bs) = Sparse (f pb) $ mapWithKey (times (df b)) bs+    lift1_ f df b@(Sparse pb bs) = a where+        a = Sparse (f pb) $ mapWithKey (times (df a b)) bs++    binary f dadb dadc (Sparse pb db) (Sparse pc dc) = Sparse (f pb pc) $ +        unionWith (<+>) +            (mapWithKey (times dadb) db)+            (mapWithKey (times dadc) dc)++    lift2 f df b@(Sparse pb db) c@(Sparse pc dc) = Sparse (f pb pc) da where+        (dadb, dadc) = df b c+        da = unionWith (<+>) +            (mapWithKey (times dadb) db)+            (mapWithKey (times dadc) dc)+        +    lift2_ f df b@(Sparse pb db) c@(Sparse pc dc) = a where+        (dadb, dadc) = df a b c+        a = Sparse (f pb pc) da+        da = unionWith (<+>) +            (mapWithKey (times dadb) db)+            (mapWithKey (times dadc) dc)++deriveLifted id $ conT ''Sparse
Numeric/AD/Internal/Tensors.hs view
@@ -28,8 +28,10 @@  infixl 3 :- +-- Polymorphic recursion precludes 'Data' in its current form, as no Data1 class exists+-- Polymorphic recursion also breaks 'show' for 'Tensors'!+-- factor Show1 out of Lifted? data Tensors f a = a :- Tensors f (f a)--- Polymorphic recursion precludes Data in its current form, as no Data1 class exists  instance Functor f => Functor (Tensors f) where     fmap f (a :- as) = f a :- fmap (fmap f) as
Numeric/AD/Internal/Tower.hs view
@@ -133,4 +133,4 @@         a = bundle a0 da         (dadb, dadc) = df a b c -deriveLifted (conT ''Tower)+deriveLifted id (conT ''Tower)
Numeric/AD/Mode/Mixed.hs view
@@ -53,6 +53,9 @@     , hessianProduct     , hessianProduct' +    -- * Higher Order Gradients/Hessians (Sparse Forward)+    , gradients+     -- * Derivatives (Forward Mode)     , diff     , diffF@@ -92,8 +95,7 @@     , diffM'      -- * Exposed Types-    , UU, UF, FU, FF-    , AD(..)+    , module Numeric.AD.Types     , Mode(..)     ) where @@ -101,7 +103,7 @@ import Data.Foldable (Foldable, foldr') import Control.Applicative -import Numeric.AD.Types (AD(..), UU, UF, FU, FF)+import Numeric.AD.Types import Numeric.AD.Internal.Identity (probed, unprobe) import Numeric.AD.Internal.Composition import Numeric.AD.Classes (Mode(..))@@ -127,6 +129,9 @@     , gradF, gradF', gradWithF, gradWithF'     ) +-- temporary until we make a full sparse mode+import qualified Numeric.AD.Internal.Sparse as Sparse+ -- | Calculate the Jacobian of a non-scalar-to-non-scalar function, automatically choosing between forward and reverse mode AD based on the number of inputs and outputs. -- -- If you need to support functions where the output is only a 'Functor' or 'Monad', consider 'Numeric.AD.Reverse.jacobian' or 'Numeric.AD.Reverse.gradM' from "Numeric.AD.Reverse".@@ -213,3 +218,7 @@     dda = Forward.jacobian (grad (decomposeMode . f . fmap composeMode)     ddda = Forward -}++gradients :: (Traversable f, Num a) => FU f a -> f a -> Stream f a+gradients f as = Sparse.ds as $ f $ Sparse.vars as+    
ad.cabal view
@@ -1,5 +1,5 @@ name:         ad-version:      0.33.0+version:      0.40 license:      BSD3 license-File: LICENSE copyright:    (c) Edward Kmett 2010,@@ -34,22 +34,24 @@     Numeric.AD.Types     Numeric.AD.Newton -    Numeric.AD.Mode.Mixed-    Numeric.AD.Mode.Forward-    Numeric.AD.Mode.Reverse-    Numeric.AD.Mode.Tower-    Numeric.AD.Mode.Directed-     Numeric.AD.Internal.Classes     Numeric.AD.Internal.Combinators -    Numeric.AD.Internal.Composition     Numeric.AD.Internal.Forward-    Numeric.AD.Internal.Reverse     Numeric.AD.Internal.Tower+    Numeric.AD.Internal.Reverse+    Numeric.AD.Internal.Sparse+    Numeric.AD.Internal.Dense+    Numeric.AD.Internal.Composition     Numeric.AD.Internal.Identity-    Numeric.AD.Internal.Iterated +    Numeric.AD.Mode.Directed+    Numeric.AD.Mode.Forward+    Numeric.AD.Mode.Mixed+    Numeric.AD.Mode.Reverse+    Numeric.AD.Mode.Tower++ other-modules:     Numeric.AD.Internal.Types     Numeric.AD.Internal.Comonad@@ -57,5 +59,4 @@     Numeric.AD.Internal.Tensors  Extra-Source-Files: TODO-GHC-Options: -Wall -fspec-constr ---           -O2+GHC-Options: -Wall -fspec-constr -fdicts-cheap -O2