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 +8/−5
- Numeric/AD/Internal/Dense.hs +155/−0
- Numeric/AD/Internal/Forward.hs +1/−1
- Numeric/AD/Internal/Iterated.hs +0/−185
- Numeric/AD/Internal/Reverse.hs +1/−2
- Numeric/AD/Internal/Sparse.hs +136/−0
- Numeric/AD/Internal/Tensors.hs +3/−1
- Numeric/AD/Internal/Tower.hs +1/−1
- Numeric/AD/Mode/Mixed.hs +12/−3
- ad.cabal +13/−12
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