diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,36 @@ Changelog ========= +Version 0.2.0.0 +--------------- + +*May 1, 2018* + + + +* Added `Backprop` class in *Numeric.Backprop.Class*, which is a typeclass + specifically for "backpropagatable" values. This will replace `Num`. +* API of *Numeric.Backprop* completely re-written to require values be + instances of `Backprop` instead of `Num`. This closes some outstanding + issues with the reliance of `Num`, and allows backpropagation to work with + non-Num instances like variable-length vectors, matrices, lists, tuples, + etc. (including types from *accelerate*) +* *Numeric.Backprop.Num* and *Prelude.Backprop.Num* modules added, providing + the old interface that uses `Num` instances instead of `Backprop` + instances, for those who wish to avoid writing orphan instances when + working with external types. +* *Numeric.Backprop.Explicit* and *Prelude.Backprop.Explicit* modules added, + providing an interface that allows users to manually specify how zeroing, + addition, and one-ing works on a per-value basis. Useful for those who + wish to avoid writing orphan instances of `Backprop` for types with no + `Num` instances, or if you are mixing and matching styles. +* `backpropWith` variants added, allowing you to specify a "final gradient", + instead of assuming it to be 1. +* Added `auto`, a shorter alias for `constVar` inspired by the *ad* library. +* *Numeric.Backprop.Tuple* module removed. I couldn't find a significant + reason to keep it now that `Num` is no longer required for backpropagation. + + Version 0.1.5.2 --------------- diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -246,53 +246,6 @@ 2. Write tests! -3. Explore potentially ditching `Num` for another typeclass that only has `+`, - `0`, and `1`. Currently, `Num` is required for all backpropagated types, - but only `+`, `fromInteger 0`, and `fromInteger 1` are ever used. - - The main upside to using `Num` is that it integrates well with the rest of - the Haskell ecosystem, and many things already have useful `Num` instances. - - There are two downsides -- one minor and one major. - - * It requires more work to make a type backpropagatable. Instead of - writing only `+`, `0` and `1`, users must also define `*`, `-` or - `negate`, `abs`, `signum`, and all of `fromInteger`. However, I don't - see this being a big issue in practice, since most values that will be - used with *backprop* would presumably also benefit from having a full - `Num` instance even without the need to backprop. - - * Automatically generated prisms (used with `^^?`) work with tuples, and - so cannot work out-of-the-box without a `Num` instance for tuples. In - addition, it's often useful to have anonymous products and tuples in - general. - - This is bandaided-over by having *backprop* provide canonical - tuple-with-`Num` types for different libraries to use, but it's not a - perfect solution. - - This can be resolved by using the orphan instances in the - *[NumInstances][]* package. Still, there might be some headache for - application developers if different libraries using *backprop* - accidentally pull in their orphan instances from different places. - - [NumInstances]: https://hackage.haskell.org/package/NumInstances - - Alternatively, one day we can get `Num` instances for tuples into - *base*! - - The extra complexity that would come from adding a custom typeclass just - for `+` / `0` / `1`, though, I feel, might not be worth the benefit. The - entire numeric Haskell ecosystem, at the time, revolves around `Num`. - - However, it is worth noting that it wouldn't be too hard to add "Additive - Typeclass" instances for any custom types -- one would just need to define - `(<+>) = (+)`, `zero = fromInteger 0`, and `one = fromInteger 1` (a - three-liner), so it might not be too bad. - - But really, a lot of this would all resolve itself if we got `Num` - instances for tuples in base :) - 3. Explore opportunities for parallelization. There are some naive ways of directly parallelizing right now, but potential overhead should be investigated. diff --git a/backprop.cabal b/backprop.cabal --- a/backprop.cabal +++ b/backprop.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 1a3823df38b9b0fe0ecb1481bea9f4b591e24a0abe5f96c21bf88c2b6055851b +-- hash: 0ba2801ba9787e38a25a6b3a1f48172558ed7066726034c01b1f3b01b9ee17fa name: backprop -version: 0.1.5.2 +version: 0.2.0.0 synopsis: Heterogeneous automatic differentation (backpropagation) description: Write your functions to compute your result, and the library will automatically generate functions to compute your gradient. @@ -47,20 +47,23 @@ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wredundant-constraints -fprint-explicit-kinds build-depends: base >=4.7 && <5 - , binary + , containers , deepseq , microlens , primitive - , random , reflection , transformers , type-combinators , vector exposed-modules: Numeric.Backprop + Numeric.Backprop.Class + Numeric.Backprop.Explicit + Numeric.Backprop.Num Numeric.Backprop.Op - Numeric.Backprop.Tuple Prelude.Backprop + Prelude.Backprop.Explicit + Prelude.Backprop.Num other-modules: Numeric.Backprop.Internal Data.Type.Util diff --git a/bench/bench.hs b/bench/bench.hs --- a/bench/bench.hs +++ b/bench/bench.hs @@ -25,6 +25,7 @@ import GHC.Generics (Generic) import GHC.TypeLits import Numeric.Backprop +import Numeric.Backprop.Class import Numeric.LinearAlgebra.Static import System.Directory import qualified Data.Vector.Generic as VG @@ -314,21 +315,15 @@ uniform g = Net <$> MWC.uniform g <*> MWC.uniform g <*> MWC.uniform g uniformR (l, h) g = (\x -> x * (h - l) + l) <$> MWC.uniform g -instance (Num a, Num b) => Num (a, b) where - (x1,y1) + (x2,y2) = (x1 + x2, y1 + y2) - (x1,y1) * (x2,y2) = (x1 * x2, y1 * y2) - (x1,y1) - (x2,y2) = (x1 - x2, y1 - y2) - abs (x, y) = (abs x, abs y) - signum (x, y) = (signum x, signum y) - fromInteger x = (fromInteger x, fromInteger x) +instance Backprop (R n) where + zero = zeroNum + add = addNum + one = oneNum --- softMaxCrossEntropy --- :: KnownNat n --- => R n --- -> BPOpI s '[ R n ] Double --- softMaxCrossEntropy targ (r :< Ø) = realToFrac tsum * log (vsum .$ (r :< Ø)) --- - (dot .$ (r :< t :< Ø)) --- where --- tsum = HM.sumElements . extract $ targ --- t = constVar targ +instance (KnownNat n, KnownNat m) => Backprop (L m n) where + zero = zeroNum + add = addNum + one = oneNum +instance (KnownNat i, KnownNat o) => Backprop (Layer i o) +instance (KnownNat i, KnownNat h1, KnownNat h2, KnownNat o) => Backprop (Network i h1 h2 o) diff --git a/renders/backprop-mnist.md b/renders/backprop-mnist.md --- a/renders/backprop-mnist.md +++ b/renders/backprop-mnist.md @@ -67,6 +67,7 @@ import GHC.Generics (Generic) import GHC.TypeLits import Numeric.Backprop +import Numeric.Backprop.Class import Numeric.LinearAlgebra.Static import Numeric.OneLiner import Text.Printf @@ -206,6 +207,15 @@ refer to the numbers in its type and use it to go about its normal hmatrixy business. +Now we need instances of `Backprop` for our types in order to use them +for automatic differentiation. Luckily, these can be generated +automatically using GHC Generics: + +``` {.sourceCode .literate .haskell} +instance (KnownNat i, KnownNat o) => Backprop (Layer i o) +instance (KnownNat i, KnownNat h1, KnownNat h2, KnownNat o) => Backprop (Network i h1 h2 o) +``` + Ops === @@ -688,4 +698,21 @@ => MWC.Variate (Network i h1 h2 o) where uniform g = Net <$> MWC.uniform g <*> MWC.uniform g <*> MWC.uniform g uniformR (l, h) g = (\x -> x * (h - l) + l) <$> MWC.uniform g +``` + +Also, some orphan instances of `Backprop` for vector and matrix types. +These are provided by the [hmatrix-backprop] library normally: + + [hmatrix-backprop]: http://hackage.haskell.org/package/hmatrix-backprop + +``` {.sourceCode .literate .haskell} +instance Backprop (R n) where + zero = zeroNum + add = addNum + one = oneNum + +instance (KnownNat n, KnownNat m) => Backprop (L m n) where + zero = zeroNum + add = addNum + one = oneNum ``` diff --git a/renders/backprop-mnist.pdf b/renders/backprop-mnist.pdf Binary files a/renders/backprop-mnist.pdf and b/renders/backprop-mnist.pdf differ diff --git a/renders/extensible-neural.md b/renders/extensible-neural.md --- a/renders/extensible-neural.md +++ b/renders/extensible-neural.md @@ -62,6 +62,7 @@ import Data.Tuple import GHC.Generics (Generic) import Numeric.Backprop +import Numeric.Backprop.Class import Numeric.LinearAlgebra.Static import Numeric.OneLiner import Text.Printf @@ -436,7 +437,9 @@ recip = gRecip fromRational = gFromRational +instance (KnownNat i, KnownNat o) => Backprop (Layer i o) + liftNet0 :: forall i hs o. (KnownNat i, KnownNat o) => (forall m n. (KnownNat m, KnownNat n) => Layer m n) @@ -518,6 +521,11 @@ recip = liftNet1 negate sing fromRational x = liftNet0 (fromRational x) sing +instance (KnownNat i, KnownNat o, SingI hs) => Backprop (Net i hs o) where + zero = liftNet1 zero sing + add = liftNet2 add sing + one = liftNet1 one sing + instance KnownNat n => MWC.Variate (R n) where uniform g = randomVector <$> MWC.uniform g <*> pure Uniform uniformR (l, h) g = (\x -> x * (h - l) + l) <$> MWC.uniform g @@ -548,4 +556,14 @@ rnf = \case NO l -> rnf l x :~ xs -> rnf x `seq` rnf xs + +instance Backprop (R n) where + zero = zeroNum + add = addNum + one = oneNum + +instance (KnownNat n, KnownNat m) => Backprop (L m n) where + zero = zeroNum + add = addNum + one = oneNum ``` diff --git a/renders/extensible-neural.pdf b/renders/extensible-neural.pdf Binary files a/renders/extensible-neural.pdf and b/renders/extensible-neural.pdf differ diff --git a/samples/backprop-mnist.lhs b/samples/backprop-mnist.lhs --- a/samples/backprop-mnist.lhs +++ b/samples/backprop-mnist.lhs @@ -63,6 +63,7 @@ > import GHC.Generics (Generic) > import GHC.TypeLits > import Numeric.Backprop +> import Numeric.Backprop.Class > import Numeric.LinearAlgebra.Static > import Numeric.OneLiner > import Text.Printf @@ -192,6 +193,13 @@ to the numbers in its type and use it to go about its normal hmatrixy business. +Now we need instances of `Backprop` for our types in order to use them for +automatic differentiation. Luckily, these can be generated automatically +using GHC Generics: + +> instance (KnownNat i, KnownNat o) => Backprop (Layer i o) +> instance (KnownNat i, KnownNat h1, KnownNat h2, KnownNat o) => Backprop (Network i h1 h2 o) + Ops === @@ -626,3 +634,17 @@ > uniform g = Net <$> MWC.uniform g <*> MWC.uniform g <*> MWC.uniform g > uniformR (l, h) g = (\x -> x * (h - l) + l) <$> MWC.uniform g +Also, some orphan instances of `Backprop` for vector and matrix types. These +are provided by the [hmatrix-backprop][] library normally: + +> instance Backprop (R n) where +> zero = zeroNum +> add = addNum +> one = oneNum +> +> instance (KnownNat n, KnownNat m) => Backprop (L m n) where +> zero = zeroNum +> add = addNum +> one = oneNum + +[hmatrix-backprop]: http://hackage.haskell.org/package/hmatrix-backprop diff --git a/samples/extensible-neural.lhs b/samples/extensible-neural.lhs --- a/samples/extensible-neural.lhs +++ b/samples/extensible-neural.lhs @@ -59,6 +59,7 @@ > import Data.Tuple > import GHC.Generics (Generic) > import Numeric.Backprop +> import Numeric.Backprop.Class > import Numeric.LinearAlgebra.Static > import Numeric.OneLiner > import Text.Printf @@ -414,7 +415,9 @@ > recip = gRecip > fromRational = gFromRational > +> instance (KnownNat i, KnownNat o) => Backprop (Layer i o) > +> > liftNet0 > :: forall i hs o. (KnownNat i, KnownNat o) > => (forall m n. (KnownNat m, KnownNat n) => Layer m n) @@ -496,6 +499,11 @@ > recip = liftNet1 negate sing > fromRational x = liftNet0 (fromRational x) sing > +> instance (KnownNat i, KnownNat o, SingI hs) => Backprop (Net i hs o) where +> zero = liftNet1 zero sing +> add = liftNet2 add sing +> one = liftNet1 one sing +> > instance KnownNat n => MWC.Variate (R n) where > uniform g = randomVector <$> MWC.uniform g <*> pure Uniform > uniformR (l, h) g = (\x -> x * (h - l) + l) <$> MWC.uniform g @@ -526,3 +534,15 @@ > rnf = \case > NO l -> rnf l > x :~ xs -> rnf x `seq` rnf xs +> +> instance Backprop (R n) where +> zero = zeroNum +> add = addNum +> one = oneNum +> +> instance (KnownNat n, KnownNat m) => Backprop (L m n) where +> zero = zeroNum +> add = addNum +> one = oneNum + +[hmatrix-backprop]: http://hackage.haskell.org/package/hmatrix-backprop diff --git a/src/Data/Type/Util.hs b/src/Data/Type/Util.hs --- a/src/Data/Type/Util.hs +++ b/src/Data/Type/Util.hs @@ -11,11 +11,13 @@ , unzipP , zipP , zipWithPM_ + , zipWithPM3_ , vecToProd , vecLen , lengthProd , listToVecDef , fillProd + , zipVecList ) where import Data.Bifunctor @@ -66,6 +68,23 @@ x :< xs -> \case y :< ys -> f x y *> go xs ys +zipWithPM3_ + :: forall m f g h as. Applicative m + => (forall a. f a -> g a -> h a -> m ()) + -> Prod f as + -> Prod g as + -> Prod h as + -> m () +zipWithPM3_ f = go + where + go :: forall bs. Prod f bs -> Prod g bs -> Prod h bs -> m () + go = \case + Ø -> \case + Ø -> \case + Ø -> pure () + x :< xs -> \case + y :< ys -> \case + z :< zs -> f x y z *> go xs ys zs zipP :: Prod f as @@ -122,3 +141,18 @@ x :< xs -> \case [] -> Nothing y:ys -> (f x y :<) <$> go xs ys + +zipVecList + :: forall a b c f g n. () + => (f a -> Maybe b -> g c) + -> VecT n f a + -> [b] + -> VecT n g c +zipVecList f = go + where + go :: VecT m f a -> [b] -> VecT m g c + go = \case + ØV -> const ØV + x :* xs -> \case + [] -> f x Nothing :* go xs [] + y:ys -> f x (Just y) :* go xs ys diff --git a/src/Numeric/Backprop.hs b/src/Numeric/Backprop.hs --- a/src/Numeric/Backprop.hs +++ b/src/Numeric/Backprop.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} -- | -- Module : Numeric.Backprop @@ -46,17 +47,28 @@ -- and links to demonstrations and tutorials, or dive striaght in by -- reading the docs for 'BVar'. -- +-- In the original version 0.1, this module required 'Num' instances for +-- methods instead of 'Backprop' instances. This interface is still +-- available in "Numeric.Backprop.Num", which has the same API as this +-- module, except with 'Num' constraints on all values instead of +-- 'Backprop' constraints. +-- +-- See "Prelude.Backprop.Explicit" for a version allowing you to provide +-- 'zero', 'add', and 'one' explicitly, which can be useful when attempting +-- to avoid orphan instances or when mixing both 'Backprop' and 'Num' +-- styles. +-- module Numeric.Backprop ( -- * Types - BVar, W + BVar, W, Backprop(..) -- * Running - , backprop, evalBP, gradBP + , backprop, E.evalBP, gradBP, backpropWith -- ** Multiple inputs - , backprop2, evalBP2, gradBP2 - , backpropN, evalBPN, gradBPN, Every + , backprop2, E.evalBP2, gradBP2, backpropWith2 + , backpropN, E.evalBPN, gradBPN, backpropWithN, Every -- * Manipulating 'BVar' - , constVar, coerceVar + , E.constVar, E.auto, E.coerceVar , (^^.), (.~~), (^^?), (^^..) , viewVar, setVar , sequenceVar, collectVar @@ -87,12 +99,15 @@ , Reifies ) where -import Data.Bifunctor import Data.Reflection import Data.Type.Index +import Data.Type.Length import Lens.Micro -import Numeric.Backprop.Internal +import Numeric.Backprop.Class +import Numeric.Backprop.Explicit (BVar, W) import Numeric.Backprop.Op +import Type.Class.Known +import qualified Numeric.Backprop.Explicit as E -- $liftops -- @@ -138,6 +153,51 @@ -- -> b@, using 'evalBP', and this carries virtually zero overhead, so some -- libraries might even provide 'BVar' versions by default. +-- | 'backprop' generalized to multiple inputs of different types. See the +-- "Numeric.Backprop.Op#prod" for a mini-tutorial on heterogeneous lists. +-- +-- Not strictly necessary, because you can always uncurry a function by +-- passing in all of the inputs in a data type containing all of the +-- arguments or a giant tuple. However, this could potentially also be +-- more performant. +-- +-- A @'Prod' ('BVar' s) '[Double, Float, Double]@, for instance, is a tuple +-- of @'BVar' s 'Double'@, @'BVar' s 'Float'@, and @'BVar' s 'Double'@, and +-- can be pattern matched on using ':<' (cons) and 'Ø' (nil). +-- +-- Tuples can be built and pattern matched on using '::<' (cons) and 'Ø' +-- (nil), as well. +-- +-- The @'Every' 'Backprop' as@ in the constraint says that every value in +-- the type-level list @as@ must have a 'Backprop' instance. This means +-- you can use, say, @'[Double, Float, Int]@, but not @'[Double, Bool, +-- String]@. +-- +-- If you stick to /concerete/, monomorphic usage of this (with specific +-- types, typed into source code, known at compile-time), then @'Every' +-- 'Backprop' as@ should be fulfilled automatically. +backpropN + :: (Every Backprop as, Known Length as, Backprop b) + => (forall s. Reifies s W => Prod (BVar s) as -> BVar s b) + -> Tuple as + -> (b, Tuple as) +backpropN = E.backpropN E.zeroFuncs E.oneFunc +{-# INLINE backpropN #-} + +-- | 'backpropN', but allows you to provide the gradient of the "final +-- result" with respect to the output of your function. See 'backpropWith' +-- for more details. +-- +-- @since 0.2.0.0 +backpropWithN + :: (Every Backprop as, Known Length as) + => (forall s. Reifies s W => Prod (BVar s) as -> BVar s b) + -> Tuple as + -> (b -> b) -- ^ Gradient of final result with respect to output of function + -> (b, Tuple as) +backpropWithN = E.backpropWithN E.zeroFuncs +{-# INLINE backpropWithN #-} + -- | Turn a function @'BVar' s a -> 'BVar' s b@ into the function @a -> b@ -- that it represents, also computing its gradient @a@ as well. -- @@ -145,55 +205,37 @@ -- that 'BVar's do not leak out of the context (similar to how it is used -- in "Control.Monad.ST"), and also as a reference to an ephemeral Wengert -- tape used to track the graph of references. --- --- Note that every type involved has to be an instance of 'Num'. This is --- because gradients all need to be "summable" (which is implemented using --- 'sum' and '+'), and we also need to able to generate gradients of 1 --- and 0. Really, only '+' and 'fromInteger' methods are used from the --- 'Num' typeclass. --- --- This might change in the future, to allow easier integration with tuples --- (which typically do not have a 'Num' instance), and potentially make --- types easier to use (by only requiring '+', 0, and 1, and not the rest --- of the 'Num' class). --- --- See the for a more detailed --- discussion on this issue. --- --- If you need a 'Num' instance for tuples, you can use the canonical 2- --- and 3-tuples for the library in "Numeric.Backprop.Tuple". If you need --- one for larger tuples, consider making a custom product type instead --- (making Num instances with something like --- ). --- You can also use the orphan instances in the --- package --- (in particular, "Data.NumInstances.Tuple") if you are writing an --- application and do not have to worry about orphan instances. backprop - :: forall a b. (Num a, Num b) + :: (Backprop a, Backprop b) => (forall s. Reifies s W => BVar s a -> BVar s b) -> a -> (b, a) -backprop f = second (getI . head') - . backpropN (f . head') - . only_ +backprop = E.backprop E.zeroFunc E.oneFunc {-# INLINE backprop #-} --- | Turn a function @'BVar' s a -> 'BVar' s b@ into the function @a -> b@ --- that it represents. +-- | A version of 'backprop' that allows you to specify the gradent of your +-- "final result" in with respect to the output of your function. -- --- Benchmarks show that this should have virtually no overhead over --- directly writing a @a -> b@. 'BVar' is, in this situation, a zero-cost --- abstraction, performance-wise. +-- Typically, this is just the scalar 1, or a value of components that are +-- all 1. -- --- Has a nice advantage over using 'backprop' in that it doesn't require --- 'Num' constraints on the input and output. +-- Instead of taking the @b@ gradient, the you may provide a @b -> b@, +-- which 'backpropWith' calls with the result of your function as the +-- argument. This allows you to return something with the correct "shape", +-- if not a scalar. -- --- See documentation of 'backprop' for more information. +-- 'backprop' is essentially 'backpropWith' with @'const' 1@ for scalars +-- and 'Num' instances. -- -evalBP :: (forall s. Reifies s W => BVar s a -> BVar s b) -> a -> b -evalBP f = evalBPN (f . head') . only_ -{-# INLINE evalBP #-} +-- @since 0.2.0.0 +backpropWith + :: Backprop a + => (forall s. Reifies s W => BVar s a -> BVar s b) + -> a + -> (b -> b) -- ^ Gradient of final result with respect to output of function + -> (b, a) +backpropWith = E.backpropWith E.zeroFunc +{-# INLINE backpropWith #-} -- | Take a function @'BVar' s a -> 'BVar' s b@, interpreted as a function -- @a -> b@, and compute its gradient with respect to its input. @@ -207,58 +249,65 @@ -- -- See documentation of 'backprop' for more information. -- +-- If you want to provide an explicit "final gradient" for the end, see +-- 'backpropWith'. gradBP - :: forall a b. (Num a, Num b) + :: (Backprop a, Backprop b) => (forall s. Reifies s W => BVar s a -> BVar s b) -> a -> a -gradBP f = snd . backprop f +gradBP = E.gradBP E.zeroFunc E.oneFunc {-# INLINE gradBP #-} -- | 'gradBP' generalized to multiple inputs of different types. See -- documentation for 'backpropN' for more details. gradBPN - :: forall as b. (Every Num as, Num b) + :: (Every Backprop as, Known Length as, Backprop b) => (forall s. Reifies s W => Prod (BVar s) as -> BVar s b) -> Tuple as -> Tuple as -gradBPN f = snd . backpropN f +gradBPN = E.gradBPN E.zeroFuncs E.oneFunc {-# INLINE gradBPN #-} -- | 'backprop' for a two-argument function. -- -- Not strictly necessary, because you can always uncurry a function by --- passing in all of the argument inside a data type, or use 'T2'. However, --- this could potentially be more performant. +-- passing in all of the argument inside a data type, or just use a tuple. +-- However, this could potentially be more performant. -- -- For 3 and more arguments, consider using 'backpropN'. backprop2 - :: forall a b c. (Num a, Num b, Num c) + :: (Backprop a, Backprop b, Backprop c) => (forall s. Reifies s W => BVar s a -> BVar s b -> BVar s c) -> a -> b -> (c, (a, b)) -backprop2 f x y = second (\(dx ::< dy ::< Ø) -> (dx, dy)) - $ backpropN (\(x' :< y' :< Ø) -> f x' y') (x ::< y ::< Ø) +backprop2 = E.backprop2 E.zeroFunc E.zeroFunc E.oneFunc {-# INLINE backprop2 #-} --- | 'evalBP' for a two-argument function. See 'backprop2' for notes. -evalBP2 - :: (forall s. Reifies s W => BVar s a -> BVar s b -> BVar s c) +-- | 'backprop2', but allows you to provide the gradient of the "final +-- result" with respect to the output of your function. See 'backpropWith' +-- for more details. +-- +-- @since 0.2.0.0 +backpropWith2 + :: (Backprop a, Backprop b) + => (forall s. Reifies s W => BVar s a -> BVar s b -> BVar s c) -> a -> b - -> c -evalBP2 f x y = evalBPN (\(x' :< y' :< Ø) -> f x' y') (x ::< y ::< Ø) -{-# INLINE evalBP2 #-} + -> (c -> c) -- ^ Gradient of final result with respect to output of function + -> (c, (a, b)) +backpropWith2 = E.backpropWith2 E.zeroFunc E.zeroFunc +{-# INLINE backpropWith2 #-} -- | 'gradBP' for a two-argument function. See 'backprop2' for notes. gradBP2 - :: (Num a, Num b, Num c) + :: (Backprop a, Backprop b, Backprop c) => (forall s. Reifies s W => BVar s a -> BVar s b -> BVar s c) -> a -> b -> (a, b) -gradBP2 f x = snd . backprop2 f x +gradBP2 = E.gradBP2 E.zeroFunc E.zeroFunc E.oneFunc {-# INLINE gradBP2 #-} -- | An infix version of 'viewVar', meant to evoke parallels to '^.' from @@ -288,7 +337,7 @@ -- the contents (like 'multiplying'). -- (^^.) - :: forall a b s. (Reifies s W, Num a) + :: forall a b s. (Reifies s W, Backprop a) => BVar s b -> Lens' b a -> BVar s a @@ -296,6 +345,19 @@ infixl 8 ^^. {-# INLINE (^^.) #-} +-- | Using a 'Lens'', extract a value /inside/ a 'BVar'. Meant to evoke +-- parallels to 'view' from lens. +-- +-- See documentation for '^^.' for more information. +viewVar + :: forall a b s. (Reifies s W, Backprop a) + => Lens' b a + -> BVar s b + -> BVar s a +viewVar = E.viewVar E.addFunc E.zeroFunc +{-# INLINE viewVar #-} + + -- | An infix version of 'setVar', meant to evoke parallels to '.~' from -- lens. -- @@ -320,7 +382,7 @@ -- This is the main way to set values inside 'BVar's of container types. -- (.~~) - :: forall a b s. (Reifies s W, Num a, Num b) + :: forall a b s. (Reifies s W, Backprop a, Backprop b) => Lens' b a -> BVar s a -> BVar s b @@ -329,6 +391,20 @@ infixl 8 .~~ {-# INLINE (.~~) #-} +-- | Using a 'Lens'', set a value /inside/ a 'BVar'. Meant to evoke +-- parallels to "set" from lens. +-- +-- See documentation for '.~~' for more information. +setVar + :: forall a b s. (Reifies s W, Backprop a, Backprop b) + => Lens' b a + -> BVar s a + -> BVar s b + -> BVar s b +setVar = E.setVar E.addFunc E.addFunc E.zeroFunc E.zeroFunc +{-# INLINE setVar #-} + + -- | An infix version of 'previewVar', meant to evoke parallels to '^?' -- from lens. -- @@ -358,30 +434,28 @@ -- -- This can be used to "pattern match" on 'BVar's, by using prisms on -- constructors. --- --- Note that many automatically-generated prisms by the /lens/ package use --- tuples, which cannot normally be backpropagated (because they do not --- have a 'Num' instance). --- --- If you are writing an application or don't have to worry about orphan --- instances, you can pull in the orphan instances from --- . --- Alternatively, you can chain those prisms with conversions to the --- anonymous canonical strict tuple types in "Numeric.Backprop.Tuple", --- which do have 'Num' instances. --- --- @ --- myPrism :: 'Prism'' c (a, b) --- myPrism . 'iso' 'tupT2' 't2Tup' :: 'Prism'' c ('T2' a b) --- @ (^^?) - :: forall b a s. (Num a, Reifies s W) + :: forall b a s. (Backprop a, Reifies s W) => BVar s b -> Traversal' b a -> Maybe (BVar s a) v ^^? t = previewVar t v {-# INLINE (^^?) #-} +-- | Using a 'Traversal'', extract a single value /inside/ a 'BVar', if it +-- exists. If more than one traversal target exists, returns te first. +-- Meant to evoke parallels to 'preview' from lens. Really only intended +-- to be used wth 'Prism''s, or up-to-one target traversals. +-- +-- See documentation for '^^?' for more information. +previewVar + :: forall b a s. (Reifies s W, Backprop a) + => Traversal' b a + -> BVar s b + -> Maybe (BVar s a) +previewVar = E.previewVar E.addFunc E.zeroFunc +{-# INLINE previewVar #-} + -- | An infix version of 'toListOfVar', meant to evoke parallels to '^..' -- from lens. -- @@ -404,13 +478,120 @@ -- has type @['BVar' s a]@ (A list of 'BVar's holding @a@s). -- (^^..) - :: forall b a s. (Num a, Reifies s W) + :: forall b a s. (Backprop a, Reifies s W) => BVar s b -> Traversal' b a -> [BVar s a] v ^^.. t = toListOfVar t v {-# INLINE (^^..) #-} +-- | Using a 'Traversal'', extract all targeted values /inside/ a 'BVar'. +-- Meant to evoke parallels to 'toListOf' from lens. +-- +-- See documentation for '^^..' for more information. +toListOfVar + :: forall b a s. (Backprop a, Reifies s W) + => Traversal' b a + -> BVar s b + -> [BVar s a] +toListOfVar = E.toListOfVar E.addFunc E.zeroFunc +{-# INLINE toListOfVar #-} + +-- | Extract all of the 'BVar's out of a 'Traversable' container of +-- 'BVar's. +-- +-- Note that this associates gradients in order of occurrence in the +-- original data structure; the second item in the gradient is assumed to +-- correspond with the second item in the input, etc.; this can cause +-- unexpected behavior in 'Foldable' instances that don't have a fixed +-- number of items. +sequenceVar + :: forall t a s. (Backprop a, Reifies s W, Traversable t) + => BVar s (t a) + -> t (BVar s a) +sequenceVar = E.sequenceVar E.addFunc E.zeroFunc +{-# INLINE sequenceVar #-} + +-- | Collect all of the 'BVar's in a container into a 'BVar' of that +-- container's contents. +-- +-- Note that this associates gradients in order of occurrence in the +-- original data structure; the second item in the total derivative and +-- gradient is assumed to correspond with the second item in the input, +-- etc.; this can cause unexpected behavior in 'Foldable' instances that +-- don't have a fixed number of items. +collectVar + :: forall t a s. (Backprop a, Backprop (t a), Reifies s W, Foldable t, Functor t) + => t (BVar s a) + -> BVar s (t a) +collectVar = E.collectVar E.addFunc E.zeroFunc E.zeroFunc +{-# INLINE collectVar #-} + +-- | Lift an 'Op' with an arbitrary number of inputs to a function on the +-- appropriate number of 'BVar's. +-- +-- Should preferably be used only by libraries to provide primitive 'BVar' +-- functions for their types for users. +-- +-- See "Numeric.Backprop#liftops" and documentation for 'liftOp' for more +-- information, and "Numeric.Backprop.Op#prod" for a mini-tutorial on using +-- 'Prod' and 'Tuple'. +liftOp + :: forall as b s. (Every Backprop as, Known Length as, Backprop b, Reifies s W) + => Op as b + -> Prod (BVar s) as + -> BVar s b +liftOp = E.liftOp E.addFuncs E.zeroFunc +{-# INLINE liftOp #-} + +-- | Lift an 'Op' with a single input to be a function on a single 'BVar'. +-- +-- Should preferably be used only by libraries to provide primitive 'BVar' +-- functions for their types for users. +-- +-- See "Numeric.Backprop#liftops" and documentation for 'liftOp' for more +-- information. +liftOp1 + :: forall a b s. (Backprop a, Backprop b, Reifies s W) + => Op '[a] b + -> BVar s a + -> BVar s b +liftOp1 = E.liftOp1 E.addFunc E.zeroFunc +{-# INLINE liftOp1 #-} + +-- | Lift an 'Op' with two inputs to be a function on a two 'BVar's. +-- +-- Should preferably be used only by libraries to provide primitive 'BVar' +-- functions for their types for users. +-- +-- See "Numeric.Backprop#liftops" and documentation for 'liftOp' for more +-- information. +liftOp2 + :: forall a b c s. (Backprop a, Backprop b, Backprop c, Reifies s W) + => Op '[a,b] c + -> BVar s a + -> BVar s b + -> BVar s c +liftOp2 = E.liftOp2 E.addFunc E.addFunc E.zeroFunc +{-# INLINE liftOp2 #-} + +-- | Lift an 'Op' with three inputs to be a function on a three 'BVar's. +-- +-- Should preferably be used only by libraries to provide primitive 'BVar' +-- functions for their types for users. +-- +-- See "Numeric.Backprop#liftops" and documentation for 'liftOp' for more +-- information. +liftOp3 + :: forall a b c d s. (Backprop a, Backprop b, Backprop c, Backprop d, Reifies s W) + => Op '[a,b,c] d + -> BVar s a + -> BVar s b + -> BVar s c + -> BVar s d +liftOp3 = E.liftOp3 E.addFunc E.addFunc E.addFunc E.zeroFunc +{-# INLINE liftOp3 #-} + -- | Convert the value inside a 'BVar' using a given isomorphism. Useful -- for things like constructors. -- @@ -420,7 +601,7 @@ -- -- @since 0.1.4.0 isoVar - :: (Num a, Num b, Reifies s W) + :: (Backprop a, Backprop b, Reifies s W) => (a -> b) -> (b -> a) -> BVar s a @@ -433,7 +614,7 @@ -- -- @since 0.1.4.0 isoVar2 - :: (Num a, Num b, Num c, Reifies s W) + :: (Backprop a, Backprop b, Backprop c, Reifies s W) => (a -> b -> c) -> (c -> (a, b)) -> BVar s a @@ -447,7 +628,7 @@ -- -- @since 0.1.4.0 isoVar3 - :: (Num a, Num b, Num c, Num d, Reifies s W) + :: (Backprop a, Backprop b, Backprop c, Backprop d, Reifies s W) => (a -> b -> c -> d) -> (d -> (a, b, c)) -> BVar s a @@ -463,7 +644,7 @@ -- -- @since 0.1.4.0 isoVarN - :: (Every Num as, Num b, Reifies s W) + :: (Every Backprop as, Known Length as, Backprop b, Reifies s W) => (Tuple as -> b) -> (b -> Tuple as) -> Prod (BVar s) as diff --git a/src/Numeric/Backprop/Class.hs b/src/Numeric/Backprop/Class.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Backprop/Class.hs @@ -0,0 +1,649 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Numeric.Backprop.Class +-- Copyright : (c) Justin Le 2018 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Provides the 'Backprop' typeclass, a class for values that can be used +-- for backpropagation. +-- +-- This class replaces the old (version 0.1) API relying on 'Num'. +-- +-- @since 0.2.0.0 + +module Numeric.Backprop.Class ( + -- * Backpropagatable types + Backprop(..) + -- * Derived methods + , zeroNum, addNum, oneNum + , zeroVec, addVec, oneVec + , zeroFunctor, addIsList, addAsList, oneFunctor + , genericZero, genericAdd, genericOne + -- * Generics + , GZero(..), GAdd(..), GOne(..) + ) where + +import Data.Complex +import Data.Foldable hiding (toList) +import Data.Functor.Identity +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Proxy +import Data.Ratio +import Data.Type.Combinator hiding ((:.:), Comp1) +import Data.Type.Option +import Data.Type.Product hiding (toList) +import Data.Void +import GHC.Exts +import GHC.Generics +import Type.Family.List +import qualified Data.IntMap as IM +import qualified Data.Map as M +import qualified Data.Sequence as Seq +import qualified Data.Vector as V +import qualified Data.Vector.Generic as VG +import qualified Data.Vector.Primitive as VP +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Unboxed as VU +import qualified Type.Family.Maybe as M + +-- | Class of values that can be backpropagated in general. +-- +-- For instances of 'Num', these methods can be given by 'zeroNum', +-- 'addNum', and 'oneNum'. There are also generic options given in +-- "Numeric.Backprop.Class" for functors, 'IsList' instances, and 'Generic' +-- instances. +-- +-- @ +-- instance 'Backprop' 'Double' where +-- 'zero' = 'zeroNum' +-- 'add' = 'addNum' +-- 'one' = 'oneNum' +-- @ +-- +-- If you leave the body of an instance declaration blank, GHC Generics +-- will be used to derive instances if the type has a single constructor +-- and each field is an instance of 'Backprop'. +-- +-- To ensure that backpropagation works in a sound way, should obey the +-- laws: +-- +-- [/identity/] +-- +-- * @'add' x ('zero' y) = x@ +-- +-- * @'add' ('zero' x) y = y@ +-- +-- Also implies preservation of information, making @'zipWith' ('+')@ an +-- illegal implementation for lists and vectors. +-- +-- This is only expected to be true up to potential "extra zeroes" in @x@ +-- and @y@ in the result. +-- +-- [/commutativity/] +-- +-- * @'add' x y = 'add' y x@ +-- +-- [/associativity/] +-- +-- * @'add' x ('add' y z) = 'add' ('add' x y) z@ +-- +-- [/idempotence/] +-- +-- * @'zero' '.' 'zero' = 'zero'@ +-- +-- * @'one' '.' 'one' = 'one'@ +-- +-- Note that not all values in the backpropagation process needs all of +-- these methods: Only the "final result" needs 'one', for example. These +-- are all grouped under one typeclass for convenience in defining +-- instances, and also to talk about sensible laws. For fine-grained +-- control, use the "explicit" versions of library functions (for example, +-- in "Numeric.Backprop.Explicit") instead of 'Backprop' based ones. +-- +-- This typeclass replaces the reliance on 'Num' of the previous API +-- (v0.1). 'Num' is strictly more powerful than 'Backprop', and is +-- a stronger constraint on types than is necessary for proper +-- backpropagating. In particular, 'fromInteger' is a problem for many +-- types, preventing useful backpropagation for lists, variable-length +-- vectors (like "Data.Vector") and variable-size matrices from linear +-- algebra libraries like /hmatrix/ and /accelerate/. +-- +-- @since 0.2.0.0 +class Backprop a where + -- | "Zero out" all components of a value. For scalar values, this + -- should just be @'const' 0@. For vectors and matrices, this should + -- set all components to zero, the additive identity. + -- + -- Should be idempotent: + -- + -- * @'zero' '.' 'zero' = 'zero'@ + -- + -- Should be as /lazy/ as possible. This behavior is observed for + -- all instances provided by this library. + -- + -- See 'zeroNum' for a pre-built definition for instances of 'Num' and + -- 'zeroFunctor' for a definition for instances of 'Functor'. If left + -- blank, will automatically be 'genericZero', a pre-built definition + -- for instances of 'GHC.Generic' whose fields are all themselves + -- instances of 'Backprop'. + zero :: a -> a + -- | Add together two values of a type. To combine contributions of + -- gradients, so should be information-preserving: + -- + -- * @'add' x ('zero' y) = x@ + -- + -- * @'add' ('zero' x) y = y@ + -- + -- Should be as /strict/ as possible. This behavior is observed for + -- all instances provided by this library. + -- + -- See 'addNum' for a pre-built definition for instances of 'Num' and + -- 'addFunctor' for a definition for instances of 'Functor'. If left + -- blank, will automatically be 'genericAdd', a pre-built definition + -- for instances of 'GHC.Generic' with one constructor whose fields are + -- all themselves instances of 'Backprop'. + add :: a -> a -> a + -- | "One" all components of a value. For scalar values, this should + -- just be @'const' 1@. For vectors and matrices, this should set all + -- components to one, the multiplicative identity. + -- + -- Should be idempotent: + -- + -- * @'one' '.' 'one' = 'one'@ + -- + -- Should be as /lazy/ as possible. This behavior is observed for + -- all instances provided by this library. + -- + -- See 'oneNum' for a pre-built definition for instances of 'Num' and + -- 'oneFunctor' for a definition for instances of 'Functor'. If left + -- blank, will automatically be 'genericOne', a pre-built definition + -- for instances of 'GHC.Generic' whose fields are all themselves + -- instances of 'Backprop'. + one :: a -> a + + default zero :: (Generic a, GZero (Rep a)) => a -> a + zero = genericZero + {-# INLINE zero #-} + default add :: (Generic a, GAdd (Rep a)) => a -> a -> a + add = genericAdd + {-# INLINE add #-} + default one :: (Generic a, GOne (Rep a)) => a -> a + one = genericOne + {-# INLINE one #-} + +-- | 'zero' using GHC Generics; works if all fields are instances of +-- 'Backprop'. +genericZero :: (Generic a, GZero (Rep a)) => a -> a +genericZero = to . gzero . from +{-# INLINE genericZero #-} + +-- | 'add' using GHC Generics; works if all fields are instances of +-- 'Backprop', but only for values with single constructors. +genericAdd :: (Generic a, GAdd (Rep a)) => a -> a -> a +genericAdd x y = to $ gadd (from x) (from y) +{-# INLINE genericAdd #-} + +-- | 'one' using GHC Generics; works if all fields are instaces of +-- 'Backprop'. +genericOne :: (Generic a, GOne (Rep a)) => a -> a +genericOne = to . gone . from +{-# INLINE genericOne #-} + +-- | 'zero' for instances of 'Num'. +-- +-- Is lazy in its argument. +zeroNum :: Num a => a -> a +zeroNum _ = 0 +{-# INLINE zeroNum #-} + +-- | 'add' for instances of 'Num'. +addNum :: Num a => a -> a -> a +addNum = (+) +{-# INLINE addNum #-} + +-- | 'one' for instances of 'Num'. +-- +-- Is lazy in its argument. +oneNum :: Num a => a -> a +oneNum _ = 1 +{-# INLINE oneNum #-} + +-- | 'zero' for instances of 'VG.Vector'. +zeroVec :: (VG.Vector v a, Backprop a) => v a -> v a +zeroVec = VG.map zero +{-# INLINE zeroVec #-} + +-- | 'add' for instances of 'VG.Vector'. Automatically pads the end of the +-- shorter vector with zeroes. +addVec :: (VG.Vector v a, Backprop a) => v a -> v a -> v a +addVec x y = case compare lX lY of + LT -> let (y1,y2) = VG.splitAt (lY - lX) y + in VG.zipWith add x y1 VG.++ y2 + EQ -> VG.zipWith add x y + GT -> let (x1,x2) = VG.splitAt (lX - lY) x + in VG.zipWith add x1 y VG.++ x2 + where + lX = VG.length x + lY = VG.length y + +-- | 'one' for instances of 'VG.Vector'. +oneVec :: (VG.Vector v a, Backprop a) => v a -> v a +oneVec = VG.map one +{-# INLINE oneVec #-} + +-- | 'zero' for 'Functor' instances. +zeroFunctor :: (Functor f, Backprop a) => f a -> f a +zeroFunctor = fmap zero +{-# INLINE zeroFunctor #-} + +-- | 'add' for instances of 'IsList'. Automatically pads the end of the +-- "shorter" value with zeroes. +addIsList :: (IsList a, Backprop (Item a)) => a -> a -> a +addIsList = addAsList toList fromList +{-# INLINE addIsList #-} + +-- | 'add' for types that are isomorphic to a list. +-- Automatically pads the end of the "shorter" value with zeroes. +addAsList + :: Backprop b + => (a -> [b]) -- ^ convert to list (should form isomorphism) + -> ([b] -> a) -- ^ convert from list (should form isomorphism) + -> a + -> a + -> a +addAsList f g x y = g $ go (f x) (f y) + where + go = \case + [] -> id + o@(x':xs) -> \case + [] -> o + y':ys -> add x' y' : go xs ys + +-- | 'one' for instances of 'Functor'. +oneFunctor :: (Functor f, Backprop a) => f a -> f a +oneFunctor = fmap one +{-# INLINE oneFunctor #-} + + + + + +-- | Helper class for automatically deriving 'zero' using GHC Generics. +class GZero f where + gzero :: f t -> f t + +instance Backprop a => GZero (K1 i a) where + gzero (K1 x) = K1 (zero x) + {-# INLINE gzero #-} + +instance (GZero f, GZero g) => GZero (f :*: g) where + gzero (x :*: y) = gzero x :*: gzero y + {-# INLINE gzero #-} + +instance (GZero f, GZero g) => GZero (f :+: g) where + gzero (L1 x) = L1 (gzero x) + gzero (R1 x) = R1 (gzero x) + {-# INLINE gzero #-} + +instance GZero V1 where + gzero = \case {} + {-# INLINE gzero #-} + +instance GZero U1 where + gzero _ = U1 + {-# INLINE gzero #-} + +instance GZero f => GZero (M1 i c f) where + gzero (M1 x) = M1 (gzero x) + {-# INLINE gzero #-} + +instance GZero f => GZero (f :.: g) where + gzero (Comp1 x) = Comp1 (gzero x) + {-# INLINE gzero #-} + + +-- | Helper class for automatically deriving 'add' using GHC Generics. +class GAdd f where + gadd :: f t -> f t -> f t + +instance Backprop a => GAdd (K1 i a) where + gadd (K1 x) (K1 y) = K1 (add x y) + {-# INLINE gadd #-} + +instance (GAdd f, GAdd g) => GAdd (f :*: g) where + gadd (x1 :*: y1) (x2 :*: y2) = x3 :*: y3 + where + !x3 = gadd x1 x2 + !y3 = gadd y1 y2 + {-# INLINE gadd #-} + +instance GAdd V1 where + gadd = \case {} + {-# INLINE gadd #-} + +instance GAdd U1 where + gadd _ _ = U1 + {-# INLINE gadd #-} + +instance GAdd f => GAdd (M1 i c f) where + gadd (M1 x) (M1 y) = M1 (gadd x y) + {-# INLINE gadd #-} + +instance GAdd f => GAdd (f :.: g) where + gadd (Comp1 x) (Comp1 y) = Comp1 (gadd x y) + {-# INLINE gadd #-} + + +-- | Helper class for automatically deriving 'one' using GHC Generics. +class GOne f where + gone :: f t -> f t + +instance Backprop a => GOne (K1 i a) where + gone (K1 x) = K1 (one x) + {-# INLINE gone #-} + +instance (GOne f, GOne g) => GOne (f :*: g) where + gone (x :*: y) = gone x :*: gone y + {-# INLINE gone #-} + +instance (GOne f, GOne g) => GOne (f :+: g) where + gone (L1 x) = L1 (gone x) + gone (R1 x) = R1 (gone x) + {-# INLINE gone #-} + +instance GOne V1 where + gone = \case {} + {-# INLINE gone #-} + +instance GOne U1 where + gone _ = U1 + {-# INLINE gone #-} + +instance GOne f => GOne (M1 i c f) where + gone (M1 x) = M1 (gone x) + {-# INLINE gone #-} + +instance GOne f => GOne (f :.: g) where + gone (Comp1 x) = Comp1 (gone x) + {-# INLINE gone #-} + +instance Backprop Int where + zero = zeroNum + {-# INLINE zero #-} + add = addNum + {-# INLINE add #-} + one = oneNum + {-# INLINE one #-} + +instance Backprop Integer where + zero = zeroNum + {-# INLINE zero #-} + add = addNum + {-# INLINE add #-} + one = oneNum + {-# INLINE one #-} + +instance Integral a => Backprop (Ratio a) where + zero = zeroNum + {-# INLINE zero #-} + add = addNum + {-# INLINE add #-} + one = oneNum + {-# INLINE one #-} + +instance RealFloat a => Backprop (Complex a) where + zero = zeroNum + {-# INLINE zero #-} + add = addNum + {-# INLINE add #-} + one = oneNum + {-# INLINE one #-} + +instance Backprop Float where + zero = zeroNum + {-# INLINE zero #-} + add = addNum + {-# INLINE add #-} + one = oneNum + {-# INLINE one #-} + +instance Backprop Double where + zero = zeroNum + {-# INLINE zero #-} + add = addNum + {-# INLINE add #-} + one = oneNum + {-# INLINE one #-} + +instance Backprop a => Backprop (V.Vector a) where + zero = zeroVec + {-# INLINE zero #-} + add = addVec + {-# INLINE add #-} + one = oneVec + {-# INLINE one #-} + +instance (VU.Unbox a, Backprop a) => Backprop (VU.Vector a) where + zero = zeroVec + {-# INLINE zero #-} + add = addVec + {-# INLINE add #-} + one = oneVec + {-# INLINE one #-} + +instance (VS.Storable a, Backprop a) => Backprop (VS.Vector a) where + zero = zeroVec + {-# INLINE zero #-} + add = addVec + {-# INLINE add #-} + one = oneVec + {-# INLINE one #-} + +instance (VP.Prim a, Backprop a) => Backprop (VP.Vector a) where + zero = zeroVec + {-# INLINE zero #-} + add = addVec + {-# INLINE add #-} + one = oneVec + {-# INLINE one #-} + +-- | 'add' assumes the shorter list has trailing zeroes, and the result has +-- the length of the longest input. +instance Backprop a => Backprop [a] where + zero = zeroFunctor + {-# INLINE zero #-} + add = addIsList + {-# INLINE add #-} + one = oneFunctor + {-# INLINE one #-} + +-- | 'add' assumes the shorter list has trailing zeroes, and the result has +-- the length of the longest input. +instance Backprop a => Backprop (NonEmpty a) where + zero = zeroFunctor + {-# INLINE zero #-} + add = addIsList + {-# INLINE add #-} + one = oneFunctor + {-# INLINE one #-} + +-- | 'add' assumes the shorter sequence has trailing zeroes, and the result +-- has the length of the longest input. +instance Backprop a => Backprop (Seq.Seq a) where + zero = zeroFunctor + {-# INLINE zero #-} + add = addIsList + {-# INLINE add #-} + one = oneFunctor + {-# INLINE one #-} + +-- | 'Nothing' is treated the same as @'Just' 0@. However, 'zero', 'add', +-- and 'one' preserve 'Nothing' if all inputs are also 'Nothing'. +instance Backprop a => Backprop (Maybe a) where + zero = zeroFunctor + {-# INLINE zero #-} + add x y = asum [ add <$> x <*> y + , x + , y + ] + {-# INLINE add #-} + one = oneFunctor + {-# INLINE one #-} + +-- | 'add' is strict, but 'zero' and 'one' are lazy in their arguments. +instance Backprop () where + zero _ = () + add () () = () + one _ = () + +-- | 'add' is strict +instance (Backprop a, Backprop b) => Backprop (a, b) where + zero (x, y) = (zero x, zero y) + {-# INLINE zero #-} + add (x1, y1) (x2, y2) = (x3, y3) + where + !x3 = add x1 x2 + !y3 = add y1 y2 + {-# INLINE add #-} + one (x, y) = (one x, one y) + {-# INLINE one #-} + +-- | 'add' is strict +instance (Backprop a, Backprop b, Backprop c) => Backprop (a, b, c) where + zero (x, y, z) = (zero x, zero y, zero z) + {-# INLINE zero #-} + add (x1, y1, z1) (x2, y2, z2) = (x3, y3, z3) + where + !x3 = add x1 x2 + !y3 = add y1 y2 + !z3 = add z1 z2 + {-# INLINE add #-} + one (x, y, z) = (one x, one y, one z) + {-# INLINE one #-} + +-- | 'add' is strict +instance (Backprop a, Backprop b, Backprop c, Backprop d) => Backprop (a, b, c, d) where + zero (x, y, z, w) = (zero x, zero y, zero z, zero w) + {-# INLINE zero #-} + add (x1, y1, z1, w1) (x2, y2, z2, w2) = (x3, y3, z3, w3) + where + !x3 = add x1 x2 + !y3 = add y1 y2 + !z3 = add z1 z2 + !w3 = add w1 w2 + {-# INLINE add #-} + one (x, y, z, w) = (one x, one y, one z, one w) + {-# INLINE one #-} + +-- | 'add' is strict +instance (Backprop a, Backprop b, Backprop c, Backprop d, Backprop e) => Backprop (a, b, c, d, e) where + zero (x, y, z, w, v) = (zero x, zero y, zero z, zero w, zero v) + {-# INLINE zero #-} + add (x1, y1, z1, w1, v1) (x2, y2, z2, w2, v2) = (x3, y3, z3, w3, v3) + where + !x3 = add x1 x2 + !y3 = add y1 y2 + !z3 = add z1 z2 + !w3 = add w1 w2 + !v3 = add v1 v2 + {-# INLINE add #-} + one (x, y, z, w, v) = (one x, one y, one z, one w, one v) + {-# INLINE one #-} + +instance Backprop a => Backprop (Identity a) where + zero (Identity x) = Identity (zero x) + {-# INLINE zero #-} + add (Identity x) (Identity y) = Identity (add x y) + {-# INLINE add #-} + one (Identity x) = Identity (one x) + {-# INLINE one #-} + +instance Backprop a => Backprop (I a) where + zero (I x) = I (zero x) + {-# INLINE zero #-} + add (I x) (I y) = I (add x y) + {-# INLINE add #-} + one (I x) = I (one x) + {-# INLINE one #-} + +-- | 'add' is strict, but 'zero' and 'one' are lazy in their arguments. +instance Backprop (Proxy a) where + zero _ = Proxy + {-# INLINE zero #-} + add Proxy Proxy = Proxy + {-# INLINE add #-} + one _ = Proxy + {-# INLINE one #-} + +instance Backprop Void where + zero = \case {} + {-# INLINE zero #-} + add = \case {} + {-# INLINE add #-} + one = \case {} + {-# INLINE one #-} + +-- | 'zero' and 'one' replace all current values, and 'add' merges keys +-- from both maps, adding in the case of double-occurrences. +instance (Backprop a, Ord k) => Backprop (M.Map k a) where + zero = zeroFunctor + {-# INLINE zero #-} + add = M.unionWith add + {-# INLINE add #-} + one = oneFunctor + {-# INLINE one #-} + +-- | 'zero' and 'one' replace all current values, and 'add' merges keys +-- from both maps, adding in the case of double-occurrences. +instance (Backprop a) => Backprop (IM.IntMap a) where + zero = zeroFunctor + {-# INLINE zero #-} + add = IM.unionWith add + {-# INLINE add #-} + one = oneFunctor + {-# INLINE one #-} + +instance ListC (Backprop <$> (f <$> as)) => Backprop (Prod f as) where + zero = \case + Ø -> Ø + x :< xs -> zero x :< zero xs + {-# INLINE zero #-} + add = \case + Ø -> \case + Ø -> Ø + x :< xs -> \case + y :< ys -> add x y :< add xs ys + {-# INLINE add #-} + one = \case + Ø -> Ø + x :< xs -> one x :< one xs + {-# INLINE one #-} + +instance M.MaybeC (Backprop M.<$> (f M.<$> a)) => Backprop (Option f a) where + zero = \case + Nothing_ -> Nothing_ + Just_ x -> Just_ (zero x) + {-# INLINE zero #-} + add = \case + Nothing_ -> \case + Nothing_ -> Nothing_ + Just_ x -> \case + Just_ y -> Just_ (add x y) + {-# INLINE add #-} + one = \case + Nothing_ -> Nothing_ + Just_ x -> Just_ (one x) + {-# INLINE one #-} + diff --git a/src/Numeric/Backprop/Explicit.hs b/src/Numeric/Backprop/Explicit.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Backprop/Explicit.hs @@ -0,0 +1,321 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} + +-- | +-- Module : Numeric.Backprop.Explicit +-- Copyright : (c) Justin Le 2018 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Provides "explicit" versions of all of the functions in +-- "Numeric.Backprop". Instead of relying on a 'Backprop' instance, allows +-- you to manually provide 'zero', 'add', and 'one' on a per-value basis. +-- +-- It is recommended you use 'Numeric.Backprop' or 'Numeric.Backprop.Num' +-- instead, unless your type has no 'Num' instance, or you else you want to +-- avoid defining orphan 'Backprop' instances for external types. Can also +-- be useful if mixing and matching styles. +-- +-- See "Numeric.Backprop" for fuller documentation on using these +-- functions. +-- +-- @since 0.2.0.0 + +module Numeric.Backprop.Explicit ( + -- * Types + BVar, W, Backprop(..) + -- * Explicit 'zero', 'add', and 'one' + , ZeroFunc(..), zfNum, zfNums, zeroFunc, zeroFuncs + , AddFunc(..), afNum, afNums, addFunc, addFuncs + , OneFunc(..), ofNum, ofNums, oneFunc, oneFuncs + -- * Running + , backprop, evalBP, gradBP, backpropWith + -- ** Multiple inputs + , backprop2, evalBP2, gradBP2, backpropWith2 + , backpropN, evalBPN, gradBPN, backpropWithN, Every + -- * Manipulating 'BVar' + , constVar, auto, coerceVar + -- , (^^.), (.~~), (^^?), (^^..) + , viewVar, setVar + , sequenceVar, collectVar + , previewVar, toListOfVar + -- ** With Isomorphisms + , isoVar, isoVar2, isoVar3, isoVarN + -- ** With 'Op's + , liftOp + , liftOp1, liftOp2, liftOp3 + -- * 'Op' + , Op(..) + -- ** Creation + , op0, opConst, idOp + , opConst' + -- *** Giving gradients directly + , op1, op2, op3 + -- *** From Isomorphisms + , opCoerce, opTup, opIso, opIsoN, opLens + -- *** No gradients + , noGrad1, noGrad + -- * Utility + -- ** Inductive tuples/heterogeneous lists + , Prod(..), pattern (:>), only, head' + , Tuple, pattern (::<), only_ + , I(..) + -- ** Misc + , Reifies + ) where + +import Data.Bifunctor +import Data.Reflection +import Data.Type.Index +import Data.Type.Length +import Data.Type.Product +import Numeric.Backprop.Class +import Numeric.Backprop.Internal +import Numeric.Backprop.Op +import Type.Class.Higher +import Type.Class.Known +import Type.Class.Witness + +-- | 'ZeroFunc's for every item in a type level list based on their +-- 'Num' instances +-- +-- @since 0.2.0.0 +zfNums :: (Every Num as, Known Length as) => Prod ZeroFunc as +zfNums = map1 (\i -> zfNum \\ every @_ @Num i) indices + +-- | 'ZeroFunc's for every item in a type level list based on their +-- 'Num' instances +-- +-- @since 0.2.0.0 +afNums :: (Every Num as, Known Length as) => Prod AddFunc as +afNums = map1 (\i -> afNum \\ every @_ @Num i) indices + +-- | 'ZeroFunc's for every item in a type level list based on their +-- 'Num' instances +-- +-- @since 0.2.0.0 +ofNums :: (Every Num as, Known Length as) => Prod OneFunc as +ofNums = map1 (\i -> ofNum \\ every @_ @Num i) indices + +-- | The canonical 'ZeroFunc' for instances of 'Backprop'. +-- +-- @since 0.2.0.0 +zeroFunc :: Backprop a => ZeroFunc a +zeroFunc = ZF zero +{-# INLINE zeroFunc #-} + +-- | The canonical 'AddFunc' for instances of 'Backprop'. +-- +-- @since 0.2.0.0 +addFunc :: Backprop a => AddFunc a +addFunc = AF add +{-# INLINE addFunc #-} + +-- | The canonical 'OneFunc' for instances of 'Backprop'. +-- +-- @since 0.2.0.0 +oneFunc :: Backprop a => OneFunc a +oneFunc = OF one +{-# INLINE oneFunc #-} + +-- | Generate an 'ZeroFunc' for every type in a type-level list, if every +-- type has an instance of 'Backprop'. +-- +-- @since 0.2.0.0 +zeroFuncs :: (Every Backprop as, Known Length as) => Prod ZeroFunc as +zeroFuncs = map1 (\i -> zeroFunc \\ every @_ @Backprop i) indices + +-- | Generate an 'AddFunc' for every type in a type-level list, if every +-- type has an instance of 'Backprop'. +-- +-- @since 0.2.0.0 +addFuncs :: (Every Backprop as, Known Length as) => Prod AddFunc as +addFuncs = map1 (\i -> addFunc \\ every @_ @Backprop i) indices + +-- | Generate an 'OneFunc' for every type in a type-level list, if every +-- type has an instance of 'Backprop'. +-- +-- @since 0.2.0.0 +oneFuncs :: (Every Backprop as, Known Length as) => Prod OneFunc as +oneFuncs = map1 (\i -> oneFunc \\ every @_ @Backprop i) indices + +-- | Shorter alias for 'constVar', inspired by the /ad/ library. +-- +-- @since 0.2.0.0 +auto :: a -> BVar s a +auto = constVar +{-# INLINE auto #-} + +-- | 'Numeric.Backprop.backpropWithN', but with explicit 'zero'. +backpropWithN + :: Prod ZeroFunc as + -> (forall s. Reifies s W => Prod (BVar s) as -> BVar s b) + -> Tuple as + -> (b -> b) -- ^ Gradient of final result with respect to output of function + -> (b, Tuple as) +backpropWithN zfs f xs g = backpropN zfs (OF g) f xs +{-# INLINE backpropWithN #-} + +-- | 'Numeric.Backprop.backprop', but with explicit 'zero' and 'one'. +backprop + :: ZeroFunc a + -> OneFunc b + -> (forall s. Reifies s W => BVar s a -> BVar s b) + -> a + -> (b, a) +backprop zfa ofb f = second (getI . head') + . backpropN (zfa :< Ø) ofb (f . head') + . only_ +{-# INLINE backprop #-} + +-- | 'Numeric.Backprop.backpropWith', but with explicit 'zero'. +backpropWith + :: ZeroFunc a + -> (forall s. Reifies s W => BVar s a -> BVar s b) + -> a + -> (b -> b) -- ^ Gradient of final result with respect to output of function + -> (b, a) +backpropWith zfa f x g = backprop zfa (OF g) f x +{-# INLINE backpropWith #-} + +-- | Turn a function @'BVar' s a -> 'BVar' s b@ into the function @a -> b@ +-- that it represents. +-- +-- Benchmarks show that this should have virtually no overhead over +-- directly writing a @a -> b@. 'BVar' is, in this situation, a zero-cost +-- abstraction, performance-wise. +-- +-- See documentation of 'Numeric.Backprop.backprop' for more information. +evalBP :: (forall s. Reifies s W => BVar s a -> BVar s b) -> a -> b +evalBP f = evalBPN (f . head') . only_ +{-# INLINE evalBP #-} + +-- | 'Numeric.Backprop.gradBP', but with explicit 'zero' and 'one'. +gradBP + :: ZeroFunc a + -> OneFunc b + -> (forall s. Reifies s W => BVar s a -> BVar s b) + -> a + -> a +gradBP zfa ofb f = snd . backprop zfa ofb f +{-# INLINE gradBP #-} + +-- | 'Numeric.Backprop.gradBP', Nbut with explicit 'zero' and 'one'. +gradBPN + :: Prod ZeroFunc as + -> OneFunc b + -> (forall s. Reifies s W => Prod (BVar s) as -> BVar s b) + -> Tuple as + -> Tuple as +gradBPN zfas ofb f = snd . backpropN zfas ofb f +{-# INLINE gradBPN #-} + +-- | 'Numeric.Backprop.backprop2', but with explicit 'zero' and 'one'. +backprop2 + :: ZeroFunc a + -> ZeroFunc b + -> OneFunc c + -> (forall s. Reifies s W => BVar s a -> BVar s b -> BVar s c) + -> a + -> b + -> (c, (a, b)) +backprop2 zfa zfb ofc f x y = second (\(dx ::< dy ::< Ø) -> (dx, dy)) $ + backpropN (zfa :< zfb :< Ø) ofc + (\(x' :< y' :< Ø) -> f x' y') + (x ::< y ::< Ø) +{-# INLINE backprop2 #-} + +-- | 'Numeric.Backprop.backpropWith2', but with explicit 'zero'. +backpropWith2 + :: ZeroFunc a + -> ZeroFunc b + -> (forall s. Reifies s W => BVar s a -> BVar s b -> BVar s c) + -> a + -> b + -> (c -> c) -- ^ Gradient of final result with respect to output of function + -> (c, (a, b)) +backpropWith2 zfa zfb f x y g = backprop2 zfa zfb (OF g) f x y +{-# INLINE backpropWith2 #-} + +-- | 'evalBP' for a two-argument function. See +-- 'Numeric.Backprop.backprop2' for notes. +evalBP2 + :: (forall s. Reifies s W => BVar s a -> BVar s b -> BVar s c) + -> a + -> b + -> c +evalBP2 f x y = evalBPN (\(x' :< y' :< Ø) -> f x' y') (x ::< y ::< Ø) +{-# INLINE evalBP2 #-} + +-- | 'gradBP' for a two-argument function. See +-- 'Numeric.Backprop.backprop2' for notes. +gradBP2 + :: ZeroFunc a + -> ZeroFunc b + -> OneFunc c + -> (forall s. Reifies s W => BVar s a -> BVar s b -> BVar s c) + -> a + -> b + -> (a, b) +gradBP2 zfa zfb ofc f x = snd . backprop2 zfa zfb ofc f x +{-# INLINE gradBP2 #-} + +-- | 'Numeric.Backprop.isoVar' with explicit 'add' and 'zero'. +isoVar + :: Reifies s W + => AddFunc a + -> ZeroFunc b + -> (a -> b) + -> (b -> a) + -> BVar s a + -> BVar s b +isoVar af z f g = liftOp1 af z (opIso f g) +{-# INLINE isoVar #-} + +-- | 'Numeric.Backprop.isoVar2' with explicit 'add' and 'zero'. +isoVar2 + :: Reifies s W + => AddFunc a + -> AddFunc b + -> ZeroFunc c + -> (a -> b -> c) + -> (c -> (a, b)) + -> BVar s a + -> BVar s b + -> BVar s c +isoVar2 afa afb z f g = liftOp2 afa afb z (opIso2 f g) +{-# INLINE isoVar2 #-} + +-- | 'Numeric.Backprop.isoVar3' with explicit 'add' and 'zero'. +isoVar3 + :: Reifies s W + => AddFunc a + -> AddFunc b + -> AddFunc c + -> ZeroFunc d + -> (a -> b -> c -> d) + -> (d -> (a, b, c)) + -> BVar s a + -> BVar s b + -> BVar s c + -> BVar s d +isoVar3 afa afb afc z f g = liftOp3 afa afb afc z (opIso3 f g) +{-# INLINE isoVar3 #-} + +-- | 'Numeric.Backprop.isoVarN' with explicit 'add' and 'zero'. +isoVarN + :: Reifies s W + => Prod AddFunc as + -> ZeroFunc b + -> (Tuple as -> b) + -> (b -> Tuple as) + -> Prod (BVar s) as + -> BVar s b +isoVarN afs z f g = liftOp afs z (opIsoN f g) +{-# INLINE isoVarN #-} diff --git a/src/Numeric/Backprop/Internal.hs b/src/Numeric/Backprop/Internal.hs --- a/src/Numeric/Backprop/Internal.hs +++ b/src/Numeric/Backprop/Internal.hs @@ -10,6 +10,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} -- | @@ -32,6 +33,10 @@ , liftOp, liftOp1, liftOp2, liftOp3 , viewVar, setVar, sequenceVar, collectVar, previewVar, toListOfVar , coerceVar + -- * Func wrappers + , ZeroFunc(..), zfNum + , AddFunc(..), afNum + , OneFunc(..), ofNum -- * Debug , debugSTN , debugIR @@ -53,7 +58,7 @@ import Data.Monoid hiding (Any(..)) import Data.Proxy import Data.Reflection -import Data.Type.Index +import Data.Type.Conjunction import Data.Type.Product hiding (toList) import Data.Type.Util import Data.Type.Vector hiding (itraverse) @@ -64,11 +69,70 @@ import Numeric.Backprop.Op import System.IO.Unsafe import Type.Class.Higher -import Type.Class.Witness import Unsafe.Coerce import qualified Data.Vector as V import qualified Data.Vector.Mutable as MV +-- | "Zero out" all components of a value. For scalar values, this should +-- just be @'const' 0@. For vectors and matrices, this should set all +-- components to zero, the additive identity. +-- +-- Should be idempotent: Applying the function twice is the same as +-- applying it just once. +-- +-- Each type should ideally only have one 'ZeroFunc'. This coherence +-- constraint is given by the typeclass 'Backprop'. +-- +-- @since 0.2.0.0 +newtype ZeroFunc a = ZF { runZF :: a -> a } + +-- | Add together two values of a type. To combine contributions of +-- gradients, so should ideally be information-preserving. +-- +-- See laws for 'Backprop' for the laws this should be expected to +-- preserve. Namely, it should be commutative and associative, with an +-- identity for a valid 'ZeroFunc'. +-- +-- Each type should ideally only have one 'AddFunc'. This coherence +-- constraint is given by the typeclass 'Backprop'. +-- +-- @since 0.2.0.0 +newtype AddFunc a = AF { runAF :: a -> a -> a } + +-- | "One" all components of a value. For scalar values, this should +-- just be @'const' 1@. For vectors and matrices, this should set all +-- components to one, the multiplicative identity. +-- +-- Should be idempotent: Applying the function twice is the same as +-- applying it just once. +-- +-- Each type should ideally only have one 'OneFunc'. This coherence +-- constraint is given by the typeclass 'Backprop'. +-- +-- @since 0.2.0.0 +newtype OneFunc a = OF { runOF :: a -> a } + +-- | If a type has a 'Num' instance, this is the canonical 'ZeroFunc'. +-- +-- @since 0.2.0.0 +zfNum :: Num a => ZeroFunc a +zfNum = ZF (const 0) +{-# INLINE zfNum #-} + +-- | If a type has a 'Num' instance, this is the canonical 'AddFunc'. +-- +-- @since 0.2.0.0 +afNum :: Num a => AddFunc a +afNum = AF (+) +{-# INLINE afNum #-} + +-- | If a type has a 'Num' instance, this is the canonical 'OneFunc'. +-- +-- @since 0.2.0.0 +ofNum :: Num a => OneFunc a +ofNum = OF (const 1) +{-# INLINE ofNum #-} + -- | A @'BVar' s a@ is a value of type @a@ that can be "backpropagated". -- -- Functions referring to 'BVar's are tracked by the library and can be @@ -138,13 +202,12 @@ data InpRef :: Type -> Type where IR :: { _irIx :: !(BVar s b) - , _irUpd :: !(Lens' b a) - , _irAdd :: !(a -> a -> a) + , _irAdd :: !(a -> b -> b) } -> InpRef a forceInpRef :: InpRef a -> () -forceInpRef (IR v !_ !_) = forceBVar v `seq` () +forceInpRef (IR v !_) = forceBVar v `seq` () {-# INLINE forceInpRef #-} -- | Debugging string for an 'InpRef'. @@ -183,14 +246,14 @@ {-# INLINE initWengert #-} insertNode - :: Num a - => TapeNode a - -> a + :: TapeNode a + -> a -- ^ val + -> ZeroFunc a -> W -> IO (BVar s a) -insertNode tn !x !w = fmap ((`BV` x) . BRIx) . atomicModifyIORef' (wRef w) $ \(!n,!t) -> +insertNode tn !x zf !w = fmap ((`BV` x) . BRIx) . atomicModifyIORef' (wRef w) $ \(!n,!t) -> let n' = n + 1 - t' = STN 0 tn:t + t' = STN (runZF zf x) tn : t in forceTapeNode tn `seq` n' `seq` t' `seq` ((n', t'), n) {-# INLINE insertNode #-} @@ -203,286 +266,283 @@ {-# INLINE constVar #-} liftOp_ - :: forall s as b. (Reifies s W, Num b, Every Num as) - => Op as b + :: forall s as b. Reifies s W + => Prod AddFunc as + -> ZeroFunc b + -> Op as b -> Prod (BVar s) as -> IO (BVar s b) -liftOp_ o !vs = case traverse1 (fmap I . bvConst) vs of - Just xs -> return $ constVar (evalOp o xs) - Nothing -> insertNode tn y (reflect (Proxy @s)) +liftOp_ afs z o !vs = case traverse1 (fmap I . bvConst) vs of + Just xs -> return $ constVar (evalOp o xs) + Nothing -> insertNode tn y z (reflect (Proxy @s)) where (y,g) = runOpWith o (map1 (I . _bvVal) vs) - tn = TN { _tnInputs = imap1 go vs + tn = TN { _tnInputs = map1 go (zipP afs vs) , _tnGrad = g } - go :: forall a. Index as a -> BVar s a -> InpRef a - go i !v = forceBVar v `seq` (IR v id (+) \\ every @_ @Num i) + go :: forall a. (AddFunc :&: BVar s) a -> InpRef a + go (af :&: (!v)) = forceBVar v `seq` IR v (runAF af) {-# INLINE go #-} {-# INLINE liftOp_ #-} --- | Lift an 'Op' with an arbitrary number of inputs to a function on the --- appropriate number of 'BVar's. --- --- Should preferably be used only by libraries to provide primitive 'BVar' --- functions for their types for users. --- --- See "Numeric.Backprop#liftops" and documentation for 'liftOp' for more --- information, and "Numeric.Backprop.Op#prod" for a mini-tutorial on using --- 'Prod' and 'Tuple'. +-- | 'Numeric.Backprop.liftOp', but with explicit 'add' and 'zero'. liftOp - :: forall as b s. (Reifies s W, Num b, Every Num as) - => Op as b + :: forall as b s. Reifies s W + => Prod AddFunc as + -> ZeroFunc b + -> Op as b -> Prod (BVar s) as -> BVar s b -liftOp o !vs = unsafePerformIO $ liftOp_ o vs +liftOp afs z o !vs = unsafePerformIO $ liftOp_ afs z o vs {-# INLINE liftOp #-} liftOp1_ - :: forall a b s. (Reifies s W, Num a, Num b) - => Op '[a] b + :: forall a b s. Reifies s W + => AddFunc a + -> ZeroFunc b + -> Op '[a] b -> BVar s a -> IO (BVar s b) -liftOp1_ o (bvConst->Just x) = return . constVar . evalOp o $ (x ::< Ø) -liftOp1_ o v = forceBVar v `seq` insertNode tn y (reflect (Proxy @s)) +liftOp1_ _ _ o (bvConst->Just x) = return . constVar . evalOp o $ (x ::< Ø) +liftOp1_ af z o v = forceBVar v `seq` insertNode tn y z (reflect (Proxy @s)) where (y,g) = runOpWith o (_bvVal v ::< Ø) - tn = TN { _tnInputs = IR v id (+) :< Ø + tn = TN { _tnInputs = IR v (runAF af) :< Ø , _tnGrad = g } {-# INLINE liftOp1_ #-} --- | Lift an 'Op' with a single input to be a function on a single 'BVar'. --- --- Should preferably be used only by libraries to provide primitive 'BVar' --- functions for their types for users. --- --- See "Numeric.Backprop#liftops" and documentation for 'liftOp' for more --- information. +-- | 'Numeric.Backprop.liftOp1', but with explicit 'add' and 'zero'. liftOp1 - :: forall a b s. (Reifies s W, Num a, Num b) - => Op '[a] b + :: forall a b s. Reifies s W + => AddFunc a + -> ZeroFunc b + -> Op '[a] b -> BVar s a -> BVar s b -liftOp1 o !v = unsafePerformIO $ liftOp1_ o v +liftOp1 af z o !v = unsafePerformIO $ liftOp1_ af z o v {-# INLINE liftOp1 #-} liftOp2_ - :: forall a b c s. (Reifies s W, Num a, Num b, Num c) - => Op '[a,b] c + :: forall a b c s. Reifies s W + => AddFunc a + -> AddFunc b + -> ZeroFunc c + -> Op '[a,b] c -> BVar s a -> BVar s b -> IO (BVar s c) -liftOp2_ o (bvConst->Just x) (bvConst->Just y) = return . constVar . evalOp o $ x ::< y ::< Ø -liftOp2_ o v u = forceBVar v - `seq` forceBVar u - `seq` insertNode tn y (reflect (Proxy @s)) +liftOp2_ _ _ _ o (bvConst->Just x) (bvConst->Just y) + = return . constVar . evalOp o $ x ::< y ::< Ø +liftOp2_ afa afb z o v u = forceBVar v + `seq` forceBVar u + `seq` insertNode tn y z (reflect (Proxy @s)) where (y,g) = runOpWith o (_bvVal v ::< _bvVal u ::< Ø) - tn = TN { _tnInputs = IR v id (+) :< IR u id (+) :< Ø + tn = TN { _tnInputs = IR v (runAF afa) :< IR u (runAF afb) :< Ø , _tnGrad = g } {-# INLINE liftOp2_ #-} --- | Lift an 'Op' with two inputs to be a function on a two 'BVar's. --- --- Should preferably be used only by libraries to provide primitive 'BVar' --- functions for their types for users. --- --- See "Numeric.Backprop#liftops" and documentation for 'liftOp' for more --- information. +-- | 'Numeric.Backprop.liftOp2', but with explicit 'add' and 'zero'. liftOp2 - :: forall a b c s. (Reifies s W, Num a, Num b, Num c) - => Op '[a,b] c + :: forall a b c s. Reifies s W + => AddFunc a + -> AddFunc b + -> ZeroFunc c + -> Op '[a,b] c -> BVar s a -> BVar s b -> BVar s c -liftOp2 o !v !u = unsafePerformIO $ liftOp2_ o v u +liftOp2 afa afb z o !v !u = unsafePerformIO $ liftOp2_ afa afb z o v u {-# INLINE liftOp2 #-} liftOp3_ - :: forall a b c d s. (Reifies s W, Num a, Num b, Num c, Num d) - => Op '[a,b,c] d + :: forall a b c d s. Reifies s W + => AddFunc a + -> AddFunc b + -> AddFunc c + -> ZeroFunc d + -> Op '[a,b,c] d -> BVar s a -> BVar s b -> BVar s c -> IO (BVar s d) -liftOp3_ o (bvConst->Just x) (bvConst->Just y) (bvConst->Just z) +liftOp3_ _ _ _ _ o (bvConst->Just x) (bvConst->Just y) (bvConst->Just z) = return . constVar . evalOp o $ x ::< y ::< z ::< Ø -liftOp3_ o v u w = forceBVar v - `seq` forceBVar u - `seq` forceBVar w - `seq` insertNode tn y (reflect (Proxy @s)) +liftOp3_ afa afb afc z o v u w = forceBVar v + `seq` forceBVar u + `seq` forceBVar w + `seq` insertNode tn y z (reflect (Proxy @s)) where (y, g) = runOpWith o (_bvVal v ::< _bvVal u ::< _bvVal w ::< Ø) - tn = TN { _tnInputs = IR v id (+) :< IR u id (+) :< IR w id (+) :< Ø + tn = TN { _tnInputs = IR v (runAF afa) + :< IR u (runAF afb) + :< IR w (runAF afc) + :< Ø , _tnGrad = g } {-# INLINE liftOp3_ #-} --- | Lift an 'Op' with three inputs to be a function on a three 'BVar's. --- --- Should preferably be used only by libraries to provide primitive 'BVar' --- functions for their types for users. --- --- See "Numeric.Backprop#liftops" and documentation for 'liftOp' for more --- information. +-- | 'Numeric.Backprop.liftOp3', but with explicit 'add' and 'zero'. liftOp3 - :: forall a b c d s. (Reifies s W, Num a, Num b, Num c, Num d) - => Op '[a,b,c] d + :: forall a b c d s. Reifies s W + => AddFunc a + -> AddFunc b + -> AddFunc c + -> ZeroFunc d + -> Op '[a,b,c] d -> BVar s a -> BVar s b -> BVar s c -> BVar s d -liftOp3 o !v !u !w = unsafePerformIO $ liftOp3_ o v u w +liftOp3 afa afb afc z o !v !u !w = unsafePerformIO $ liftOp3_ afa afb afc z o v u w {-# INLINE liftOp3 #-} +-- TODO: can we get the zero and scale func from the bvar? viewVar_ - :: forall a b s. (Reifies s W, Num a) - => Lens' b a + :: forall a b s. Reifies s W + => AddFunc a + -> ZeroFunc a + -> Lens' b a -> BVar s b -> IO (BVar s a) -viewVar_ l v = forceBVar v `seq` insertNode tn y (reflect (Proxy @s)) +viewVar_ af z l v = forceBVar v `seq` insertNode tn y z (reflect (Proxy @s)) where y = _bvVal v ^. l - tn = TN { _tnInputs = IR v l (+) :< Ø + tn = TN { _tnInputs = IR v (over l . runAF af) :< Ø , _tnGrad = only_ } {-# INLINE viewVar_ #-} --- | Using a 'Lens'', extract a value /inside/ a 'BVar'. Meant to evoke --- parallels to 'view' from lens. --- --- See documentation for '^^.' for more information. +-- | 'Numeric.Backprop.viewVar', but with explicit 'add' and 'zero'. viewVar - :: forall a b s. (Reifies s W, Num a) - => Lens' b a + :: forall a b s. Reifies s W + => AddFunc a + -> ZeroFunc a + -> Lens' b a -> BVar s b -> BVar s a -viewVar l !v = unsafePerformIO $ viewVar_ l v +viewVar af z l !v = unsafePerformIO $ viewVar_ af z l v {-# INLINE viewVar #-} +-- TODO: can zero and scale func be gotten from the input bvars? setVar_ - :: forall a b s. (Reifies s W, Num a, Num b) - => Lens' b a + :: forall a b s. Reifies s W + => AddFunc a + -> AddFunc b + -> ZeroFunc a + -> ZeroFunc b + -> Lens' b a -> BVar s a -> BVar s b -> IO (BVar s b) -setVar_ l w v = forceBVar v - `seq` forceBVar w - `seq` insertNode tn y (reflect (Proxy @s)) +setVar_ afa afb za zb l w v = forceBVar v + `seq` forceBVar w + `seq` insertNode tn y zb (reflect (Proxy @s)) where y = _bvVal v & l .~ _bvVal w - tn = TN { _tnInputs = IR w id (+) :< IR v id (+) :< Ø - , _tnGrad = \d -> let (dw,dv) = l (,0) d + tn = TN { _tnInputs = IR w (runAF afa) :< IR v (runAF afb) :< Ø + , _tnGrad = \d -> let (dw,dv) = l (\x -> (x, runZF za x)) d in dw ::< dv ::< Ø } {-# INLINE setVar_ #-} --- | Using a 'Lens'', set a value /inside/ a 'BVar'. Meant to evoke --- parallels to "set" from lens. --- --- See documentation for '.~~' for more information. +-- | 'Numeric.Backprop.setVar', but with explicit 'add' and 'zero'. setVar - :: forall a b s. (Reifies s W, Num a, Num b) - => Lens' b a + :: forall a b s. Reifies s W + => AddFunc a + -> AddFunc b + -> ZeroFunc a + -> ZeroFunc b + -> Lens' b a -> BVar s a -> BVar s b -> BVar s b -setVar l !w !v = unsafePerformIO $ setVar_ l w v +setVar afa afb za zb l !w !v = unsafePerformIO $ setVar_ afa afb za zb l w v {-# INLINE setVar #-} --- | Extract all of the 'BVar's out of a 'Traversable' container of --- 'BVar's. --- --- Note that this associates gradients in order of occurrence in the --- original data structure; the second item in the gradient is assumed to --- correspond with the second item in the input, etc.; this can cause --- unexpected behavior in 'Foldable' instances that don't have a fixed --- number of items. +-- | 'Numeric.Backprop.sequenceVar', but with explicit 'add' and 'zero'. sequenceVar - :: forall t a s. (Reifies s W, Traversable t, Num a) - => BVar s (t a) + :: forall t a s. (Reifies s W, Traversable t) + => AddFunc a + -> ZeroFunc a + -> BVar s (t a) -> t (BVar s a) -sequenceVar !v = unsafePerformIO $ traverseVar' id traverse v +sequenceVar af z !v = unsafePerformIO $ traverseVar' af z id traverse v {-# INLINE sequenceVar #-} +-- TODO: can scale funcs and zeros be had from bvars and Functor instance? collectVar_ - :: forall t a s. (Reifies s W, Foldable t, Functor t, Num (t a), Num a) - => t (BVar s a) + :: forall t a s. (Reifies s W, Foldable t, Functor t) + => AddFunc a + -> ZeroFunc a + -> ZeroFunc (t a) + -> t (BVar s a) -> IO (BVar s (t a)) -collectVar_ !vs = withV (toList vs) $ \(vVec :: Vec n (BVar s a)) -> do +collectVar_ af z z' !vs = withV (toList vs) $ \(vVec :: Vec n (BVar s a)) -> do let tn :: TapeNode (t a) - tn = TN { _tnInputs = vecToProd (vmap ((\v -> IR v id (+)) . getI) vVec) - , _tnGrad = vecToProd - . listToVecDef 0 (vecLen vVec) - . map I . toList - } + tn = TN + { _tnInputs = vecToProd (vmap ((`IR` runAF af) . getI) vVec) + , _tnGrad = vecToProd + . zipVecList (\(I v) -> I . fromMaybe (runZF z (_bvVal v))) vVec + . toList + } traverse_ (evaluate . forceBVar) vs - insertNode tn (_bvVal <$> vs) (reflect (Proxy @s)) + insertNode tn (_bvVal <$> vs) z' (reflect (Proxy @s)) {-# INLINE collectVar_ #-} --- | Collect all of the 'BVar's in a container into a 'BVar' of that --- container's contents. --- --- Note that this associates gradients in order of occurrence in the --- original data structure; the second item in the total derivative and --- gradient is assumed to correspond with the second item in the input, --- etc.; this can cause unexpected behavior in 'Foldable' instances that --- don't have a fixed number of items. --- --- Note that this requires @t a@ to have a 'Num' instance. If you are --- using a list, I recommend using --- instead: --- it's a fixed-length vector type with a very appropriate 'Num' instance! +-- | 'Numeric.Backprop.collectVar', but with explicit 'add' and 'zero'. collectVar - :: forall t a s. (Reifies s W, Foldable t, Functor t, Num (t a), Num a) - => t (BVar s a) + :: forall t a s. (Reifies s W, Foldable t, Functor t) + => AddFunc a + -> ZeroFunc a + -> ZeroFunc (t a) + -> t (BVar s a) -> BVar s (t a) -collectVar !vs = unsafePerformIO $ collectVar_ vs +collectVar af z z' !vs = unsafePerformIO $ collectVar_ af z z' vs {-# INLINE collectVar #-} traverseVar' - :: forall b a f s. (Num a, Reifies s W, Traversable f) - => (b -> f a) + :: forall b a f s. (Reifies s W, Traversable f) + => AddFunc a + -> ZeroFunc a + -> (b -> f a) -> Traversal' b a -> BVar s b -> IO (f (BVar s a)) -traverseVar' f t v = forceBVar v - `seq` itraverse go (f (_bvVal v)) +traverseVar' af z f t v = forceBVar v + `seq` itraverse go (f (_bvVal v)) where go :: Int -> a -> IO (BVar s a) - go i y = insertNode tn y (reflect (Proxy @s)) + go i y = insertNode tn y z (reflect (Proxy @s)) where - tn = TN { _tnInputs = IR v (ixt t i) (+) :< Ø + tn = TN { _tnInputs = IR v (over (ixt t i) . runAF af) :< Ø , _tnGrad = only_ } {-# INLINE go #-} {-# INLINE traverseVar' #-} --- | Using a 'Traversal'', extract a single value /inside/ a 'BVar', if it --- exists. If more than one traversal target exists, returns te first. --- Meant to evoke parallels to 'preview' from lens. Really only intended --- to be used wth 'Prism''s, or up-to-one target traversals. --- --- See documentation for '^^?' for more information. +-- | 'Numeric.Backprop.previewVar', but with explicit 'add' and 'zero'. previewVar - :: forall b a s. (Num a, Reifies s W) - => Traversal' b a + :: forall b a s. Reifies s W + => AddFunc a + -> ZeroFunc a + -> Traversal' b a -> BVar s b -> Maybe (BVar s a) -previewVar t !v = unsafePerformIO $ traverseVar' (listToMaybe . toListOf t) t v +previewVar af z t !v = unsafePerformIO $ traverseVar' af z (listToMaybe . toListOf t) t v {-# INLINE previewVar #-} --- | Using a 'Traversal'', extract all targeted values /inside/ a 'BVar'. --- Meant to evoke parallels to 'toListOf' from lens. --- --- See documentation for '^^..' for more information. +-- | 'Numeric.Backprop.toListOfVar', but with explicit 'add' and 'zero'. toListOfVar - :: forall b a s. (Num a, Reifies s W) - => Traversal' b a + :: forall b a s. Reifies s W + => AddFunc a + -> ZeroFunc a + -> Traversal' b a -> BVar s b -> [BVar s a] -toListOfVar t !v = unsafePerformIO $ traverseVar' (toListOf t) t v +toListOfVar af z t !v = unsafePerformIO $ traverseVar' af z (toListOf t) t v {-# INLINE toListOfVar #-} -- | Coerce a 'BVar' contents. Useful for things like newtype wrappers. @@ -501,27 +561,27 @@ initRunner :: (PrimMonad m, PrimState m ~ s) => (Int, [SomeTapeNode]) - -> (Int, [Some (Wit1 Num)]) + -> (Int, [Any]) -> m (Runner s) initRunner (n, stns) (nx,xs) = do delts <- MV.new n for_ (zip [n-1,n-2..] stns) $ \(i, STN z (TN{..} :: TapeNode c)) -> MV.write delts i $ unsafeCoerce z inps <- MV.new nx - for_ (zip [0..] xs) $ \(i, Some (Wit1 :: Wit1 Num c)) -> - MV.write inps i $ unsafeCoerce @c 0 + for_ (zip [0..] xs) . uncurry $ \i z -> + MV.write inps i z return $ R delts inps {-# INLINE initRunner #-} gradRunner - :: forall m b s p. (PrimMonad m, PrimState m ~ s, Num b) - => p b + :: forall m b s. (PrimMonad m, PrimState m ~ s) + => b -- ^ one -> Runner s -> (Int, [SomeTapeNode]) -> m () -gradRunner _ R{..} (n,stns) = do +gradRunner o R{..} (n,stns) = do when (n > 0) $ - MV.write _rDelta (n - 1) (unsafeCoerce @b 1) + MV.write _rDelta (n - 1) (unsafeCoerce o) zipWithM_ go [n-1,n-2..] stns where go :: Int -> SomeTapeNode -> m () @@ -531,65 +591,43 @@ zipWithPM_ propagate _tnInputs gs {-# INLINE go #-} propagate :: forall x. InpRef x -> I x -> m () - propagate (IR v ln (+*)) (I d) = case _bvRef v of + propagate (IR v (+*)) (I d) = case _bvRef v of BRInp i -> flip (MV.modify _rInputs) i $ - unsafeCoerce . (ln %~ (+* d)) . unsafeCoerce + unsafeCoerce . (d +*) . unsafeCoerce BRIx i -> flip (MV.modify _rDelta) i $ - unsafeCoerce . (ln %~ (+* d)) . unsafeCoerce + unsafeCoerce . (d +*) . unsafeCoerce BRC -> return () {-# INLINE propagate #-} {-# INLINE gradRunner #-} --- | 'backprop' generalized to multiple inputs of different types. See the --- "Numeric.Backprop.Op#prod" for a mini-tutorial on heterogeneous lists. --- --- Not strictly necessary, because you can always uncurry a function by --- passing in all of the inputs in a data type containing all of the --- arguments or a tuple from "Numeric.Backprop.Tuple". You could also --- pass in a giant tuple with --- . --- However, this can be convenient if you don't want to make a custom --- larger tuple type or pull in orphan instances. This could potentially --- also be more performant. --- --- A @'Prod' ('BVar' s) '[Double, Float, Double]@, for instance, is a tuple --- of @'BVar' s 'Double'@, @'BVar' s 'Float'@, and @'BVar' s 'Double'@, and --- can be pattern matched on using ':<' (cons) and 'Ø' (nil). --- --- Tuples can be built and pattern matched on using '::<' (cons) and 'Ø' --- (nil), as well. --- --- The @'Every' 'Num' as@ in the constraint says that every value in the --- type-level list @as@ must have a 'Num' instance. This means you can --- use, say, @'[Double, Float, Int]@, but not @'[Double, Bool, String]@. --- --- If you stick to /concerete/, monomorphic usage of this (with specific --- types, typed into source code, known at compile-time), then @'Every' --- 'Num' as@ should be fulfilled automatically. --- +-- | 'Numeric.Backprop.backpropN', but with explicit 'zero' and 'one'. backpropN - :: forall as b. (Every Num as, Num b) - => (forall s. Reifies s W => Prod (BVar s) as -> BVar s b) + :: forall as b. () + => Prod ZeroFunc as + -> OneFunc b + -> (forall s. Reifies s W => Prod (BVar s) as -> BVar s b) -> Tuple as -> (b, Tuple as) -backpropN f !xs = (y, g) +backpropN zfs ofb f !xs = (y, g) where !(!tp@(!_,!_),!y) = unsafePerformIO $ fillWengert f xs g :: Tuple as g = runST $ do - r <- initRunner tp (getSum `first` ifoldMap1 go xs) - gradRunner (Proxy @b) r tp + r <- initRunner tp $ bimap getSum (`appEndo` []) + . fst + $ zipWithPM_ go zfs xs + gradRunner (runOF ofb y) r tp delts <- toList <$> V.freeze (_rInputs r) return . fromMaybe (error "backpropN") $ fillProd (\_ d -> I (unsafeCoerce d)) xs delts where - go :: forall a. Index as a -> I a -> (Sum Int, [Some (Wit1 Num)]) - go i (I _) = (1, [Some (Wit1 :: Wit1 Num a)]) \\ every @_ @Num i + go :: forall a. ZeroFunc a -> I a -> ((Sum Int, Endo [Any]),()) + go zf (I x) = ((1, Endo (unsafeCoerce (runZF zf x) :)), ()) {-# INLINE go #-} {-# INLINE backpropN #-} -- | 'evalBP' generalized to multiple inputs of different types. See --- documentation for 'backpropN' for more details. +-- documentation for 'Numeric.Backprop.backpropN' for more details. evalBPN :: forall as b. () => (forall s. Reifies s W => Prod (BVar s) as -> BVar s b) @@ -623,25 +661,25 @@ instance (Num a, Reifies s W) => Num (BVar s a) where - (+) = liftOp2 (+.) + (+) = liftOp2 afNum afNum zfNum (+.) {-# INLINE (+) #-} - (-) = liftOp2 (-.) + (-) = liftOp2 afNum afNum zfNum (-.) {-# INLINE (-) #-} - (*) = liftOp2 (*.) + (*) = liftOp2 afNum afNum zfNum (*.) {-# INLINE (*) #-} - negate = liftOp1 negateOp + negate = liftOp1 afNum zfNum negateOp {-# INLINE negate #-} - signum = liftOp1 signumOp + signum = liftOp1 afNum zfNum signumOp {-# INLINE signum #-} - abs = liftOp1 absOp + abs = liftOp1 afNum zfNum absOp {-# INLINE abs #-} fromInteger = constVar . fromInteger {-# INLINE fromInteger #-} instance (Fractional a, Reifies s W) => Fractional (BVar s a) where - (/) = liftOp2 (/.) + (/) = liftOp2 afNum afNum zfNum (/.) {-# INLINE (/) #-} - recip = liftOp1 recipOp + recip = liftOp1 afNum zfNum recipOp {-# INLINE recip #-} fromRational = constVar . fromRational {-# INLINE fromRational #-} @@ -649,39 +687,39 @@ instance (Floating a, Reifies s W) => Floating (BVar s a) where pi = constVar pi {-# INLINE pi #-} - exp = liftOp1 expOp + exp = liftOp1 afNum zfNum expOp {-# INLINE exp #-} - log = liftOp1 logOp + log = liftOp1 afNum zfNum logOp {-# INLINE log #-} - sqrt = liftOp1 sqrtOp + sqrt = liftOp1 afNum zfNum sqrtOp {-# INLINE sqrt #-} - (**) = liftOp2 (**.) + (**) = liftOp2 afNum afNum zfNum (**.) {-# INLINE (**) #-} - logBase = liftOp2 logBaseOp + logBase = liftOp2 afNum afNum zfNum logBaseOp {-# INLINE logBase #-} - sin = liftOp1 sinOp + sin = liftOp1 afNum zfNum sinOp {-# INLINE sin #-} - cos = liftOp1 cosOp + cos = liftOp1 afNum zfNum cosOp {-# INLINE cos #-} - tan = liftOp1 tanOp + tan = liftOp1 afNum zfNum tanOp {-# INLINE tan #-} - asin = liftOp1 asinOp + asin = liftOp1 afNum zfNum asinOp {-# INLINE asin #-} - acos = liftOp1 acosOp + acos = liftOp1 afNum zfNum acosOp {-# INLINE acos #-} - atan = liftOp1 atanOp + atan = liftOp1 afNum zfNum atanOp {-# INLINE atan #-} - sinh = liftOp1 sinhOp + sinh = liftOp1 afNum zfNum sinhOp {-# INLINE sinh #-} - cosh = liftOp1 coshOp + cosh = liftOp1 afNum zfNum coshOp {-# INLINE cosh #-} - tanh = liftOp1 tanhOp + tanh = liftOp1 afNum zfNum tanhOp {-# INLINE tanh #-} - asinh = liftOp1 asinhOp + asinh = liftOp1 afNum zfNum asinhOp {-# INLINE asinh #-} - acosh = liftOp1 acoshOp + acosh = liftOp1 afNum zfNum acoshOp {-# INLINE acosh #-} - atanh = liftOp1 atanhOp + atanh = liftOp1 afNum zfNum atanhOp {-# INLINE atanh #-} -- | Compares the values inside the 'BVar'. @@ -727,4 +765,3 @@ go [] = error "asList" go (y:ys) = (y, ys) {-# INLINE ixt #-} - diff --git a/src/Numeric/Backprop/Num.hs b/src/Numeric/Backprop/Num.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Backprop/Num.hs @@ -0,0 +1,426 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} + +-- | +-- Module : Numeric.Backprop.Num +-- Copyright : (c) Justin Le 2018 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Provides the exact same API as "Numeric.Backprop", except requiring +-- 'Num' instances for all types involved instead of 'Backprop' instances. +-- +-- This was the original API of the library (for version 0.1). +-- +-- 'Num' is strictly more powerful than 'Backprop', and is a stronger +-- constraint on types than is necessary for proper backpropagating. In +-- particular, 'fromInteger' is a problem for many types, preventing useful +-- backpropagation for lists, variable-length vectors (like "Data.Vector") +-- and variable-size matrices from linear algebra libraries like /hmatrix/ +-- and /accelerate/. +-- +-- However, this module might be useful in situations where you are working +-- with external types with 'Num' instances, and you want to avoid writing +-- orphan instances for external types. +-- +-- If you have external types that are not 'Num' instances, consider +-- instead "Numeric.Backprop.External". +-- +-- If you need a 'Num' instance for tuples, you can use the canonical 2- +-- and 3-tuples for the library in "Numeric.Backprop.Tuple". If you need +-- one for larger tuples, consider making a custom product type instead +-- (making Num instances with something like +-- ). You can also use the orphan instances in the +-- package +-- (in particular, "Data.NumInstances.Tuple") if you are writing an +-- application and do not have to worry about orphan instances. +-- +-- See "Numeric.Backprop" for fuller documentation on using these +-- functions. +-- +-- @since 0.2.0.0 + +module Numeric.Backprop.Num ( + -- * Types + BVar, W + -- * Running + , backprop, E.evalBP, gradBP, backpropWith + -- ** Multiple inputs + , backprop2, E.evalBP2, gradBP2, backpropWith2 + , backpropN, E.evalBPN, gradBPN, backpropWithN, Every + -- * Manipulating 'BVar' + , E.constVar, E.auto, E.coerceVar + , (^^.), (.~~), (^^?), (^^..) + , viewVar, setVar + , sequenceVar, collectVar + , previewVar, toListOfVar + -- ** With Isomorphisms + , isoVar, isoVar2, isoVar3, isoVarN + -- ** With 'Op's#liftops# + -- $liftops + , liftOp + , liftOp1, liftOp2, liftOp3 + -- * 'Op' + , Op(..) + -- ** Creation + , op0, opConst, idOp + , opConst' + -- *** Giving gradients directly + , op1, op2, op3 + -- *** From Isomorphisms + , opCoerce, opTup, opIso, opIsoN, opLens + -- *** No gradients + , noGrad1, noGrad + -- * Utility + -- ** Inductive tuples/heterogeneous lists + , Prod(..), pattern (:>), only, head' + , Tuple, pattern (::<), only_ + , I(..) + -- ** Misc + , Reifies + ) where + +import Data.Reflection +import Data.Type.Index +import Data.Type.Length +import Lens.Micro +import Numeric.Backprop.Explicit (BVar, W) +import Numeric.Backprop.Op +import Type.Class.Known +import qualified Numeric.Backprop.Explicit as E + +-- | 'Numeric.Backprop.backpropN', but with 'Num' constraints instead of +-- 'Backprop' constraints. +-- +-- The @'Every' 'Num' as@ in the constraint says that every value in the +-- type-level list @as@ must have a 'Num' instance. This means you can +-- use, say, @'[Double, Float, Int]@, but not @'[Double, Bool, String]@. +-- +-- If you stick to /concerete/, monomorphic usage of this (with specific +-- types, typed into source code, known at compile-time), then @'Every' +-- 'Num' as@ should be fulfilled automatically. +-- +backpropN + :: (Every Num as, Known Length as, Num b) + => (forall s. Reifies s W => Prod (BVar s) as -> BVar s b) + -> Tuple as + -> (b, Tuple as) +backpropN = E.backpropN E.zfNums E.ofNum +{-# INLINE backpropN #-} + +-- | 'Numeric.Backprop.backpropWithN', but with 'Num' constraints instead +-- of 'Backprop' constraints. +-- +-- See 'backpropN' for information on the 'Every' constraint. +backpropWithN + :: (Every Num as, Known Length as) + => (forall s. Reifies s W => Prod (BVar s) as -> BVar s b) + -> Tuple as + -> (b -> b) -- ^ Gradient of final result with respect to output of function + -> (b, Tuple as) +backpropWithN = E.backpropWithN E.zfNums +{-# INLINE backpropWithN #-} + +-- | 'Numeric.Backprop.backprop', but with 'Num' constraints instead of +-- 'Backprop' constraints. +-- +-- See module documentation for "Numeric.Backprop.Num" for information on +-- using this with tuples. +backprop + :: (Num a, Num b) + => (forall s. Reifies s W => BVar s a -> BVar s b) + -> a + -> (b, a) +backprop = E.backprop E.zfNum E.ofNum +{-# INLINE backprop #-} + +-- | 'Numeric.Backprop.backpropWith', but with 'Num' constraints instead of +-- 'Backprop' constraints. +-- +-- See module documentation for "Numeric.Backprop.Num" for information on +-- using this with tuples. +backpropWith + :: Num a + => (forall s. Reifies s W => BVar s a -> BVar s b) + -> a + -> (b -> b) -- ^ Gradient of final result with respect to output of function + -> (b, a) +backpropWith = E.backpropWith E.zfNum +{-# INLINE backpropWith #-} + +-- | 'Numeric.Backprop.gradBP', but with 'Num' constraints instead of +-- 'Backprop' constraints. +gradBP + :: (Num a, Num b) + => (forall s. Reifies s W => BVar s a -> BVar s b) + -> a + -> a +gradBP = E.gradBP E.zfNum E.ofNum +{-# INLINE gradBP #-} + +-- | 'Numeric.Backprop.gradBPN', but with 'Num' constraints instead of +-- 'Backprop' constraints. +gradBPN + :: (Every Num as, Known Length as, Num b) + => (forall s. Reifies s W => Prod (BVar s) as -> BVar s b) + -> Tuple as + -> Tuple as +gradBPN = E.gradBPN E.zfNums E.ofNum +{-# INLINE gradBPN #-} + +-- | 'Numeric.Backprop.backprop2', but with 'Num' constraints instead of +-- 'Backprop' constraints. +backprop2 + :: (Num a, Num b, Num c) + => (forall s. Reifies s W => BVar s a -> BVar s b -> BVar s c) + -> a + -> b + -> (c, (a, b)) +backprop2 = E.backprop2 E.zfNum E.zfNum E.ofNum +{-# INLINE backprop2 #-} + +-- | 'Numeric.Backprop.backpropWith2', but with 'Num' constraints instead of +-- 'Backprop' constraints. +backpropWith2 + :: (Num a, Num b) + => (forall s. Reifies s W => BVar s a -> BVar s b -> BVar s c) + -> a + -> b + -> (c -> c) -- ^ Gradient of final result with respect to output of function + -> (c, (a, b)) +backpropWith2 = E.backpropWith2 E.zfNum E.zfNum +{-# INLINE backpropWith2 #-} + +-- | 'Numeric.Backprop.gradBP2', but with 'Num' constraints instead of +-- 'Backprop' constraints. +gradBP2 + :: (Num a, Num b, Num c) + => (forall s. Reifies s W => BVar s a -> BVar s b -> BVar s c) + -> a + -> b + -> (a, b) +gradBP2 = E.gradBP2 E.zfNum E.zfNum E.ofNum +{-# INLINE gradBP2 #-} + +-- | 'Numeric.Backprop.^^.', but with 'Num' constraints instead of +-- 'Backprop' constraints. +(^^.) + :: forall a b s. (Reifies s W, Num a) + => BVar s b + -> Lens' b a + -> BVar s a +x ^^. l = viewVar l x +infixl 8 ^^. +{-# INLINE (^^.) #-} + +-- | 'Numeric.Backprop.viewVar', but with 'Num' constraints instead of +-- 'Backprop' constraints. +viewVar + :: forall a b s. (Reifies s W, Num a) + => Lens' b a + -> BVar s b + -> BVar s a +viewVar = E.viewVar E.afNum E.zfNum +{-# INLINE viewVar #-} + + +-- | 'Numeric.Backprop..~~', but with 'Num' constraints instead of +-- 'Backprop' constraints. +(.~~) + :: forall a b s. (Reifies s W, Num a, Num b) + => Lens' b a + -> BVar s a + -> BVar s b + -> BVar s b +l .~~ x = setVar l x +infixl 8 .~~ +{-# INLINE (.~~) #-} + +-- | 'Numeric.Backprop.setVar', but with 'Num' constraints instead of +-- 'Backprop' constraints. +setVar + :: forall a b s. (Reifies s W, Num a, Num b) + => Lens' b a + -> BVar s a + -> BVar s b + -> BVar s b +setVar = E.setVar E.afNum E.afNum E.zfNum E.zfNum +{-# INLINE setVar #-} + +-- | 'Numeric.Backprop.^^?', but with 'Num' constraints instead of +-- 'Backprop' constraints. +-- +-- Note that many automatically-generated prisms by the /lens/ package use +-- tuples, which cannot work this this by default (because tuples do not +-- have a 'Num' instance). +-- +-- If you are writing an application or don't have to worry about orphan +-- instances, you can pull in the orphan instances from +-- . +-- Alternatively, you can chain those prisms with conversions to the +-- anonymous canonical strict tuple types in "Numeric.Backprop.Tuple", +-- which do have 'Num' instances. +-- +-- @ +-- myPrism :: 'Prism'' c (a, b) +-- myPrism . 'iso' 'tupT2' 't2Tup' :: 'Prism'' c ('T2' a b) +-- @ +(^^?) + :: forall b a s. (Num a, Reifies s W) + => BVar s b + -> Traversal' b a + -> Maybe (BVar s a) +v ^^? t = previewVar t v +{-# INLINE (^^?) #-} + +-- | 'Numeric.Backprop.previewVar', but with 'Num' constraints instead of +-- 'Backprop' constraints. +-- +-- See documentation for '^^?' for more information and important notes. +previewVar + :: forall b a s. (Reifies s W, Num a) + => Traversal' b a + -> BVar s b + -> Maybe (BVar s a) +previewVar = E.previewVar E.afNum E.zfNum +{-# INLINE previewVar #-} + +-- | 'Numeric.Backprop.^^..', but with 'Num' constraints instead of +-- 'Backprop' constraints. +(^^..) + :: forall b a s. (Num a, Reifies s W) + => BVar s b + -> Traversal' b a + -> [BVar s a] +v ^^.. t = toListOfVar t v +{-# INLINE (^^..) #-} + +-- | 'Numeric.Backprop.toListOfVar', but with 'Num' constraints instead of +-- 'Backprop' constraints. +toListOfVar + :: forall b a s. (Num a, Reifies s W) + => Traversal' b a + -> BVar s b + -> [BVar s a] +toListOfVar = E.toListOfVar E.afNum E.zfNum +{-# INLINE toListOfVar #-} + +-- | 'Numeric.Backprop.sequenceVar', but with 'Num' constraints instead of +-- 'Backprop' constraints. +sequenceVar + :: forall t a s. (Num a, Reifies s W, Traversable t) + => BVar s (t a) + -> t (BVar s a) +sequenceVar = E.sequenceVar E.afNum E.zfNum +{-# INLINE sequenceVar #-} + +-- | 'Numeric.Backprop.collectVar', but with 'Num' constraints instead of +-- 'Backprop' constraints. +-- +-- If you are using a list or vector, I recommend using +-- instead: +-- it's a fixed-length vector type with a very appropriate 'Num' instance! +collectVar + :: forall t a s. (Num a, Num (t a), Reifies s W, Foldable t, Functor t) + => t (BVar s a) + -> BVar s (t a) +collectVar = E.collectVar E.afNum E.zfNum E.zfNum +{-# INLINE collectVar #-} + +-- | 'Numeric.Backprop.liftOp', but with 'Num' constraints instead of +-- 'Backprop' constraints. +liftOp + :: forall as b s. (Every Num as, Known Length as, Num b, Reifies s W) + => Op as b + -> Prod (BVar s) as + -> BVar s b +liftOp = E.liftOp E.afNums E.zfNum +{-# INLINE liftOp #-} + +-- | 'Numeric.Backprop.liftOp1', but with 'Num' constraints instead of +-- 'Backprop' constraints. +liftOp1 + :: forall a b s. (Num a, Num b, Reifies s W) + => Op '[a] b + -> BVar s a + -> BVar s b +liftOp1 = E.liftOp1 E.afNum E.zfNum +{-# INLINE liftOp1 #-} + +-- | 'Numeric.Backprop.liftOp2', but with 'Num' constraints instead of +-- 'Backprop' constraints. +liftOp2 + :: forall a b c s. (Num a, Num b, Num c, Reifies s W) + => Op '[a,b] c + -> BVar s a + -> BVar s b + -> BVar s c +liftOp2 = E.liftOp2 E.afNum E.afNum E.zfNum +{-# INLINE liftOp2 #-} + +-- | 'Numeric.Backprop.liftOp3', but with 'Num' constraints instead of +-- 'Backprop' constraints. +liftOp3 + :: forall a b c d s. (Num a, Num b, Num c, Num d, Reifies s W) + => Op '[a,b,c] d + -> BVar s a + -> BVar s b + -> BVar s c + -> BVar s d +liftOp3 = E.liftOp3 E.afNum E.afNum E.afNum E.zfNum +{-# INLINE liftOp3 #-} + +-- | 'Numeric.Backprop.isoVar', but with 'Num' constraints instead of +-- 'Backprop' constraints. +isoVar + :: (Num a, Num b, Reifies s W) + => (a -> b) + -> (b -> a) + -> BVar s a + -> BVar s b +isoVar f g = liftOp1 (opIso f g) +{-# INLINE isoVar #-} + +-- | 'Numeric.Backprop.isoVar', but with 'Num' constraints instead of +-- 'Backprop' constraints. +isoVar2 + :: (Num a, Num b, Num c, Reifies s W) + => (a -> b -> c) + -> (c -> (a, b)) + -> BVar s a + -> BVar s b + -> BVar s c +isoVar2 f g = liftOp2 (opIso2 f g) +{-# INLINE isoVar2 #-} + +-- | 'Numeric.Backprop.isoVar3', but with 'Num' constraints instead of +-- 'Backprop' constraints. +isoVar3 + :: (Num a, Num b, Num c, Num d, Reifies s W) + => (a -> b -> c -> d) + -> (d -> (a, b, c)) + -> BVar s a + -> BVar s b + -> BVar s c + -> BVar s d +isoVar3 f g = liftOp3 (opIso3 f g) +{-# INLINE isoVar3 #-} + +-- | 'Numeric.Backprop.isoVarN', but with 'Num' constraints instead of +-- 'Backprop' constraints. +isoVarN + :: (Every Num as, Known Length as, Num b, Reifies s W) + => (Tuple as -> b) + -> (b -> Tuple as) + -> Prod (BVar s) as + -> BVar s b +isoVarN f g = liftOp (opIsoN f g) +{-# INLINE isoVarN #-} + diff --git a/src/Numeric/Backprop/Op.hs b/src/Numeric/Backprop/Op.hs --- a/src/Numeric/Backprop/Op.hs +++ b/src/Numeric/Backprop/Op.hs @@ -32,6 +32,9 @@ -- of functions, 'Op' and its utility functions alone are sufficient to -- differentiate/backprop. However, this happens rarely in practice. -- +-- To use these 'Op's with the backprop library, they can be made to work +-- with 'BVar's using 'liftOp', 'liftOp1', 'liftOp2', and 'liftOp3'. +-- module Numeric.Backprop.Op ( -- * Implementation @@ -170,6 +173,9 @@ -- -- See "Numeric.Backprop.Op#prod" for a mini-tutorial on using 'Prod' and -- 'Tuple'. +-- +-- To /use/ an 'Op' with the backprop library, see 'liftOp', 'liftOp1', +-- 'liftOp2', and 'liftOp3'. newtype Op as a = -- | Construct an 'Op' by giving a function creating the -- result, and also a continuation on how to create the gradient, given diff --git a/src/Numeric/Backprop/Tuple.hs b/src/Numeric/Backprop/Tuple.hs deleted file mode 100644 --- a/src/Numeric/Backprop/Tuple.hs +++ /dev/null @@ -1,712 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeInType #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} - --- | --- Module : Numeric.Backprop.Tuple --- Copyright : (c) Justin Le 2018 --- License : BSD3 --- --- Maintainer : justin@jle.im --- Stability : experimental --- Portability : non-portable --- --- Canonical strict tuples (and unit) with 'Num' instances for usage with --- /backprop/. This is here to solve the problem of orphan instances in --- libraries and potential mismatched tuple types. --- --- If you are writing a library that needs to export 'BVar's of tuples, --- consider using the tuples in this module so that your library can have --- easy interoperability with other libraries using /backprop/. --- --- Because of API decisions, 'backprop' and 'gradBP' only work with things --- with 'Num' instances. However, this disallows default 'Prelude' tuples --- (without orphan instances from packages like --- ). --- --- Until tuples have 'Num' instances in /base/, this module is intended to --- be a workaround for situations where: --- --- This comes up often in cases where: --- --- (1) A function wants to return more than one value (@'BVar' s ('T2' --- a b)@ --- (2) You want to uncurry a 'BVar' function to use with 'backprop' and --- 'gradBP'. --- (3) You want to use the useful 'Prism's automatically generated by --- the lens library, which use tuples for multiple-constructor fields. --- --- Only 2-tuples and 3-tuples are provided. Any more and you should --- probably be using your own custom product types, with instances --- automatically generated from something like --- . --- --- Lenses into the fields are provided, but they also work with '_1', '_2', --- and '_3' from "Lens.Micro". However, note that these are incompatible --- with '_1', '_2', and '_3' from "Control.Lens". --- --- You can "construct" a @'BVar' s ('T2' a b)@ with functions like --- 'isoVar'. --- --- @since 0.1.1.0 --- - - -module Numeric.Backprop.Tuple ( - -- * Zero-tuples (unit) - T0(..) - -- * Two-tuples - , T2(..) - -- ** Conversions - -- $t2iso - , t2Tup, tupT2 - -- ** Consumption - , uncurryT2, curryT2 - -- ** Lenses - , t2_1, t2_2 - -- * Three-tuples - , T3(..) - -- ** Conversions - -- $t3iso - , t3Tup, tupT3 - -- ** Lenses - , t3_1, t3_2, t3_3 - -- ** Consumption - , uncurryT3, curryT3 - -- * N-Tuples - , T(..) - , indexT - -- ** Conversions - -- $tiso - , tOnly, onlyT, tSplit, tAppend, tProd, prodT - -- ** Lenses - , tIx, tHead, tTail, tTake, tDrop - -- ** Internal Utility - , constT, mapT, zipT - ) where - -import Control.DeepSeq -import Control.Monad.Trans.State -import Data.Bifunctor -import Data.Data -import Data.Kind -import Data.Type.Combinator -import Data.Type.Index -import Data.Type.Length -import Data.Type.Product -import GHC.Generics (Generic) -import Lens.Micro -import Lens.Micro.Internal hiding (Index) -import System.Random -import Type.Class.Known -import Type.Family.List -import qualified Data.Binary as Bi - -#if !MIN_VERSION_base(4,11,0) -import Data.Semigroup -#endif - --- | Unit ('()') with 'Num', 'Fractional', and 'Floating' instances. --- --- Be aware that the methods in its numerical instances are all non-strict: --- --- @ --- _ + _ = 'T0' --- 'negate' _ = 'T0' --- 'fromIntegral' _ = 'T0' --- @ --- --- @since 0.1.4.0 -data T0 = T0 - deriving (Show, Read, Eq, Ord, Generic, Data) - --- | Strict 2-tuple with 'Num', 'Fractional', and 'Floating' instances. --- --- @since 0.1.1.0 -data T2 a b = T2 !a !b - deriving (Show, Read, Eq, Ord, Generic, Functor, Data, Typeable) - --- | Strict 3-tuple with a 'Num', 'Fractional', and 'Floating' instances. --- --- @since 0.1.1.0 -data T3 a b c = T3 !a !b !c - deriving (Show, Read, Eq, Ord, Generic, Functor, Data, Typeable) - --- | Strict inductive N-tuple with a 'Num', 'Fractional', and 'Floating' --- instances. --- --- It is basically "yet another HList", like the one found in --- "Data.Type.Product" and many other locations on the haskell ecosystem. --- Because it's inductively defined, it has O(n) random indexing, but is --- efficient for zipping and mapping and other sequential consumption --- patterns. --- --- It is provided because of its 'Num' instance, making it useful for --- /backproup/. Will be obsolete when 'Data.Type.Product.Product' gets --- numerical instances. --- --- @since 0.1.5.0 -data T :: [Type] -> Type where - TNil :: T '[] - (:&) :: !a -> !(T as) -> T (a ': as) - --- | @since 0.1.5.1 -deriving instance ListC (Show <$> as) => Show (T as) --- | @since 0.1.5.1 -deriving instance ListC (Eq <$> as) => Eq (T as) --- | @since 0.1.5.1 -deriving instance (ListC (Eq <$> as), ListC (Ord <$> as)) => Ord (T as) --- | @since 0.1.5.1 -deriving instance Typeable (T as) - --- | @since 0.1.5.1 -deriving instance Typeable T0 --- | @since 0.1.5.1 -deriving instance Typeable (T2 a b) --- | @since 0.1.5.1 -deriving instance Typeable (T3 a b c) - -instance NFData T0 -instance (NFData a, NFData b) => NFData (T2 a b) -instance (NFData a, NFData b, NFData c) => NFData (T3 a b c) -instance ListC (NFData <$> as) => NFData (T as) where - rnf = \case - TNil -> () - x :& xs -> rnf x `seq` rnf xs - --- | @since 0.1.5.2 -instance Random T0 where - randomR _ = (T0,) - random = (T0,) - randomRs _ _ = repeat T0 - randoms _ = repeat T0 - randomIO = pure T0 - --- | @since 0.1.5.2 -instance (Random a, Random b) => Random (T2 a b) where - randomR (T2 lx ly, T2 ux uy) = runState $ - T2 <$> state (randomR (lx, ux)) - <*> state (randomR (ly, uy)) - random = runState $ - T2 <$> state random <*> state random - --- | @since 0.1.5.2 -instance (Random a, Random b, Random c) => Random (T3 a b c) where - randomR (T3 lx ly lz, T3 ux uy uz) = runState $ - T3 <$> state (randomR (lx, ux)) - <*> state (randomR (ly, uy)) - <*> state (randomR (lz, uz)) - random = runState $ - T3 <$> state random <*> state random <*> state random - - - --- TODO: optimize? - --- | @since 0.1.5.1 -instance Bi.Binary T0 --- | @since 0.1.5.1 -instance (Bi.Binary a, Bi.Binary b) => Bi.Binary (T2 a b) --- | @since 0.1.5.1 -instance (Bi.Binary a, Bi.Binary b, Bi.Binary c) => Bi.Binary (T3 a b c) - -instance Bifunctor T2 where - bimap f g (T2 x y) = T2 (f x) (g y) - -instance Bifunctor (T3 a) where - bimap f g (T3 x y z) = T3 x (f y) (g z) - --- | Convert to a Haskell tuple. --- --- Forms an isomorphism with 'tupT2'. -t2Tup :: T2 a b -> (a, b) -t2Tup (T2 x y) = (x, y) - --- | Convert from Haskell tuple. --- --- Forms an isomorphism with 't2Tup'. -tupT2 :: (a, b) -> T2 a b -tupT2 (x, y) = T2 x y - --- | Convert to a Haskell tuple. --- --- Forms an isomorphism with 'tupT3'. -t3Tup :: T3 a b c -> (a, b, c) -t3Tup (T3 x y z) = (x, y, z) - --- | Convert from Haskell tuple. --- --- Forms an isomorphism with 't3Tup'. -tupT3 :: (a, b, c) -> T3 a b c -tupT3 (x, y, z) = T3 x y z - --- | A singleton 'T' --- --- Forms an isomorphism with 'tOnly' --- --- @since 0.1.5.0 -onlyT :: a -> T '[a] -onlyT = (:& TNil) - --- | Extract a singleton 'T' --- --- Forms an isomorphism with 'onlyT' --- --- @since 0.1.5.0 -tOnly :: T '[a] -> a -tOnly (x :& _) = x - --- | Uncurry a function to take in a 'T2' of its arguments --- --- @since 0.1.2.0 -uncurryT2 :: (a -> b -> c) -> T2 a b -> c -uncurryT2 f (T2 x y) = f x y - --- | Curry a function taking a 'T2' of its arguments --- --- @since 0.1.2.0 -curryT2 :: (T2 a b -> c) -> a -> b -> c -curryT2 f x y = f (T2 x y) - --- | Uncurry a function to take in a 'T3' of its arguments --- --- @since 0.1.2.0 -uncurryT3 :: (a -> b -> c -> d) -> T3 a b c -> d -uncurryT3 f (T3 x y z) = f x y z - --- | Curry a function taking a 'T3' of its arguments --- --- @since 0.1.2.0 -curryT3 :: (T3 a b c -> d) -> a -> b -> c -> d -curryT3 f x y z = f (T3 x y z) - -instance Field1 (T2 a b) (T2 a' b) a a' where - _1 = t2_1 - -instance Field2 (T2 a b) (T2 a b') b b' where - _2 = t2_2 - -instance Field1 (T3 a b c) (T3 a' b c) a a' where - _1 = t3_1 - -instance Field2 (T3 a b c) (T3 a b' c) b b' where - _2 = t3_2 - -instance Field3 (T3 a b c) (T3 a b c') c c' where - _3 = t3_3 - -instance Field1 (T (a ': as)) (T (a ': as)) a a where - _1 = tIx IZ - -instance Field2 (T (a ': b ': as)) (T (a ': b ': as)) b b where - _2 = tIx (IS IZ) - -instance Field3 (T (a ': b ': c ': as)) (T (a ': b ': c ': as)) c c where - _3 = tIx (IS (IS IZ)) - --- | Lens into the first field of a 'T2'. Also exported as '_1' from --- "Lens.Micro". -t2_1 :: Lens (T2 a b) (T2 a' b) a a' -t2_1 f (T2 x y) = (`T2` y) <$> f x - --- | Lens into the second field of a 'T2'. Also exported as '_2' from --- "Lens.Micro". -t2_2 :: Lens (T2 a b) (T2 a b') b b' -t2_2 f (T2 x y) = T2 x <$> f y - --- | Lens into the first field of a 'T3'. Also exported as '_1' from --- "Lens.Micro". -t3_1 :: Lens (T3 a b c) (T3 a' b c) a a' -t3_1 f (T3 x y z) = (\x' -> T3 x' y z) <$> f x - --- | Lens into the second field of a 'T3'. Also exported as '_2' from --- "Lens.Micro". -t3_2 :: Lens (T3 a b c) (T3 a b' c) b b' -t3_2 f (T3 x y z) = (\y' -> T3 x y' z) <$> f y - --- | Lens into the third field of a 'T3'. Also exported as '_3' from --- "Lens.Micro". -t3_3 :: Lens (T3 a b c) (T3 a b c') c c' -t3_3 f (T3 x y z) = T3 x y <$> f z - --- | Index into a 'T'. --- --- /O(i)/ --- --- @since 0.1.5.0 -indexT :: Index as a -> T as -> a -indexT = flip (^.) . tIx - --- | Lens into a given index of a 'T'. --- --- @since 0.1.5.0 -tIx :: Index as a -> Lens' (T as) a -tIx IZ f (x :& xs) = (:& xs) <$> f x -tIx (IS i) f (x :& xs) = (x :&) <$> tIx i f xs - --- | Lens into the head of a 'T' --- --- @since 0.1.5.0 -tHead :: Lens (T (a ': as)) (T (b ': as)) a b -tHead f (x :& xs) = (:& xs) <$> f x - --- | Lens into the tail of a 'T' --- --- @since 0.1.5.0 -tTail :: Lens (T (a ': as)) (T (a ': bs)) (T as) (T bs) -tTail f (x :& xs) = (x :&) <$> f xs - --- | Append two 'T's. --- --- Forms an isomorphism with 'tSplit'. --- --- @since 0.1.5.0 -tAppend :: T as -> T bs -> T (as ++ bs) -tAppend TNil ys = ys -tAppend (x :& xs) ys = x :& tAppend xs ys -infixr 5 `tAppend` - --- | Split a 'T'. For splits known at compile-time, you can use 'known' to --- derive the 'Length' automatically. --- --- Forms an isomorphism with 'tAppend'. --- --- @since 0.1.5.0 -tSplit :: Length as -> T (as ++ bs) -> (T as, T bs) -tSplit LZ xs = (TNil, xs) -tSplit (LS l) (x :& xs) = first (x :&) . tSplit l $ xs - --- | Lens into the initial portion of a 'T'. For splits known at --- compile-time, you can use 'known' to derive the 'Length' automatically. --- --- @since 0.1.5.0 -tTake :: forall as bs cs. Length as -> Lens (T (as ++ bs)) (T (cs ++ bs)) (T as) (T cs) -tTake l f (tSplit l->(xs,ys)) = flip (tAppend @cs @bs) ys <$> f xs - --- | Lens into the ending portion of a 'T'. For splits known at --- compile-time, you can use 'known' to derive the 'Length' automatically. --- --- @since 0.1.5.0 -tDrop :: forall as bs cs. Length as -> Lens (T (as ++ bs)) (T (as ++ cs)) (T bs) (T cs) -tDrop l f (tSplit l->(xs,ys)) = tAppend xs <$> f ys - --- | Convert a 'T' to a 'Tuple'. --- --- Forms an isomorphism with 'prodT'. --- --- @since 0.1.5.0 -tProd :: T as -> Tuple as -tProd TNil = Ø -tProd (x :& xs) = x ::< tProd xs - --- | Convert a 'Tuple' to a 'T'. --- --- Forms an isomorphism with 'tProd'. --- --- @since 0.1.5.0 -prodT :: Tuple as -> T as -prodT Ø = TNil -prodT (I x :< xs) = x :& prodT xs - - -instance Num T0 where - _ + _ = T0 - _ - _ = T0 - _ * _ = T0 - negate _ = T0 - abs _ = T0 - signum _ = T0 - fromInteger _ = T0 - -instance Fractional T0 where - _ / _ = T0 - recip _ = T0 - fromRational _ = T0 - -instance Floating T0 where - pi = T0 - _ ** _ = T0 - logBase _ _ = T0 - exp _ = T0 - log _ = T0 - sqrt _ = T0 - sin _ = T0 - cos _ = T0 - asin _ = T0 - acos _ = T0 - atan _ = T0 - sinh _ = T0 - cosh _ = T0 - asinh _ = T0 - acosh _ = T0 - atanh _ = T0 - -instance Semigroup T0 where - _ <> _ = T0 - -instance Monoid T0 where - mempty = T0 - mappend = (<>) - -instance (Num a, Num b) => Num (T2 a b) where - T2 x1 y1 + T2 x2 y2 = T2 (x1 + x2) (y1 + y2) - T2 x1 y1 - T2 x2 y2 = T2 (x1 - x2) (y1 - y2) - T2 x1 y1 * T2 x2 y2 = T2 (x1 * x2) (y1 * y2) - negate (T2 x y) = T2 (negate x) (negate y) - abs (T2 x y) = T2 (abs x) (abs y) - signum (T2 x y) = T2 (signum x) (signum y) - fromInteger x = T2 (fromInteger x) (fromInteger x) - -instance (Fractional a, Fractional b) => Fractional (T2 a b) where - T2 x1 y1 / T2 x2 y2 = T2 (x1 / x2) (y1 / y2) - recip (T2 x y) = T2 (recip x) (recip y) - fromRational x = T2 (fromRational x) (fromRational x) - -instance (Floating a, Floating b) => Floating (T2 a b) where - pi = T2 pi pi - T2 x1 y1 ** T2 x2 y2 = T2 (x1 ** x2) (y1 ** y2) - logBase (T2 x1 y1) (T2 x2 y2) = T2 (logBase x1 x2) (logBase y1 y2) - exp (T2 x y) = T2 (exp x) (exp y) - log (T2 x y) = T2 (log x) (log y) - sqrt (T2 x y) = T2 (sqrt x) (sqrt y) - sin (T2 x y) = T2 (sin x) (sin y) - cos (T2 x y) = T2 (cos x) (cos y) - asin (T2 x y) = T2 (asin x) (asin y) - acos (T2 x y) = T2 (acos x) (acos y) - atan (T2 x y) = T2 (atan x) (atan y) - sinh (T2 x y) = T2 (sinh x) (sinh y) - cosh (T2 x y) = T2 (cosh x) (cosh y) - asinh (T2 x y) = T2 (asinh x) (asinh y) - acosh (T2 x y) = T2 (acosh x) (acosh y) - atanh (T2 x y) = T2 (atanh x) (atanh y) - -instance (Semigroup a, Semigroup b) => Semigroup (T2 a b) where - T2 x1 y1 <> T2 x2 y2 = T2 (x1 <> x2) (y1 <> y2) - -#if MIN_VERSION_base(4,11,0) -instance (Monoid a, Monoid b) => Monoid (T2 a b) where -#else -instance (Semigroup a, Semigroup b, Monoid a, Monoid b) => Monoid (T2 a b) where -#endif - mappend = (<>) - mempty = T2 mempty mempty - -instance (Num a, Num b, Num c) => Num (T3 a b c) where - T3 x1 y1 z1 + T3 x2 y2 z2 = T3 (x1 + x2) (y1 + y2) (z1 + z2) - T3 x1 y1 z1 - T3 x2 y2 z2 = T3 (x1 - x2) (y1 - y2) (z1 + z2) - T3 x1 y1 z1 * T3 x2 y2 z2 = T3 (x1 * x2) (y1 * y2) (z1 + z2) - negate (T3 x y z) = T3 (negate x) (negate y) (negate z) - abs (T3 x y z) = T3 (abs x) (abs y) (abs z) - signum (T3 x y z) = T3 (signum x) (signum y) (signum z) - fromInteger x = T3 (fromInteger x) (fromInteger x) (fromInteger x) - -instance (Fractional a, Fractional b, Fractional c) => Fractional (T3 a b c) where - T3 x1 y1 z1 / T3 x2 y2 z2 = T3 (x1 / x2) (y1 / y2) (z1 / z2) - recip (T3 x y z) = T3 (recip x) (recip y) (recip z) - fromRational x = T3 (fromRational x) (fromRational x) (fromRational x) - -instance (Floating a, Floating b, Floating c) => Floating (T3 a b c) where - pi = T3 pi pi pi - T3 x1 y1 z1 ** T3 x2 y2 z2 = T3 (x1 ** x2) (y1 ** y2) (z1 ** z2) - logBase (T3 x1 y1 z1) (T3 x2 y2 z2) = T3 (logBase x1 x2) (logBase y1 y2) (logBase z1 z2) - exp (T3 x y z) = T3 (exp x) (exp y) (exp z) - log (T3 x y z) = T3 (log x) (log y) (log z) - sqrt (T3 x y z) = T3 (sqrt x) (sqrt y) (sqrt z) - sin (T3 x y z) = T3 (sin x) (sin y) (sin z) - cos (T3 x y z) = T3 (cos x) (cos y) (cos z) - asin (T3 x y z) = T3 (asin x) (asin y) (asin z) - acos (T3 x y z) = T3 (acos x) (acos y) (acos z) - atan (T3 x y z) = T3 (atan x) (atan y) (atan z) - sinh (T3 x y z) = T3 (sinh x) (sinh y) (sinh z) - cosh (T3 x y z) = T3 (cosh x) (cosh y) (cosh z) - asinh (T3 x y z) = T3 (asinh x) (asinh y) (asinh z) - acosh (T3 x y z) = T3 (acosh x) (acosh y) (acosh z) - atanh (T3 x y z) = T3 (atanh x) (atanh y) (atanh z) - -instance (Semigroup a, Semigroup b, Semigroup c) => Semigroup (T3 a b c) where - T3 x1 y1 z1 <> T3 x2 y2 z2 = T3 (x1 <> x2) (y1 <> y2) (z1 <> z2) - -#if MIN_VERSION_base(4,11,0) -instance (Monoid a, Monoid b, Monoid c) => Monoid (T3 a b c) where -#else -instance (Semigroup a, Semigroup b, Semigroup c, Monoid a, Monoid b, Monoid c) => Monoid (T3 a b c) where -#endif - mappend = (<>) - mempty = T3 mempty mempty mempty - --- | Initialize a 'T' with a Rank-N value. Mostly used internally, but --- provided in case useful. --- --- Must be used with /TypeApplications/ to provide the Rank-N constraint. --- --- @since 0.1.5.0 -constT - :: forall c as. ListC (c <$> as) - => (forall a. c a => a) - -> Length as - -> T as -constT x = go - where - go :: forall bs. ListC (c <$> bs) => Length bs -> T bs - go LZ = TNil - go (LS l) = x :& go l - --- | Map over a 'T' with a Rank-N function. Mostly used internally, but --- provided in case useful. --- --- Must be used with /TypeApplications/ to provide the Rank-N constraint. --- --- @since 0.1.5.0 -mapT - :: forall c as. ListC (c <$> as) - => (forall a. c a => a -> a) - -> T as - -> T as -mapT f = go - where - go :: forall bs. ListC (c <$> bs) => T bs -> T bs - go TNil = TNil - go (x :& xs) = f x :& go xs - --- | Map over a 'T' with a Rank-N function. Mostly used internally, but --- provided in case useful. --- --- Must be used with /TypeApplications/ to provide the Rank-N constraint. --- --- @since 0.1.5.0 -zipT - :: forall c as. ListC (c <$> as) - => (forall a. c a => a -> a -> a) - -> T as - -> T as - -> T as -zipT f = go - where - go :: forall bs. ListC (c <$> bs) => T bs -> T bs -> T bs - go TNil TNil = TNil - go (x :& xs) (y :& ys) = f x y :& go xs ys - -instance (Known Length as, ListC (Num <$> as)) => Num (T as) where - (+) = zipT @Num (+) - (-) = zipT @Num (-) - (*) = zipT @Num (*) - negate = mapT @Num negate - abs = mapT @Num abs - signum = mapT @Num signum - fromInteger x = constT @Num (fromInteger x) known - -instance (Known Length as, ListC (Num <$> as), ListC (Fractional <$> as)) => Fractional (T as) where - (/) = zipT @Fractional (/) - recip = mapT @Fractional recip - fromRational x = constT @Fractional (fromRational x) known - -instance (Known Length as, ListC (Num <$> as), ListC (Fractional <$> as), ListC (Floating <$> as)) - => Floating (T as) where - pi = constT @Floating pi known - (**) = zipT @Floating (**) - logBase = zipT @Floating logBase - exp = mapT @Floating exp - log = mapT @Floating log - sqrt = mapT @Floating sqrt - sin = mapT @Floating sin - cos = mapT @Floating cos - asin = mapT @Floating asin - acos = mapT @Floating acos - atan = mapT @Floating atan - sinh = mapT @Floating sinh - cosh = mapT @Floating cosh - asinh = mapT @Floating asinh - acosh = mapT @Floating acosh - atanh = mapT @Floating atanh - -instance ListC (Semigroup <$> as) => Semigroup (T as) where - (<>) = zipT @Semigroup (<>) - -instance (Known Length as, ListC (Semigroup <$> as), ListC (Monoid <$> as)) => Monoid (T as) where - mempty = constT @Monoid mempty known - mappend = (<>) - --- | @since 0.1.5.1 -instance (Known Length as, ListC (Bi.Binary <$> as)) => Bi.Binary (T as) where - put = \case - TNil -> pure () - x :& xs -> do - Bi.put x - Bi.put xs - get = getT known - -getT :: ListC (Bi.Binary <$> as) => Length as -> Bi.Get (T as) -getT = \case - LZ -> pure TNil - LS l -> do - x <- Bi.get - xs <- getT l - pure (x :& xs) - --- | @since 0.1.5.2 -instance (Known Length as, ListC (Random <$> as)) => Random (T as) where - randomR (l, u) = runState (randomRT l u) - random = runState (randomT known) - -randomRT - :: (ListC (Random <$> as), RandomGen g) - => T as - -> T as - -> State g (T as) -randomRT = \case - TNil -> \case - TNil -> pure TNil - lx :& lxs -> \case - ux :& uxs -> (:&) <$> state (randomR (lx, ux)) <*> randomRT lxs uxs - -randomT - :: (ListC (Random <$> as), RandomGen g) - => Length as - -> State g (T as) -randomT = \case - LZ -> pure TNil - LS l -> (:&) <$> state random <*> randomT l - --- $t2iso --- --- If using /lens/, the two conversion functions can be chained with prisms --- and traversals and other optics using: --- --- @ --- 'iso' 'tupT2' 't2Tup' :: 'Iso'' (a, b) ('T2' a b) --- @ - --- $t3iso --- --- If using /lens/, the two conversion functions can be chained with prisms --- and traversals and other optics using: --- --- @ --- 'iso' 'tupT3' 't2Tup' :: 'Iso'' (a, b, c) ('T3' a b c) --- @ - --- $tiso --- --- If using /lens/, the two conversion functions can be chained with prisms --- and traversals and other optics using: --- --- @ --- 'iso' 'onlyT' 'tOnly' :: 'Iso'' a (T '[a]) --- @ diff --git a/src/Prelude/Backprop.hs b/src/Prelude/Backprop.hs --- a/src/Prelude/Backprop.hs +++ b/src/Prelude/Backprop.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -- | @@ -13,15 +14,13 @@ -- Some lifted versions of common functions found in 'Prelude' (or /base/ -- in general). -- --- Intended to work with 'Functor' / 'Foldable' / 'Traversable' instances --- with "fixed" number of items, i.e. --- vectors. --- There might be unintended consequences when using it with instances --- where the number of items is not fixed. --- -- This module is intended to be a catch-all one, so feel free to suggest -- other functions or submit a PR if you think one would make sense. -- +-- See "Prelude.Backprop.Num" for a version with 'Num' constraints instead +-- of 'Backprop' constraints, and "Prelude.Backprop.Explicit" for a version +-- allowing you to provide 'zero', 'add', and 'one' explicitly. +-- -- @since 0.1.3.0 -- @@ -47,10 +46,11 @@ import Prelude (Num(..), Fractional(..), Eq(..), Ord(..), Functor, Foldable, Traversable, Applicative, (.), ($)) import qualified Control.Applicative as P import qualified Data.Coerce as C +import qualified Data.Foldable as P import qualified Prelude as P -- | Lifted 'P.sum' -sum :: forall t a s. (Foldable t, Functor t, Num (t a), Num a, Reifies s W) +sum :: forall t a s. (Foldable t, Functor t, Backprop (t a), Backprop a, Num a, Reifies s W) => BVar s (t a) -> BVar s a sum = liftOp1 . op1 $ \xs -> @@ -59,22 +59,21 @@ ) {-# INLINE sum #-} --- | Lifted 'P.pure'. Really intended only for 'Applicative' instances --- with fixed number of items; untintended consequences might arise when --- using it with containers with variable number of items. +-- | Lifted 'P.pure'. pure - :: forall t a s. (Foldable t, Applicative t, Num (t a), Num a, Reifies s W) + :: forall t a s. (Foldable t, Applicative t, Backprop (t a), Backprop a, Reifies s W) => BVar s a -> BVar s (t a) pure = liftOp1 . op1 $ \x -> ( P.pure x - , P.sum + , P.foldl' add (zero x) + -- , P.foldl' add zero ) {-# INLINE pure #-} -- | Lifted 'P.product' product - :: forall t a s. (Foldable t, Functor t, Num (t a), Fractional a, Reifies s W) + :: forall t a s. (Foldable t, Functor t, Backprop (t a), Backprop a, Fractional a, Reifies s W) => BVar s (t a) -> BVar s a product = liftOp1 . op1 $ \xs -> @@ -86,49 +85,45 @@ -- | Lifted 'P.length'. length - :: forall t a b s. (Foldable t, Num (t a), Num b, Reifies s W) + :: forall t a b s. (Foldable t, Backprop (t a), Backprop b, Num b, Reifies s W) => BVar s (t a) -> BVar s b length = liftOp1 . op1 $ \xs -> ( P.fromIntegral (P.length xs) - , P.const 0 + , P.const (zero xs) ) {-# INLINE length #-} -- | Lifted 'P.minimum'. Undefined for situations where 'P.minimum' would -- be undefined. minimum - :: forall t a s. (Foldable t, Functor t, Num a, Ord a, Num (t a), Reifies s W) + :: forall t a s. (Foldable t, Functor t, Backprop a, Ord a, Backprop (t a), Reifies s W) => BVar s (t a) -> BVar s a minimum = liftOp1 . op1 $ \xs -> let m = P.minimum xs in ( m - , \d -> (\x -> if x == m then d else 0) P.<$> xs + , \d -> (\x -> if x == m then d else zero x) P.<$> xs ) {-# INLINE minimum #-} -- | Lifted 'P.maximum'. Undefined for situations where 'P.maximum' would -- be undefined. maximum - :: forall t a s. (Foldable t, Functor t, Num a, Ord a, Num (t a), Reifies s W) + :: forall t a s. (Foldable t, Functor t, Backprop a, Ord a, Backprop (t a), Reifies s W) => BVar s (t a) -> BVar s a maximum = liftOp1 . op1 $ \xs -> let m = P.maximum xs in ( m - , \d -> (\x -> if x == m then d else 0) P.<$> xs + , \d -> (\x -> if x == m then d else zero x) P.<$> xs ) {-# INLINE maximum #-} -- | Lifted 'P.fmap'. Lifts backpropagatable functions to be -- backpropagatable functions on 'Traversable' 'Functor's. --- --- Really intended only for 'Functor' instances with fixed number of items; --- untintended consequences might arise when using it with containers with --- variable number of items. fmap - :: forall f a b s. (Traversable f, Num a, Num b, Num (f b), Reifies s W) + :: forall f a b s. (Traversable f, Backprop a, Backprop b, Backprop (f b), Reifies s W) => (BVar s a -> BVar s b) -> BVar s (f a) -> BVar s (f b) @@ -137,7 +132,7 @@ -- | Alias for 'fmap'. (<$>) - :: forall f a b s. (Traversable f, Num a, Num b, Num (f b), Reifies s W) + :: forall f a b s. (Traversable f, Backprop a, Backprop b, Backprop (f b), Reifies s W) => (BVar s a -> BVar s b) -> BVar s (f a) -> BVar s (f b) @@ -146,12 +141,8 @@ -- | Lifted 'P.traverse'. Lifts backpropagatable functions to be -- backpropagatable functions on 'Traversable' 'Functor's. --- --- Really intended only for 'Traversable' and 'Applicative' instances with --- fixed number of items; untintended consequences might arise when using --- it with containers with variable number of items. traverse - :: forall t f a b s. (Traversable t, Applicative f, Foldable f, Num a, Num b, Num (f (t b)), Num (t b), Reifies s W) + :: forall t f a b s. (Traversable t, Applicative f, Foldable f, Backprop a, Backprop b, Backprop (f (t b)), Backprop (t b), Reifies s W) => (BVar s a -> f (BVar s b)) -> BVar s (t a) -> BVar s (f (t b)) @@ -163,15 +154,11 @@ -- | Lifted 'P.liftA2'. Lifts backpropagatable functions to be -- backpropagatable functions on 'Traversable' 'Applicative's. --- --- Really intended only for 'Traversable' and 'Applicative' instances with --- fixed number of items; untintended consequences might arise when using --- it with containers with variable number of items. liftA2 :: forall f a b c s. ( Traversable f , Applicative f - , Num a, Num b, Num c, Num (f c) + , Backprop a, Backprop b, Backprop c, Backprop (f c) , Reifies s W ) => (BVar s a -> BVar s b -> BVar s c) @@ -184,15 +171,11 @@ -- | Lifted 'P.liftA3'. Lifts backpropagatable functions to be -- backpropagatable functions on 'Traversable' 'Applicative's. --- --- Really intended only for 'Traversable' and 'Applicative' instances with --- fixed number of items; untintended consequences might arise when using --- it with containers with variable number of items. liftA3 :: forall f a b c d s. ( Traversable f , Applicative f - , Num a, Num b, Num c, Num d, Num (f d) + , Backprop a, Backprop b, Backprop c, Backprop d, Backprop (f d) , Reifies s W ) => (BVar s a -> BVar s b -> BVar s c -> BVar s d) @@ -207,8 +190,8 @@ -- | Coerce items inside a 'BVar'. coerce - :: forall a b s. (C.Coercible a b, Num a, Num b, Reifies s W) + :: forall a b s. C.Coercible a b => BVar s a -> BVar s b -coerce = liftOp1 $ opIso C.coerce C.coerce +coerce = coerceVar {-# INLINE coerce #-} diff --git a/src/Prelude/Backprop/Explicit.hs b/src/Prelude/Backprop/Explicit.hs new file mode 100644 --- /dev/null +++ b/src/Prelude/Backprop/Explicit.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Prelude.Backprop.Explicit +-- Copyright : (c) Justin Le 2018 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Provides "explicit" versions of all of the functions in +-- "Prelude.Backprop". Instead of relying on a 'Backprop' instance, allows +-- you to manually provide 'zero', 'add', and 'one' on a per-value basis. +-- +-- @since 0.2.0.0 + +module Prelude.Backprop.Explicit ( + -- * Foldable and Traversable + sum + , product + , length + , minimum + , maximum + , traverse + -- * Functor and Applicative + , fmap + , pure + , liftA2 + , liftA3 + -- * Misc + , coerce + ) where + +import Numeric.Backprop.Explicit +import Prelude (Num(..), Fractional(..), Eq(..), Ord(..), Functor, Foldable, Traversable, Applicative, (.), ($)) +import qualified Control.Applicative as P +import qualified Data.Coerce as C +import qualified Data.Foldable as P +import qualified Prelude as P + +-- | Lifted 'P.sum' +sum :: forall t a s. (Foldable t, Functor t, Num a, Reifies s W) + => AddFunc (t a) + -> ZeroFunc a + -> BVar s (t a) + -> BVar s a +sum af zf = liftOp1 af zf . op1 $ \xs -> + ( P.sum xs + , (P.<$ xs) + ) +{-# INLINE sum #-} + +-- | Lifted 'P.pure'. +pure + :: forall t a s. (Foldable t, Applicative t, Reifies s W) + => AddFunc a + -> ZeroFunc a + -> ZeroFunc (t a) + -> BVar s a + -> BVar s (t a) +pure af zfa zf = liftOp1 af zf . op1 $ \x -> + ( P.pure x + , P.foldl' (runAF af) (runZF zfa x) + ) +{-# INLINE pure #-} + +-- | Lifted 'P.product' +product + :: forall t a s. (Foldable t, Functor t, Fractional a, Reifies s W) + => AddFunc (t a) + -> ZeroFunc a + -> BVar s (t a) + -> BVar s a +product af zf = liftOp1 af zf . op1 $ \xs -> + let p = P.product xs + in ( p + , \d -> (\x -> p * d / x) P.<$> xs + ) +{-# INLINE product #-} + +-- | Lifted 'P.length'. +length + :: forall t a b s. (Foldable t, Num b, Reifies s W) + => AddFunc (t a) + -> ZeroFunc (t a) + -> ZeroFunc b + -> BVar s (t a) + -> BVar s b +length af zfa zf = liftOp1 af zf . op1 $ \xs -> + ( P.fromIntegral (P.length xs) + , P.const (runZF zfa xs) + ) +{-# INLINE length #-} + +-- | Lifted 'P.minimum'. Undefined for situations where 'P.minimum' would +-- be undefined. +minimum + :: forall t a s. (Foldable t, Functor t, Ord a, Reifies s W) + => AddFunc (t a) + -> ZeroFunc a + -> BVar s (t a) + -> BVar s a +minimum af zf = liftOp1 af zf . op1 $ \xs -> + let m = P.minimum xs + in ( m + , \d -> (\x -> if x == m then d else runZF zf x) P.<$> xs + ) +{-# INLINE minimum #-} + +-- | Lifted 'P.maximum'. Undefined for situations where 'P.maximum' would +-- be undefined. +maximum + :: forall t a s. (Foldable t, Functor t, Ord a, Reifies s W) + => AddFunc (t a) + -> ZeroFunc a + -> BVar s (t a) + -> BVar s a +maximum af zf = liftOp1 af zf . op1 $ \xs -> + let m = P.maximum xs + in ( m + , \d -> (\x -> if x == m then d else runZF zf x) P.<$> xs + ) +{-# INLINE maximum #-} + +-- | Lifted 'P.fmap'. Lifts backpropagatable functions to be +-- backpropagatable functions on 'Traversable' 'Functor's. +fmap + :: forall f a b s. (Traversable f, Reifies s W) + => AddFunc a + -> AddFunc b + -> ZeroFunc a + -> ZeroFunc b + -> ZeroFunc (f b) + -> (BVar s a -> BVar s b) + -> BVar s (f a) + -> BVar s (f b) +fmap afa afb zfa zfb zfbs f = collectVar afb zfb zfbs . P.fmap f . sequenceVar afa zfa +{-# INLINE fmap #-} + +-- | Lifted 'P.traverse'. Lifts backpropagatable functions to be +-- backpropagatable functions on 'Traversable' 'Functor's. +traverse + :: forall t f a b s. (Traversable t, Applicative f, Foldable f, Reifies s W) + => AddFunc a + -> AddFunc b + -> AddFunc (t b) + -> ZeroFunc a + -> ZeroFunc b + -> ZeroFunc (t b) + -> ZeroFunc (f (t b)) + -> (BVar s a -> f (BVar s b)) + -> BVar s (t a) + -> BVar s (f (t b)) +traverse afa afb aftb zfa zfb zftb zfftb f + = collectVar aftb zftb zfftb + . P.fmap (collectVar afb zfb zftb) + . P.traverse f + . sequenceVar afa zfa +{-# INLINE traverse #-} + +-- | Lifted 'P.liftA2'. Lifts backpropagatable functions to be +-- backpropagatable functions on 'Traversable' 'Applicative's. +liftA2 + :: forall f a b c s. + ( Traversable f + , Applicative f + , Reifies s W + ) + => AddFunc a + -> AddFunc b + -> AddFunc c + -> ZeroFunc a + -> ZeroFunc b + -> ZeroFunc c + -> ZeroFunc (f c) + -> (BVar s a -> BVar s b -> BVar s c) + -> BVar s (f a) + -> BVar s (f b) + -> BVar s (f c) +liftA2 afa afb afc zfa zfb zfc zffc f x y + = collectVar afc zfc zffc + $ f P.<$> sequenceVar afa zfa x + P.<*> sequenceVar afb zfb y +{-# INLINE liftA2 #-} + +-- | Lifted 'P.liftA3'. Lifts backpropagatable functions to be +-- backpropagatable functions on 'Traversable' 'Applicative's. +liftA3 + :: forall f a b c d s. + ( Traversable f + , Applicative f + , Reifies s W + ) + => AddFunc a + -> AddFunc b + -> AddFunc c + -> AddFunc d + -> ZeroFunc a + -> ZeroFunc b + -> ZeroFunc c + -> ZeroFunc d + -> ZeroFunc (f d) + -> (BVar s a -> BVar s b -> BVar s c -> BVar s d) + -> BVar s (f a) + -> BVar s (f b) + -> BVar s (f c) + -> BVar s (f d) +liftA3 afa afb afc afd zfa zfb zfc zfd zffd f x y z + = collectVar afd zfd zffd + $ f P.<$> sequenceVar afa zfa x + P.<*> sequenceVar afb zfb y + P.<*> sequenceVar afc zfc z +{-# INLINE liftA3 #-} + +-- | Coerce items inside a 'BVar'. +coerce + :: forall a b s. C.Coercible a b + => BVar s a + -> BVar s b +coerce = coerceVar +{-# INLINE coerce #-} + + diff --git a/src/Prelude/Backprop/Num.hs b/src/Prelude/Backprop/Num.hs new file mode 100644 --- /dev/null +++ b/src/Prelude/Backprop/Num.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Prelude.Backprop.Num +-- Copyright : (c) Justin Le 2018 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Provides the exact same API as "Prelude.Backprop", except requiring +-- 'Num' instances for all types involved instead of 'Backprop' instances. +-- +-- @since 0.2.0.0 + +module Prelude.Backprop.Num ( + -- * Foldable and Traversable + sum + , product + , length + , minimum + , maximum + , traverse + -- * Functor and Applicative + , fmap + , (<$>) + , pure + , liftA2 + , liftA3 + -- * Misc + , coerce + ) where + +import Numeric.Backprop.Num +import Prelude (Num(..), Fractional(..), Eq(..), Ord(..), Functor, Foldable, Traversable, Applicative, (.), ($)) +import qualified Control.Applicative as P +import qualified Data.Coerce as C +import qualified Data.Foldable as P +import qualified Prelude as P + +-- | Lifted 'P.sum' +sum :: forall t a s. (Foldable t, Functor t, Num (t a), Num a, Reifies s W) + => BVar s (t a) + -> BVar s a +sum = liftOp1 . op1 $ \xs -> + ( P.sum xs + , (P.<$ xs) + ) +{-# INLINE sum #-} + +-- | Lifted 'P.pure'. +pure + :: forall t a s. (Foldable t, Applicative t, Num (t a), Num a, Reifies s W) + => BVar s a + -> BVar s (t a) +pure = liftOp1 . op1 $ \x -> + ( P.pure x + , P.sum + ) +{-# INLINE pure #-} + +-- | Lifted 'P.product' +product + :: forall t a s. (Foldable t, Functor t, Num (t a), Fractional a, Reifies s W) + => BVar s (t a) + -> BVar s a +product = liftOp1 . op1 $ \xs -> + let p = P.product xs + in ( p + , \d -> (\x -> p * d / x) P.<$> xs + ) +{-# INLINE product #-} + +-- | Lifted 'P.length'. +length + :: forall t a b s. (Foldable t, Num (t a), Num b, Reifies s W) + => BVar s (t a) + -> BVar s b +length = liftOp1 . op1 $ \xs -> + ( P.fromIntegral (P.length xs) + , P.const 0 + ) +{-# INLINE length #-} + +-- | Lifted 'P.minimum'. Undefined for situations where 'P.minimum' would +-- be undefined. +minimum + :: forall t a s. (Foldable t, Functor t, Num a, Ord a, Num (t a), Reifies s W) + => BVar s (t a) + -> BVar s a +minimum = liftOp1 . op1 $ \xs -> + let m = P.minimum xs + in ( m + , \d -> (\x -> if x == m then d else 0) P.<$> xs + ) +{-# INLINE minimum #-} + +-- | Lifted 'P.maximum'. Undefined for situations where 'P.maximum' would +-- be undefined. +maximum + :: forall t a s. (Foldable t, Functor t, Num a, Ord a, Num (t a), Reifies s W) + => BVar s (t a) + -> BVar s a +maximum = liftOp1 . op1 $ \xs -> + let m = P.maximum xs + in ( m + , \d -> (\x -> if x == m then d else 0) P.<$> xs + ) +{-# INLINE maximum #-} + +-- | Lifted 'P.fmap'. Lifts backpropagatable functions to be +-- backpropagatable functions on 'Traversable' 'Functor's. +fmap + :: forall f a b s. (Traversable f, Num a, Num b, Num (f b), Reifies s W) + => (BVar s a -> BVar s b) + -> BVar s (f a) + -> BVar s (f b) +fmap f = collectVar . P.fmap f . sequenceVar +{-# INLINE fmap #-} + +-- | Alias for 'fmap'. +(<$>) + :: forall f a b s. (Traversable f, Num a, Num b, Num (f b), Reifies s W) + => (BVar s a -> BVar s b) + -> BVar s (f a) + -> BVar s (f b) +(<$>) = fmap +{-# INLINE (<$>) #-} + +-- | Lifted 'P.traverse'. Lifts backpropagatable functions to be +-- backpropagatable functions on 'Traversable' 'Functor's. +traverse + :: forall t f a b s. (Traversable t, Applicative f, Foldable f, Num a, Num b, Num (f (t b)), Num (t b), Reifies s W) + => (BVar s a -> f (BVar s b)) + -> BVar s (t a) + -> BVar s (f (t b)) +traverse f = collectVar + . P.fmap collectVar + . P.traverse f + . sequenceVar +{-# INLINE traverse #-} + +-- | Lifted 'P.liftA2'. Lifts backpropagatable functions to be +-- backpropagatable functions on 'Traversable' 'Applicative's. +liftA2 + :: forall f a b c s. + ( Traversable f + , Applicative f + , Num a, Num b, Num c, Num (f c) + , Reifies s W + ) + => (BVar s a -> BVar s b -> BVar s c) + -> BVar s (f a) + -> BVar s (f b) + -> BVar s (f c) +liftA2 f x y = collectVar $ f P.<$> sequenceVar x + P.<*> sequenceVar y +{-# INLINE liftA2 #-} + +-- | Lifted 'P.liftA3'. Lifts backpropagatable functions to be +-- backpropagatable functions on 'Traversable' 'Applicative's. +liftA3 + :: forall f a b c d s. + ( Traversable f + , Applicative f + , Num a, Num b, Num c, Num d, Num (f d) + , Reifies s W + ) + => (BVar s a -> BVar s b -> BVar s c -> BVar s d) + -> BVar s (f a) + -> BVar s (f b) + -> BVar s (f c) + -> BVar s (f d) +liftA3 f x y z = collectVar $ f P.<$> sequenceVar x + P.<*> sequenceVar y + P.<*> sequenceVar z +{-# INLINE liftA3 #-} + +-- | Coerce items inside a 'BVar'. +coerce + :: forall a b s. C.Coercible a b + => BVar s a + -> BVar s b +coerce = coerceVar +{-# INLINE coerce #-}