diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,9 +1,37 @@ -# Revision history for simple-expr +# Revision history for inf-backprop +## 0.2.0.0 -- 2025-11-13 + +### Major Breaking Changes + +* **Complete rewrite**: +The entire codebase has been rewritten from scratch with a redesigned architecture. +* Differentiation can now be applied to ordinary functions through the `RevDiff` type, +* rather than requiring special function wrappers. + +### New Features + +* **Core automatic differentiation**: + * `RevDiff` type for reverse-mode automatic differentiation + * Typeclass instances for `RevDiff` + * Support for higher-order derivatives through the derivative operator composition + +* **NumHask integration**: + * Orphan instances for NumHask typeclasses, providing polymorphic numeric operations + +* **Utility modules**: + * Sized vectors + * Tuple and triple manipulation utilities for multi-argument functions + * Vector utilities + +* **Documentation**: + * Comprehensive tutorial introducing core concepts and usage patterns + ## 0.1.0.0 -- 2023-05-12 * Basic types `Backprop`, `StartBackprop` etc. * Basic function backprrop derivative implementations. -* `Isomorphism` tyepclass and extra instances for `IsomorphicTo` typeclass from `isomorphism-class` package. +* `Isomorphism` tyepclass and extra instances for `IsomorphicTo` typeclass +from `isomorphism-class` package. * Extra instancies for `Additive` typeclass from `numhask` package. * Tutorial diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2023, Alexey Tochin +Copyright (c) 2023-2025, Alexey Tochin All rights reserved. diff --git a/doc/images/backprop.drawio.png b/doc/images/backprop.drawio.png new file mode 100644 Binary files /dev/null and b/doc/images/backprop.drawio.png differ diff --git a/doc/images/backprop.png b/doc/images/backprop.png new file mode 100644 Binary files /dev/null and b/doc/images/backprop.png differ diff --git a/doc/images/composition_derivative.png b/doc/images/composition_derivative.png Binary files a/doc/images/composition_derivative.png and b/doc/images/composition_derivative.png differ diff --git a/doc/images/composition_second_derivative.png b/doc/images/composition_second_derivative.png Binary files a/doc/images/composition_second_derivative.png and b/doc/images/composition_second_derivative.png differ diff --git a/doc/images/lens.drawio.png b/doc/images/lens.drawio.png new file mode 100644 Binary files /dev/null and b/doc/images/lens.drawio.png differ diff --git a/doc/images/lens.png b/doc/images/lens.png new file mode 100644 Binary files /dev/null and b/doc/images/lens.png differ diff --git a/doctests/Main.hs b/doctests/Main.hs --- a/doctests/Main.hs +++ b/doctests/Main.hs @@ -18,5 +18,9 @@ "-XTupleSections", "-XFlexibleContexts", "-XDeriveFunctor", + "-XBangPatterns", + "-XDataKinds", + "-XTypeApplications", + "-XTypeOperators", "src" ] diff --git a/inf-backprop.cabal b/inf-backprop.cabal --- a/inf-backprop.cabal +++ b/inf-backprop.cabal @@ -5,43 +5,72 @@ -- see: https://github.com/sol/hpack name: inf-backprop -version: 0.1.1.0 +version: 0.2.0.0 synopsis: Automatic differentiation and backpropagation. -description: ![Second order derivative of a composition](docs/doc/images/composition_second_derivative.png) +description: ![Second order derivative of a composition](docs/doc/images/composition_second_derivative.png) . - Automatic differentiation and backpropagation. - We do not attract gradient tape. - Instead, the differentiation operator is defined directly as a map between differentiable function objects. - Such functions are to be combined in arrow style using '(>>>)', '(***)', 'first', etc. + Automatic differentiation library with efficient reverse-mode backpropagation for Haskell. . - The original purpose of the package is an automatic backpropagation differentiation component - for a functional type-dependent library for deep machine learning. - See [tutorial](docs/InfBackprop-Tutorial.html) details. + This package provides a general-purpose automatic differentiation system designed for building strongly typed deep learning frameworks. It offers: + . + * Reverse-mode automatic differentiation (backpropagation) + . + * Support for higher-order derivatives + . + * Type-safe gradient computation + . + * Integration with [numhask](https://hackage.haskell.org/package/numhask) + . + * Flexible representations including profunctor and Van Laarhoven encodings + . + The library emphasizes composability and type safety, making it suitable + for research, prototyping neural networks, and implementing custom + differentiable algorithms. + . + See the [tutorial](docs/Numeric-InfBackprop-Tutorial.html) for detailed + examples and usage patterns. + . + Similar Projects: + . + * [ad](https://hackage.haskell.org/package/ad) - Comprehensive automatic differentiation library supporting forward and reverse modes + . + * [backprop](https://hackage.haskell.org/package/backprop) - Heterogeneous automatic differentiation with emphasis on ease of use category: Mathematics author: Alexey Tochin maintainer: Alexey.Tochin@gmail.com -copyright: 2023 Alexey Tochin +copyright: 2023-2025 Alexey Tochin license: BSD3 license-file: LICENSE build-type: Simple extra-source-files: CHANGELOG.md + doc/images/backprop.drawio.png + doc/images/backprop.png + doc/images/composition.png + doc/images/composition_derivative.png + doc/images/composition_second_derivative.png + doc/images/lens.drawio.png + doc/images/lens.png extra-doc-files: + doc/images/backprop.drawio.png + doc/images/backprop.png doc/images/composition.png doc/images/composition_derivative.png doc/images/composition_second_derivative.png + doc/images/lens.drawio.png + doc/images/lens.png library exposed-modules: - Control.CatBifunctor - Debug.LoggingBackprop - InfBackprop - InfBackprop.Common - InfBackprop.Tutorial - IsomorphismClass.Extra - IsomorphismClass.Isomorphism - NumHask.Extra - Prelude.InfBackprop + Data.FiniteSupportStream + Debug.DiffExpr + Numeric.InfBackprop + Numeric.InfBackprop.Core + Numeric.InfBackprop.Instances.NumHask + Numeric.InfBackprop.Tutorial + Numeric.InfBackprop.Utils.SizedVector + Numeric.InfBackprop.Utils.Tuple + Numeric.InfBackprop.Utils.Vector other-modules: Paths_inf_backprop hs-source-dirs: @@ -59,16 +88,39 @@ TupleSections FlexibleContexts DeriveFunctor + TypeOperators + TypeApplications + BangPatterns + DataKinds + PatternSynonyms ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints build-depends: - base >=4.7 && <5 - , comonad - , isomorphism-class - , monad-logger - , numhask - , simple-expr - , text - , transformers + Stream <0.5 + , base >=4.7 && <5 + , combinatorial <0.2 + , comonad <5.1 + , composition <1.1 + , data-fix <0.4 + , deepseq <1.6 + , extra <1.9 + , finite-typelits <0.3 + , fixed-vector <2.1 + , ghc-prim <0.13 + , hashable <1.6 + , indexed-list-literals <0.3 + , isomorphism-class <0.4 + , lens <5.4 + , numhask <0.14 + , optics <0.5 + , primitive <0.10 + , profunctors <5.7 + , safe <0.4 + , simple-expr <0.3 + , text <2.2 + , transformers <0.7 + , unordered-containers <0.3 + , vector <0.14 + , vector-sized <1.7 default-language: Haskell2010 test-suite doctests @@ -78,15 +130,33 @@ Paths_inf_backprop hs-source-dirs: doctests - ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -w -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.7 && <5 + Stream + , base >=4.7 && <5 + , combinatorial , comonad + , composition + , data-fix + , deepseq , doctest + , extra + , finite-typelits + , fixed-vector + , ghc-prim + , hashable + , indexed-list-literals , isomorphism-class - , monad-logger + , lens , numhask - , simple-expr + , optics + , primitive + , profunctors + , safe + , simple-expr ==0.2.* , text , transformers + , unordered-containers + , vector + , vector-sized default-language: Haskell2010 diff --git a/src/Control/CatBifunctor.hs b/src/Control/CatBifunctor.hs deleted file mode 100644 --- a/src/Control/CatBifunctor.hs +++ /dev/null @@ -1,179 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -{-# OPTIONS_HADDOCK show-extensions #-} - --- | Module : Control.CatBifunctor --- Copyright : (C) 2023 Alexey Tochin --- License : BSD3 (see the file LICENSE) --- Maintainer : Alexey Tochin --- --- Categorical Bifunctor typeclass and its trivial instances. -module Control.CatBifunctor - ( CatBiFunctor, - first, - second, - (***), - ) -where - -import Control.Applicative (liftA2) -import Control.Arrow (Kleisli (Kleisli), (>>>)) -import Control.Category (Category, id) -import Control.Comonad (Cokleisli (Cokleisli), Comonad, liftW) -import Data.Bifunctor (bimap) -import GHC.Base (Type) -import Prelude (Either (Left, Right), Monad, fmap, fst, snd, ($)) - --- | Categorical generalization for bifunctor with arrow notations. --- Notice that we do NOT require the categorical morphism '(>>>)' --- and morphism tensor product '(***)' are interchangeable. Namely, --- --- @ (f >>> g) *** (h >>> l) != (f *** h) >>> (g *** l) @ --- --- in general. --- --- ==== __Monad and type product instance examples of usage __ --- --- >>> import Prelude (Int, pure, Maybe(Just, Nothing), const, replicate, String) --- >>> import Control.Arrow (Kleisli(Kleisli), runKleisli) --- --- >>> runKleisli (Kleisli pure *** Kleisli pure) (1,2) :: [(Int, Int)] --- [(1,2)] --- --- >>> runKleisli (Kleisli pure *** Kleisli pure) (1,2) :: Maybe (Int, Int) --- Just (1,2) --- --- >>> runKleisli (Kleisli pure *** Kleisli (const Nothing)) (1,2) :: Maybe (Int, Int) --- Nothing --- --- >>> runKleisli (Kleisli (replicate 2) *** Kleisli (replicate 3)) ("a","b") :: [(String, String)] --- [("a","b"),("a","b"),("a","b"),("a","b"),("a","b"),("a","b")] --- --- ==== __Comonad and type product instance examples of usage__ --- --- >>> import Prelude (Int, pure, Maybe(..), const, replicate, String, (+), (++), Functor, Show, show, (==), (-)) --- >>> import Control.Comonad (Cokleisli(Cokleisli), runCokleisli, extract, duplicate, (=>=)) --- >>> import Control.Comonad.Store (store, seek, runStore, Store, StoreT) --- >>> import Control.Category ((>>>)) --- --- >>> runCokleisli (Cokleisli extract *** Cokleisli extract) (store (\x -> (x + 1, x + 2)) 3) :: (Int, Int) --- (4,5) --- --- >>> :{ --- up :: Int -> Cokleisli (Store Int) Int Int --- up n = Cokleisli $ \st -> let (ws, s) = runStore st in ws (s + n) --- :} --- --- >>> runCokleisli ((up 3 *** up 5) >>> (up 2 *** up 4)) (store (\x -> (x + 1, x + 2)) 0) :: (Int, Int) --- (6,11) --- --- >>> runCokleisli ((up 3 >>> up 2) *** (up 5 >>> up 4)) (store (\x -> (x + 1, x + 2)) 0) :: (Int, Int) --- (6,11) --- --- >>> :{ --- data Stream a = Cons a (Stream a) --- tail :: Stream a -> Stream a --- tail (Cons _ xs) = xs --- instance Show a => Show (Stream a) where --- show (Cons x0 (Cons x1 (Cons x2 (Cons x3 (Cons x4 _))))) = show [x0, x1, x2, x3, x4] ++ "..." --- instance Functor Stream where --- fmap f (Cons x xs) = Cons (f x) (fmap f xs) --- instance Comonad Stream where --- extract (Cons x _ ) = x --- duplicate xs = Cons xs (duplicate (tail xs)) --- :} --- --- >>> :{ --- dup :: a -> (a, a) --- dup x = (x, x) --- naturals :: Int -> Stream Int --- naturals n = Cons n (naturals (n + 1)) --- take :: Int -> Stream a -> a --- take n (Cons x xs) = if n == 0 --- then x --- else take (n - 1) xs --- :} --- --- >>> naturals 0 --- [0,1,2,3,4]... --- --- >>> take 5 (naturals 0) --- 5 --- --- >>> ((take 3) =>= (take 4)) (naturals 0) --- 7 --- --- >>> runCokleisli (Cokleisli (take 3) *** Cokleisli (take 4)) (fmap dup (naturals 0)) :: (Int, Int) --- (3,4) --- --- >>> streamN n = Cokleisli (take n) --- --- >>> runCokleisli ((streamN 3 *** streamN 5) >>> (streamN 2 *** streamN 4)) (fmap dup (naturals 0)) :: (Int, Int) --- (5,9) --- --- >>> runCokleisli ((streamN 3 >>> streamN 2) *** (streamN 5 >>> streamN 4)) (fmap dup (naturals 0)) :: (Int, Int) --- (5,9) --- --- ==== __Monad and type sum examples of usage__ --- --- >>> import Prelude (Int, pure, Maybe(Just, Nothing), const, replicate, String) --- >>> import Control.Arrow (Kleisli(Kleisli), runKleisli) --- --- >>> runKleisli (Kleisli pure *** Kleisli pure) (Left "a") :: [Either String Int] --- [Left "a"] --- --- >>> runKleisli (Kleisli pure *** Kleisli pure) (Right 1) :: Maybe (Either String Int) --- Just (Right 1) -class - Category cat => - CatBiFunctor (p :: Type -> Type -> Type) (cat :: Type -> Type -> Type) - where - -- | Categorical generalization of - -- - -- @bimap :: (a1 -> b1) -> (a2 -> b2) -> (p a1 a2 -> p c1 c2)@ - -- - -- borrowed from arrows. - (***) :: cat a1 b1 -> cat a2 b2 -> cat (p a1 a2) (p b1 b2) - - -- | Categorical generalization of - -- - -- @first :: (a -> b) -> (p a c -> p c b)@ - -- - -- borrowed from arrows. - first :: cat a b -> cat (p a c) (p b c) - first f = f *** id - - -- | Categorical generalization of - -- - -- @second :: (a -> b) -> (p a c -> p c b)@ - -- - -- borrowed from arrows. - second :: cat a b -> cat (p c a) (p c b) - second f = id *** f - -instance CatBiFunctor (,) (->) where - first f = bimap f id - second = bimap id - (***) = bimap - -instance forall m. Monad m => CatBiFunctor (,) (Kleisli m) where - (***) :: Kleisli m a1 b1 -> Kleisli m a2 b2 -> Kleisli m (a1, a2) (b1, b2) - (Kleisli (mf1 :: a1 -> m b1)) *** (Kleisli (mf2 :: a2 -> m b2)) = Kleisli mf12 - where - mf12 :: (a1, a2) -> m (b1, b2) - mf12 (x1, x2) = liftA2 (,) (mf1 x1) (mf2 x2) - -instance forall m. Comonad m => CatBiFunctor (,) (Cokleisli m) where - (***) :: Cokleisli m a1 b1 -> Cokleisli m a2 b2 -> Cokleisli m (a1, a2) (b1, b2) - (Cokleisli (mf1 :: m a1 -> b1)) *** (Cokleisli (mf2 :: m a2 -> b2)) = Cokleisli mf12 - where - mf12 :: m (a1, a2) -> (b1, b2) - mf12 x12 = (mf1 $ liftW fst x12, mf2 $ liftW snd x12) - -instance forall m. Monad m => CatBiFunctor Either (Kleisli m) where - (***) :: Kleisli m a1 b1 -> Kleisli m a2 b2 -> Kleisli m (Either a1 a2) (Either b1 b2) - (Kleisli (mf1 :: a1 -> m b1)) *** (Kleisli (mf2 :: a2 -> m b2)) = Kleisli mf12 - where - mf12 :: Either a1 a2 -> m (Either b1 b2) - mf12 x12 = case x12 of - Left x1 -> fmap Left (mf1 x1) - Right x2 -> fmap Right (mf2 x2) diff --git a/src/Data/FiniteSupportStream.hs b/src/Data/FiniteSupportStream.hs new file mode 100644 --- /dev/null +++ b/src/Data/FiniteSupportStream.hs @@ -0,0 +1,692 @@ +{-# LANGUAGE DeriveFoldable #-} + +-- | Module : Data.FiniteSupportStream +-- Copyright : (C) 2025 Alexey Tochin +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Alexey Tochin +-- +-- This module provides functionality for working with infinite streams that have +-- finite support (i.e., only finitely many non-zero elements). The streams are +-- internally represented as arrays for efficient computation. +-- +-- Any linear functional on an ordinary stream ('Data.Stream.Stream') +-- can be represented as a finite support stream. +-- Inversely, any finite support stream can be represented as +-- a linear functional on an ordinary stream. +module Data.FiniteSupportStream + ( -- * The type of finite support streams + FiniteSupportStream (toVector, MkFiniteSupportStream), + + -- * Basic functions + supportLength, + null, + head, + tail, + cons, + cons', + streamsConvolution, + finiteSupportStreamSum, + unsafeMap, + + -- * Transformations + optimize, + unsafeZip, + unsafeZipWith, + + -- * Construction + mkFiniteSupportStream', + empty, + singleton, + singleton', + replicate, + replicate', + unsafeFromList, + fromTuple, + finiteSupportStreamBasis, + + -- * Conversion + multiplicativeAction, + takeArray, + takeList, + toList, + toInfiniteList, + + -- * Fold tools + foldlWithStream, + foldlWithStream', + ) +where + +import Control.ExtendableMap (ExtandableMap, extendMap) +import Data.Eq ((==)) +import Data.Foldable (Foldable, foldl') +import qualified Data.IndexedListLiterals as DILL +import Data.List (repeat, (++)) +import qualified Data.List as DL +import Data.Maybe (fromMaybe) +import Data.Monoid (mconcat) +import qualified Data.Stream as DS +import Data.Tuple (fst) +import Data.Vector (Vector) +import qualified Data.Vector as DV +import Debug.SimpleExpr.Utils.Algebra + ( AlgebraicPower ((^^)), + Convolution ((|*|)), + MultiplicativeAction ((*|)), + ) +import GHC.Base (Bool, Eq, fmap, id, ($), (.), (<>), (>)) +import GHC.Natural (Natural) +import GHC.Real (fromIntegral) +import GHC.Show (Show, show) +import NumHask + ( Additive, + Distributive, + Multiplicative, + Subtractive, + negate, + zero, + (*), + (+), + (-), + ) +import qualified NumHask +import Numeric.InfBackprop.Instances.NumHask () +import Numeric.InfBackprop.Utils.Vector (safeHead, trimArrayTail) +import qualified Numeric.InfBackprop.Utils.Vector as DVIBP + +-- | A stream with finite support, represented as a vector. +-- Elements beyond the vector's length are implicitly zero. +-- The vector may contain trailing zeros, which can be removed using 'optimize'. +-- +-- The type parameter @a@ typically has an 'Additive' instance with a zero element. +-- +-- ==== __Examples__ +-- +-- >>> import GHC.Base (Int, Float, Bool(False, True)) +-- >>> import Data.Vector (fromList) +-- +-- >>> MkFiniteSupportStream $ fromList [0, 1, 2, 3] :: FiniteSupportStream Int +-- [0,1,2,3,0,0,0,... +-- +-- >>> MkFiniteSupportStream $ fromList [0, 1, 2, 3] :: FiniteSupportStream Float +-- [0.0,1.0,2.0,3.0,0.0,0.0,0.0,... +-- +-- >>> MkFiniteSupportStream $ fromList [False, True] :: FiniteSupportStream Bool +-- [False,True,False,False,False,... +newtype FiniteSupportStream a = MkFiniteSupportStream {toVector :: DV.Vector a} + deriving (Foldable) + +-- | Lifts a function to work with finite support streams. +-- This function applies the provided function to each element of the stream support. +-- The function is usafe because it is not checked that the argument function +-- maps zero to zero, which is expected. +-- +-- ==== __Examples__ +-- +-- >>> unsafeMap (*2) (MkFiniteSupportStream $ DV.fromList [0, 1, 2, 3]) +-- [0,2,4,6,0,0,0,... +-- +-- >>> unsafeMap (+1) (MkFiniteSupportStream $ DV.fromList [0, 1, 2, 3]) +-- [1,2,3,4,0,0,0,... +unsafeMap :: (a -> b) -> FiniteSupportStream a -> FiniteSupportStream b +unsafeMap f (MkFiniteSupportStream array') = MkFiniteSupportStream $ DV.map f array' + +-- | `Eq` instance of `FiniteSupportStream`. +instance (Eq a, Additive a) => Eq (FiniteSupportStream a) where + x == y = x' == y' + where + x' = toVector $ optimize x + y' = toVector $ optimize y + +-- | `Show` instance of `FiniteSupportStream`. +instance forall a. (Show a, Eq a, Additive a) => Show (FiniteSupportStream a) where + show bs = + let (MkFiniteSupportStream array') = optimize bs + in "[" + <> mconcat (fmap (\x -> show x <> ",") (DV.toList array' ++ [zero, zero, zero])) + <> "..." + +-- | `Additive` instance for `FiniteSupportStream`. +-- +-- ==== __Examples__ +-- +-- >>> import GHC.Base (Int) +-- +-- >>> (unsafeFromList [1, 2, 3]) + (unsafeFromList [10, 20]) :: FiniteSupportStream Int +-- [11,22,3,0,0,0,... +-- +-- >>> (unsafeFromList [1, 2, 3]) + empty +-- [1,2,3,0,0,0,... +instance (Additive a) => Additive (FiniteSupportStream a) where + zero = empty + (MkFiniteSupportStream a0) + (MkFiniteSupportStream a1) = + MkFiniteSupportStream $ + DVIBP.zipWith (+) id id a0 a1 + +-- | `Subtractive` instance for `FiniteSupportStream`. +-- +-- ==== __Examples__ +-- +-- >>> unsafeFromList [10, 20, 30] - unsafeFromList [1, 2] +-- [9,18,30,0,0,0,... +-- +-- >>> unsafeFromList [1, 2, 3] - unsafeFromList [1, 2, 3] +-- [0,0,0,... +instance (Subtractive a) => Subtractive (FiniteSupportStream a) where + negate = unsafeMap negate + (MkFiniteSupportStream a0) - (MkFiniteSupportStream a1) = + MkFiniteSupportStream $ + DVIBP.zipWith (-) id negate a0 a1 + +-- | `FiniteSupportStream` instance of `MultiplicativeAction`. +instance + (MultiplicativeAction a b) => + MultiplicativeAction a (FiniteSupportStream b) + where + (*|) = unsafeMap . (*|) + +-- | `FiniteSupportStream`instance of `AlgebraicPower` typeclass +-- for raising `FiniteSupportStream` to powers. +instance + (AlgebraicPower b a) => + AlgebraicPower b (FiniteSupportStream a) + where + x ^^ n = unsafeMap (^^ n) x + +-- | `FiniteSupportStream` instance of 'ExtandableMap' typeclass. +instance + (ExtandableMap a b c d) => + ExtandableMap a b (FiniteSupportStream c) (FiniteSupportStream d) + where + extendMap = unsafeMap . extendMap + +-- | `Convolution` instance for `FiniteSupportStream` and `Data.Stream.Stream`. +instance + (Convolution a b c, Additive c) => + Convolution (FiniteSupportStream a) (DS.Stream b) c + where + fss |*| s = foldlWithStream' (\acc x y -> acc + x |*| y) zero fss s + +-- | `Convolution` instance for `Data.Stream.Stream` and `FiniteSupportStream`. +instance + (Convolution a b c, Additive c) => + Convolution (DS.Stream a) (FiniteSupportStream b) c + where + s |*| fss = foldlWithStream' (\acc x y -> acc + y |*| x) zero fss s + +-- | `Convolution` instance for `FiniteSupportStream` and `FiniteSupportStream`. +instance + (Convolution a b c, Additive c) => + Convolution (FiniteSupportStream a) (FiniteSupportStream b) c + where + (MkFiniteSupportStream vx) |*| (MkFiniteSupportStream vy) = vx |*| vy + +-- | Creates a finite support stream from a array, removing trailing zeros in the tail. +-- This is a constructor that ensures the minimal representation. +-- +-- ==== __Examples__ +-- +-- >>> import Data.Vector (fromList) +-- +-- >>> toVector $ mkFiniteSupportStream' $ fromList [0, 1, 2, 3, 0] +-- [0,1,2,3] +mkFiniteSupportStream' :: (Eq a, Additive a) => DV.Vector a -> FiniteSupportStream a +mkFiniteSupportStream' array' = MkFiniteSupportStream $ trimArrayTail zero array' + +-- | Removes trailing elements of the finite support stream's inner array +-- if they are zeros. +-- The resulting stream is represented in its minimal form. +-- +-- ==== __Examples__ +-- +-- >>> optimize $ unsafeFromList [0, 1, 0, 3, 0, 0] +-- [0,1,0,3,0,0,0,... +optimize :: (Eq a, Additive a) => FiniteSupportStream a -> FiniteSupportStream a +optimize (MkFiniteSupportStream array') = mkFiniteSupportStream' array' + +-- | Returns the length of the stream's support (the vector length after optimization). +-- Trailing zeros are not counted in the support length. +-- +-- ==== __Examples__ +-- +-- >>> import GHC.Base (Int) +-- +-- >>> supportLength $ unsafeFromList [0, 1, 2, 3] +-- 4 +-- +-- >>> supportLength $ unsafeFromList [0, 1, 2, 3, 0, 0] +-- 6 +supportLength :: FiniteSupportStream a -> Natural +supportLength = fromIntegral . DV.length . toVector + +-- | Checks if the finite support stream is empty. +-- +-- ==== __Examples__ +-- +-- >>> null $ unsafeFromList [0, 1, 2] +-- False +-- +-- >>> null $ unsafeFromList [] +-- True +-- +-- >>> null $ unsafeFromList [0, 0, 0] +-- False +null :: FiniteSupportStream a -> Bool +null = DV.null . toVector + +-- | Converts a finite list to a 'FiniteSupportStream'. +-- The list is assumed to be finite. +-- Trailing zero elements are not checked, and the inner array is not trimmed. +-- +-- ==== __Examples__ +-- +-- >>> import GHC.Base (Int, Float, Bool(False, True)) +-- +-- >>> unsafeFromList [0, 1, 2, 3] :: FiniteSupportStream Int +-- [0,1,2,3,0,0,0,... +-- +-- >>> unsafeFromList [0, 1, 2, 3] :: FiniteSupportStream Float +-- [0.0,1.0,2.0,3.0,0.0,0.0,0.0,... +-- +-- >>> unsafeFromList [False, True] +-- [False,True,False,False,False,... +unsafeFromList :: [a] -> FiniteSupportStream a +unsafeFromList = MkFiniteSupportStream . DV.fromList + +-- | Converts a tuple into a `FiniteSupportStream`. +-- Trailing zero elements are not checked, and the inner array is not trimmed. +-- +-- === __Examples__ +-- +-- >>> import GHC.Base (Int, Float, Bool(False, True)) +-- >>> import GHC.Integer (Integer) +-- +-- >>> fromTuple (0, 1, 2, 3) :: FiniteSupportStream Integer +-- [0,1,2,3,0,0,0,... +-- +-- >>> fromTuple (0 :: Float, 1 :: Float, 2 :: Float, 3 :: Float) :: FiniteSupportStream Float +-- [0.0,1.0,2.0,3.0,0.0,0.0,0.0,... +-- +-- >>> fromTuple (False, True) :: FiniteSupportStream Bool +-- [False,True,False,False,False,... +fromTuple :: + (DILL.IndexedListLiterals input length a) => + input -> + FiniteSupportStream a +fromTuple = MkFiniteSupportStream . DV.fromList . DILL.toList + +-- | Converts a finite support stream to a finite list. +-- The resulting list includes all elements of the stream, including any trailing zeros. +-- +-- ==== __Examples__ +-- +-- >>> toList $ unsafeFromList [1, 2, 3] +-- [1,2,3] +-- +-- >>> toList $ unsafeFromList [1, 2, 3, 0] +-- [1,2,3,0] +toList :: FiniteSupportStream a -> [a] +toList = DV.toList . toVector + +-- | Converts a finite support stream to an infinite list. +-- The resulting list contains all elements of the stream, followed by an infinite sequence of zeros. +-- +-- ==== __Examples__ +-- +-- >>> import Data.List (take) +-- +-- >>> take 5 $ toInfiniteList $ unsafeFromList [1, 2, 3] +-- [1,2,3,0,0] +toInfiniteList :: (Additive a) => FiniteSupportStream a -> [a] +toInfiniteList fss = toList fss ++ repeat zero + +-- | Empty finite support stream. +-- The stream contains only zeros. +-- +-- ==== __Examples__ +-- +-- >>> import GHC.Base (Int, Bool) +-- +-- >>> empty :: FiniteSupportStream Int +-- [0,0,0,... +-- +-- >>> empty :: FiniteSupportStream Bool +-- [False,False,False,... +empty :: FiniteSupportStream a +empty = MkFiniteSupportStream DV.empty + +-- | Returns the first element of the finite support stream. +-- If the stream is empty, it returns 'zero'. +-- +-- ==== __Examples__ +-- +-- >>> import GHC.Base (Int, Bool) +-- +-- >>> head $ unsafeFromList [1, 2, 3] +-- 1 +-- +-- >>> head $ empty :: Int +-- 0 +-- +-- >>> head $ empty :: Bool +-- False +head :: (Additive a) => FiniteSupportStream a -> a +head (MkFiniteSupportStream array') = fromMaybe zero (safeHead array') + +-- | Removes the first element of the finite support stream. +-- If the stream is empty, it returns an empty stream. +-- +-- ==== __Examples__ +-- +-- >>> import GHC.Base (Int) +-- +-- >>> tail $ unsafeFromList [1, 2, 3] +-- [2,3,0,0,0,... +-- +-- >>> tail $ empty :: FiniteSupportStream Int +-- [0,0,0,... +tail :: FiniteSupportStream a -> FiniteSupportStream a +tail (MkFiniteSupportStream array') = + if DV.null array' + then empty + else MkFiniteSupportStream $ DV.tail array' + +-- | Takes the first @n@ elements of the finite support stream in the form of an array. +-- If @n@ is greater than the length of the stream, the result is padded with zeros. +-- The resulting array is not trimmed. +-- +-- ==== __Examples__ +-- +-- >>> takeArray 5 $ unsafeFromList [1, 2, 3] +-- [1,2,3,0,0] +takeArray :: (Additive a) => Natural -> FiniteSupportStream a -> Vector a +takeArray n (MkFiniteSupportStream array) = + if fromIntegral n > DV.length array + then array <> DV.replicate (fromIntegral n - DV.length array) zero + else DV.slice 0 (fromIntegral n) array + +-- | Takes the first @n@ elements of the finite support stream in the form of a list. +-- If @n@ is greater than the length of the stream, the result is padded with zeros. +-- +-- ==== __Examples__ +-- +-- >>> takeList 5 $ unsafeFromList [1, 2, 3] +-- [1,2,3,0,0] +takeList :: (Additive a) => Natural -> FiniteSupportStream a -> [a] +takeList n fss = DV.toList $ takeArray n fss + +-- | Creates a finite support stream with exactly one element. +-- The element is not checked for being zero. +-- +-- ==== __Examples__ +-- +-- >>> toVector $ singleton 42 +-- [42] +-- +-- >>> toVector $ singleton 0 +-- [0] +-- +-- >>> singleton 42 +-- [42,0,0,0,... +-- +-- >>> singleton 0 +-- [0,0,0,... +-- +-- >>> toVector $ singleton "a" +-- ["a"] +singleton :: a -> FiniteSupportStream a +singleton = MkFiniteSupportStream . DV.singleton + +-- | Creates a finite support stream with exactly one non-zero element +-- if the provided element is not zero. +-- Returns the empty stream otherwise. +-- +-- ==== __Examples__ +-- +-- >>> toVector $ singleton' 42 +-- [42] +-- +-- >>> toVector $ singleton' 0 +-- [] +-- +-- >>> singleton' 42 +-- [42,0,0,0,... +-- +-- >>> singleton' 0 +-- [0,0,0,... +singleton' :: (Additive a, Eq a) => a -> FiniteSupportStream a +singleton' x = + if x == zero + then empty + else MkFiniteSupportStream $ DV.singleton x + +-- | Creates a finite support stream with a constant value along the support. +-- It does not check whether the provided value is zero. +-- In this case, the inner array contains only zeros. +-- +-- ==== __Examples__ +-- +-- >>> replicate 3 42 +-- [42,42,42,0,0,0,... +-- +-- >>> replicate 2 0 +-- [0,0,0,... +-- +-- >>> toVector $ replicate 2 0 +-- [0,0] +replicate :: Natural -> a -> FiniteSupportStream a +replicate n x = MkFiniteSupportStream $ DV.replicate (fromIntegral n) x + +-- | Creates a finite support stream with a constant value along the support. +-- It checks whether the provided value is zero. +-- In this case, the inner array is empty. +-- +-- ==== __Examples__ +-- +-- >>> replicate' 3 42 +-- [42,42,42,0,0,0,... +-- +-- >>> replicate' 2 0 +-- [0,0,0,... +-- +-- >>> toVector $ replicate' 2 0 +-- [] +replicate' :: (Additive a, Eq a) => Natural -> a -> FiniteSupportStream a +replicate' n x = + if x == zero + then empty + else MkFiniteSupportStream $ DV.replicate (fromIntegral n) x + +-- | Adds an element to the front of the finite support stream. +-- The inner array size is increased by exactly one. +-- The head element of the array is not checked for zero elements. +-- +-- ==== __Examples__ +-- +-- >>> cons 42 (unsafeFromList [1, 2, 3]) +-- [42,1,2,3,0,0,0,... +-- +-- >>> toVector $ cons 0 empty +-- [0] +cons :: a -> FiniteSupportStream a -> FiniteSupportStream a +cons x = MkFiniteSupportStream . DV.cons x . toVector + +-- | Adds an element to the front of the finite support stream. +-- The inner array size is increased by exactly one if the head element is not zero. +-- Otherwise, if the finite support stream is empty, the output is also the empty stream. +-- +-- ==== __Examples__ +-- +-- >>> cons' 42 (unsafeFromList [1, 2, 3]) +-- [42,1,2,3,0,0,0,... +-- +-- >>> toVector $ cons' 0 empty +-- [] +cons' :: (Additive a, Eq a) => a -> FiniteSupportStream a -> FiniteSupportStream a +cons' x fss = + let (MkFiniteSupportStream array') = optimize fss + in if DV.null array' + then singleton' x + else MkFiniteSupportStream $ DV.cons x array' + +-- | Creates a finite support stream basis vector. +-- The values of the zero and unit elements are provided as arguments. +-- +-- ==== __Examples__ +-- +-- >>> finiteSupportStreamBasis 0 1 3 +-- [0,0,0,1,0,0,0,... +finiteSupportStreamBasis :: a -> a -> Natural -> FiniteSupportStream a +finiteSupportStreamBasis zero' one' n = + MkFiniteSupportStream $ DV.snoc (DV.replicate (fromIntegral n) zero') one' + +-- | Convolves a stream with a finite support stream, producing a single value. +-- The result is the sum of element-wise products. +-- +-- This operation is equivalent to applying the stream as a linear functional +-- to the finite support stream. +-- +-- ==== __Examples__ +-- +-- >>> import GHC.Base (Float, Int) +-- >>> import GHC.Real ((/)) +-- >>> import Data.Stream (iterate, take, Stream) +-- >>> import Data.HashMap.Internal.Array (fromList') +-- +-- >>> s1 = iterate (+1) 0 :: Stream Int +-- >>> Data.Stream.take 5 s1 +-- [0,1,2,3,4] +-- >>> fss1 = unsafeFromList [0, 0, 1] :: FiniteSupportStream Int +-- >>> streamsConvolution s1 fss1 +-- 2 +-- +-- >>> s2 = iterate (/2) (1 :: Float) :: Stream Float +-- >>> Data.Stream.take 5 s2 +-- [1.0,0.5,0.25,0.125,6.25e-2] +-- >>> fss2 = unsafeFromList $ Data.List.replicate 10 1 :: FiniteSupportStream Float +-- >>> streamsConvolution s2 fss2 +-- 1.9980469 +streamsConvolution :: + (Distributive a) => + DS.Stream a -> + FiniteSupportStream a -> + a +streamsConvolution stream fss = + foldl' (+) zero (DL.zipWith (*) (DS.toList stream) (toList fss)) + +-- | Applies the multiplicative action of the stream on the finite support stream. +-- The resulting stream's support length is less than or equal to +-- the stream's support length in the argument. +-- +-- ==== __Examples__ +-- +-- >>> import GHC.Base (Int) +-- +-- >>> multiplicativeAction (DS.fromList [0 ..]) (unsafeFromList [1, 1, 0, 1]) +-- [0,1,0,3,0,0,0,... +multiplicativeAction :: + (Multiplicative a) => + DS.Stream a -> + FiniteSupportStream a -> + FiniteSupportStream a +multiplicativeAction stream (MkFiniteSupportStream array) = + MkFiniteSupportStream $ + DV.fromList $ + DL.zipWith (*) (DS.toList stream) (DV.toList array) + +-- | Computes the sum of all elements the finite support stream. +-- +-- ==== __Examples__ +-- +-- >>> import GHC.Base (Int) +-- +-- >>> finiteSupportStreamSum $ unsafeFromList [1, 2, 3, 0] :: Int +-- 6 +-- +-- >>> finiteSupportStreamSum empty :: Int +-- 0 +finiteSupportStreamSum :: (Additive a) => FiniteSupportStream a -> a +finiteSupportStreamSum (MkFiniteSupportStream array') = NumHask.sum array' + +-- | Applies an element-wise binary operation to two streams. +-- +-- Parameters: +-- * @f@ - Binary operation for overlapping elements +-- * @g@ - Unary operation for excess elements in first stream +-- * @h@ - Unary operation for excess elements in second stream +-- +-- The resulting stream's length is the maximum of the input lengths, +-- with trailing elements transformed by @g@ or @h@ as appropriate. +-- +-- ==== __Examples__ +-- +-- >>> import GHC.Base (Int) +-- +-- >>> let xs = unsafeFromList [10, 20, 30] +-- >>> let ys = unsafeFromList [1,2] +-- >>> unsafeZipWith (-) id negate xs ys +-- [9,18,30,0,0,0,... +unsafeZipWith :: + -- | Binary operation for overlapping elements + (a -> b -> c) -> + -- | Operation for excess elements in first stream + (a -> c) -> + -- | Operation for excess elements in second stream + (b -> c) -> + FiniteSupportStream a -> + FiniteSupportStream b -> + FiniteSupportStream c +unsafeZipWith f g h (MkFiniteSupportStream a0) (MkFiniteSupportStream a1) = + MkFiniteSupportStream $ DVIBP.zipWith f g h a0 a1 + +-- | Lazy left fold over a foldable type @t@ and a `Data.Stream.Stream`. +-- +-- ==== __Examples__ +-- +-- >>> foldlWithStream (\acc x y -> acc + x * y) 0 (unsafeFromList [1,1,1]) (DS.iterate (+1) 0) +-- 3 +foldlWithStream :: + (Foldable t) => + (b -> a -> c -> b) -> + b -> + t a -> + DS.Stream c -> + b +foldlWithStream f acc0 ta stream0 = + fst $ foldl' step (acc0, stream0) ta + where + step (acc, DS.Cons c stream') a = + (f acc a c, stream') + +-- | Strinct left fold over a foldable type @t@ and a `Data.Stream.Stream`. +-- +-- ==== __Examples__ +-- +-- >>> foldlWithStream (\acc x y -> acc + x * y) 0 (unsafeFromList [1,1,1]) (DS.iterate (+1) 0) +-- 3 +foldlWithStream' :: + (Foldable t) => + (b -> a -> c -> b) -> + b -> + t a -> + DS.Stream c -> + b +foldlWithStream' f !acc0 ta stream0 = fst $ foldl' step (acc0, stream0) ta + where + step (!acc, DS.Cons !c stream) a = let !acc' = f acc a c in (acc', stream) + +-- | Zips two finite support streams. +-- +-- ==== __Examples__ +-- +-- >>> import GHC.Base (Int) +-- +-- >>> unsafeZip (unsafeFromList [1, 2, 3]) (unsafeFromList [4, 5]) :: FiniteSupportStream (Int, Int) +-- [(1,4),(2,5),(3,0),(0,0),(0,0),(0,0),... +unsafeZip :: + (Additive a, Additive b) => + FiniteSupportStream a -> + FiniteSupportStream b -> + FiniteSupportStream (a, b) +-- {-# ANN module "HLint: ignore Use zip" #-} +unsafeZip = unsafeZipWith (,) (,zero) (zero,) diff --git a/src/Debug/DiffExpr.hs b/src/Debug/DiffExpr.hs new file mode 100644 --- /dev/null +++ b/src/Debug/DiffExpr.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-missing-export-lists #-} + +-- | Module : Debug.SimpleExpr +-- Copyright : (C) 2023 Alexey Tochin +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Alexey Tochin +-- +-- Tools for symbolic differentiation expressions. +module Debug.DiffExpr where + +import Data.Fix (Fix (Fix)) +import Debug.SimpleExpr.Expr + ( SimpleExpr, + SimpleExprF (SymbolicFuncF), + unaryFunc, + ) +import Debug.SimpleExpr.Utils.Traced (Traced (MkTraced)) +import Debug.Trace (trace) +import NumHask + ( Additive, + Distributive, + Multiplicative, + (*), + (+), + ) +import Numeric.InfBackprop (RevDiff (MkRevDiff)) +import Prelude (Show, String, show, ($), (<>)) + +-- | Create a binary function expression. +-- +-- ==== __Examples__ +-- +-- >>> import Debug.SimpleExpr (variable) +-- +-- >>> twoArgFunc "f" (variable "x") (variable "y") +-- f(x,y) +twoArgFunc :: String -> SimpleExpr -> SimpleExpr -> SimpleExpr +twoArgFunc name x y = Fix (SymbolicFuncF name [x, y]) + +-- | This typecalss is for creating symbolic unary function expressions. +-- +-- It is used in conjunction with automatic differentiation to represent +-- functions symbolically. +-- +-- ==== __Examples__ +-- +-- >>> import Debug.SimpleExpr (variable) +-- >>> import Numeric.InfBackprop (simpleDerivative) +-- +-- >>> :{ +-- f :: SymbolicFunc a => a -> a +-- f = unarySymbolicFunc "f" +-- :} +-- +-- >>> f (variable "x") +-- f(x) +-- +-- >>> simpleDerivative f (variable "x") +-- f'(x)*1 +class SymbolicFunc a where + unarySymbolicFunc :: String -> a -> a + +-- | `SimpleExpr` instance of `SymbolicFunc` typeclass. +instance SymbolicFunc SimpleExpr where + unarySymbolicFunc = unaryFunc + +-- | `RevDiff` instance of `SymbolicFunc` typeclass. +instance + (SymbolicFunc a, Multiplicative a) => + SymbolicFunc (RevDiff t a a) + where + unarySymbolicFunc :: String -> RevDiff t a a -> RevDiff t a a + unarySymbolicFunc funcName (MkRevDiff x bp) = + MkRevDiff + (unarySymbolicFunc funcName x) + (\cy -> bp $ f' * cy) + where + f' = unarySymbolicFunc (funcName <> "'") x + +-- | This typecalss is for creating symbolic binary function expressions. +-- +-- It is used in conjunction with automatic differentiation to represent +-- functions symbolically. See `SymbolicFunc` for unary functions. +class BinarySymbolicFunc a where + binarySymbolicFunc :: String -> a -> a -> a + +-- | `SimpleExpr` instance of `BinarySymbolicFunc` typeclass. +instance BinarySymbolicFunc SimpleExpr where + binarySymbolicFunc = twoArgFunc + +-- | `RevDiff` instance of `BinarySymbolicFunc` typeclass. +instance + (BinarySymbolicFunc a, Distributive a, Additive t) => + BinarySymbolicFunc (RevDiff t a a) + where + binarySymbolicFunc funcName (MkRevDiff x bpx) (MkRevDiff y bpy) = + MkRevDiff + (binarySymbolicFunc funcName x y) + (\cz -> bpx (f'1 * cz) + bpy (f'2 * cz)) + where + f'1 = binarySymbolicFunc (funcName <> "'_1") x y + f'2 = binarySymbolicFunc (funcName <> "'_2") x y + +-- | A traced version of `SimpleExpr` for debugging purposes. +type TracedSimpleExpr = Traced SimpleExpr + +-- | A type alias for `Traced` version of `SimpleExpr`. +type TSE = TracedSimpleExpr + +-- | `Traced` instance of `SymbolicFunc` typeclass. +instance + (SymbolicFunc a, Show a) => + SymbolicFunc (Traced a) + where + unarySymbolicFunc name (MkTraced x) = + trace (" <<< TRACING: Calculating " <> name <> " of " <> show x <> " >>>") $ + MkTraced $ + unarySymbolicFunc name x + +-- | `Traced` instance of `BinarySymbolicFunc` typeclass. +instance + (BinarySymbolicFunc a, Show a) => + BinarySymbolicFunc (Traced a) + where + binarySymbolicFunc name (MkTraced x) (MkTraced y) = + trace (" <<< TRACING: Calculating " <> name <> " of " <> show x <> " and " <> show y <> " >>>") $ + MkTraced $ + binarySymbolicFunc name x y diff --git a/src/Debug/LoggingBackprop.hs b/src/Debug/LoggingBackprop.hs deleted file mode 100644 --- a/src/Debug/LoggingBackprop.hs +++ /dev/null @@ -1,368 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS_HADDOCK show-extensions #-} - --- | Module : Debug.LoggingBackprop --- Copyright : (C) 2023 Alexey Tochin --- License : BSD3 (see the file LICENSE) --- Maintainer : Alexey Tochin --- --- Basics for simple expressions equipped with Monadic behaviour. --- In particular, basic functions with logging for debug and illustration purposes. --- See [this tutorial section](InfBackprop.Tutorial#differentiation_monadic_types) for details. -module Debug.LoggingBackprop - ( -- * Generic logging functions - unitConst, - initUnaryFunc, - initBinaryFunc, - pureKleisli, - backpropExpr, - loggingBackpropExpr, - - -- * Logging functions examples - const, - linear, - negate, - (+), - (*), - pow, - exp, - sin, - cos, - ) -where - -import Control.Arrow (Kleisli (Kleisli)) -import Control.CatBifunctor (first, second, (***)) -import Control.Category ((.), (>>>)) -import Control.Monad.Logger (MonadLogger, logInfoN) -import Data.Text (pack) -import Debug.SimpleExpr.Expr (SimpleExpr, unaryFunc) -import InfBackprop.Common (Backprop (MkBackprop), BackpropFunc) -import IsomorphismClass.Isomorphism (iso) -import NumHask (Additive, Distributive, Divisive, ExpField, Multiplicative, Subtractive, TrigField, fromInteger, zero) -import qualified NumHask as NH -import qualified NumHask.Prelude as NHP -import qualified Prelude.InfBackprop -import Prelude (Monad, Show, String, pure, return, show, ($), (<>)) -import qualified Prelude as P - --- | Logging constant function. --- --- ==== __Examples of usage__ --- --- >>> import Control.Arrow (runKleisli) --- >>> import Control.Monad.Logger (runStdoutLoggingT) --- --- >>> runStdoutLoggingT $ runKleisli (unitConst 42) () --- [Info] Initializing 42 --- 42 -unitConst :: (Show a, MonadLogger m) => a -> Kleisli m () a -unitConst a = Kleisli $ \() -> do - logInfoN $ "Initializing " <> pack (show a) - pure a - --- | Logging single argument function. --- --- ==== __Examples of usage__ --- --- >>> import qualified Prelude as P --- >>> import Control.Arrow (runKleisli) --- >>> import Control.Monad.Logger (runStdoutLoggingT) --- --- >>> plusTwo = initUnaryFunc "+2" (P.+2) --- >>> runStdoutLoggingT $ runKleisli plusTwo 3 --- [Info] Calculating +2 of 3 => 5 --- 5 -initUnaryFunc :: (Show a, Show b, MonadLogger m) => String -> (a -> b) -> Kleisli m a b -initUnaryFunc msg f = Kleisli $ \a -> do - let b = f a - logInfoN $ "Calculating " <> pack msg <> " of " <> pack (show a) <> " => " <> pack (show b) - pure b - --- | Logging two argument (binary) function. --- --- ==== __Examples of usage__ --- --- >>> import qualified Prelude as P --- >>> import Control.Arrow (runKleisli) --- >>> import Control.Monad.Logger (runStdoutLoggingT) --- --- >>> loggingProduct = initBinaryFunc "product" (P.*) --- >>> runStdoutLoggingT $ runKleisli loggingProduct (6, 7) --- [Info] Calculating product of 6 and 7 => 42 --- 42 -initBinaryFunc :: (Show a, Show b, Show c, MonadLogger m) => String -> (a -> b -> c) -> Kleisli m (a, b) c -initBinaryFunc msg f = Kleisli $ \(a, b) -> do - let c = f a b - logInfoN $ - "Calculating " - <> pack msg - <> " of " - <> pack (show a) - <> " and " - <> pack (show b) - <> " => " - <> pack (show c) - return c - --- | Returns pure Kleisli morphism given a map. --- --- ==== __Examples of usage__ --- --- >>> import Control.Arrow (runKleisli) --- >>> import Control.Monad.Logger (runStdoutLoggingT) --- --- >>> loggingDup = pureKleisli (\x -> (x, x)) --- >>> runStdoutLoggingT $ runKleisli loggingDup 42 --- (42,42) -pureKleisli :: Monad m => (a -> b) -> Kleisli m a b -pureKleisli f = Kleisli $ pure . f - --- Differentiable functions. - --- | Returns symbolically differentiable Simple Expression. --- --- ==== __Examples of usage__ --- --- >>> import Control.Arrow (runKleisli) --- >>> import Control.Monad.Logger (runStdoutLoggingT) --- >>> import Debug.SimpleExpr.Expr (variable) --- >>> import InfBackprop (call, derivative, backpropExpr) --- --- >>> x = variable "x" --- >>> f = backpropExpr "f" --- >>> call f x --- f(x) --- --- >>> derivative f x --- 1·f'(x) -backpropExpr :: String -> BackpropFunc SimpleExpr SimpleExpr -backpropExpr funcName = MkBackprop call_ forward_ backward_ - where - call_ = unaryFunc funcName - forward_ = Prelude.InfBackprop.dup >>> first (backpropExpr funcName :: BackpropFunc SimpleExpr SimpleExpr) - backward_ = second (backpropExpr (funcName <> "'")) >>> (Prelude.InfBackprop.*) - --- | Returns symbolically differentiable logging symbolic function. --- --- ==== __Examples of usage__ --- --- >>> import Control.Arrow (runKleisli) --- >>> import Control.Monad.Logger (runStdoutLoggingT) --- >>> import Debug.SimpleExpr.Expr (variable) --- >>> import InfBackprop (call, derivative) --- --- >>> x = variable "x" --- >>> f = loggingBackpropExpr "f" --- >>> runStdoutLoggingT $ runKleisli (call f) x --- [Info] Calculating f of x => f(x) --- f(x) --- --- >>> runStdoutLoggingT $ runKleisli (derivative f) x --- [Info] Calculating f of x => f(x) --- [Info] Calculating f' of x => f'(x) --- [Info] Calculating multiplication of 1 and f'(x) => 1·f'(x) --- 1·f'(x) -loggingBackpropExpr :: forall m. (MonadLogger m) => String -> Backprop (Kleisli m) SimpleExpr SimpleExpr -loggingBackpropExpr funcName = MkBackprop call' forward' backward' - where - call' :: Kleisli m SimpleExpr SimpleExpr - call' = initUnaryFunc funcName (unaryFunc funcName) - - forward' :: Backprop (Kleisli m) SimpleExpr (SimpleExpr, SimpleExpr) - forward' = dup >>> first (loggingBackpropExpr funcName :: Backprop (Kleisli m) SimpleExpr SimpleExpr) - - backward' :: Backprop (Kleisli m) (SimpleExpr, SimpleExpr) SimpleExpr - backward' = second (loggingBackpropExpr (funcName <> "'")) >>> (*) - --- | Differentiable logging constant function. --- --- ==== __Examples of usage__ --- --- >>> import Control.Arrow (runKleisli) --- >>> import Control.Monad.Logger (runStdoutLoggingT) --- >>> import Debug.SimpleExpr.Expr (variable) --- >>> import InfBackprop (call, derivative) --- --- >>> runStdoutLoggingT $ runKleisli (call (const 42)) () --- 42 -const :: - forall c x m. - (Additive c, Additive x, Show c, Show x, Monad m) => - c -> - Backprop (Kleisli m) x c -const c = MkBackprop call' forward' backward' - where - call' :: Kleisli m x c - call' = Kleisli $ P.const (pure c) - - forward' :: Backprop (Kleisli m) x (c, ()) - forward' = const c >>> (iso :: Backprop (Kleisli m) c (c, ())) - - backward' :: Backprop (Kleisli m) (c, ()) x - backward' = const zero - --- | Differentiable dup logging function. -dup :: forall x m. (Show x, Additive x, MonadLogger m) => Backprop (Kleisli m) x (x, x) -dup = MkBackprop call' forward' backward' - where - call' :: Kleisli m x (x, x) - call' = pureKleisli (\x -> (x, x)) - - forward' :: Backprop (Kleisli m) x ((x, x), ()) - forward' = dup >>> (iso :: Backprop (Kleisli m) y (y, ())) - - backward' :: Backprop (Kleisli m) ((x, x), ()) x - backward' = (iso :: Backprop (Kleisli m) (y, ()) y) >>> (+) - --- | Differentiable logging sum function. --- --- ==== __Examples of usage__ --- --- >>> import Control.Arrow (runKleisli) --- >>> import Control.Monad.Logger (runStdoutLoggingT) --- >>> import InfBackprop (call) --- --- >>> runStdoutLoggingT $ runKleisli (call (+)) (2, 2) --- [Info] Calculating sum of 2 and 2 => 4 --- 4 -(+) :: forall x m. (Show x, Additive x, MonadLogger m) => Backprop (Kleisli m) (x, x) x -(+) = MkBackprop call' forward' backward' - where - call' :: Kleisli m (x, x) x - call' = initBinaryFunc "sum" (NH.+) - - forward' :: Backprop (Kleisli m) (x, x) (x, ()) - forward' = (+) >>> (iso :: Backprop (Kleisli m) y (y, ())) - - backward' :: Backprop (Kleisli m) (x, ()) (x, x) - backward' = (iso :: Backprop (Kleisli m) (x, ()) x) >>> dup - --- | Differentiable logging multiplication function. --- --- ==== __Examples of usage__ --- --- >>> import Control.Arrow (runKleisli) --- >>> import Control.Monad.Logger (runStdoutLoggingT) --- >>> import InfBackprop (call) --- --- >>> runStdoutLoggingT $ runKleisli (call (*)) (6, 7) --- [Info] Calculating multiplication of 6 and 7 => 42 --- 42 -(*) :: - forall x m. - (Show x, Additive x, Multiplicative x, MonadLogger m) => - Backprop (Kleisli m) (x, x) x -(*) = MkBackprop call' forward' backward' - where - call' :: Kleisli m (x, x) x - call' = initBinaryFunc "multiplication" (NH.*) - - forward' :: Backprop (Kleisli m) (x, x) (x, (x, x)) - forward' = dup >>> first (*) - - backward' :: Backprop (Kleisli m) (x, (x, x)) (x, x) - backward' = - first dup - >>> (iso :: Backprop (Kleisli m) ((dy, dy), (x1, x2)) ((dy, x1), (dy, x2))) - >>> (iso :: Backprop (Kleisli m) (a, b) (b, a)) - >>> ((*) *** (*)) - --- | Differentiable logging linear function. -linear :: - forall x m. - (Show x, NH.Distributive x, MonadLogger m) => - x -> - Backprop (Kleisli m) x x -linear c = MkBackprop call' forward' backward' - where - call' :: Kleisli m x x - call' = initUnaryFunc ("linear " <> show c) (c NH.*) - - forward' :: Backprop (Kleisli m) x (x, ()) - forward' = linear c >>> (iso :: Backprop (Kleisli m) y (y, ())) - - backward' :: Backprop (Kleisli m) (x, ()) x - backward' = (iso :: Backprop (Kleisli m) (x, ()) x) >>> linear c - --- | Differentiable logging negate function. -negate :: - forall x m. - (Show x, Subtractive x, MonadLogger m) => - Backprop (Kleisli m) x x -negate = MkBackprop call' forward' backward' - where - call' :: Kleisli m x x - call' = initUnaryFunc "negate" NH.negate - - forward' :: Backprop (Kleisli m) x (x, ()) - forward' = negate >>> (iso :: Backprop (Kleisli m) y (y, ())) - - backward' :: Backprop (Kleisli m) (x, ()) x - backward' = (iso :: Backprop (Kleisli m) (y, ()) y) >>> negate - --- | Differentiable logging exponent function. -exp :: - forall x m. - (ExpField x, Show x, MonadLogger m) => - Backprop (Kleisli m) x x -exp = MkBackprop call' forward' backward' - where - call' :: Kleisli m x x - call' = initUnaryFunc "exp" NH.exp - - forward' :: Backprop (Kleisli m) x (x, x) - forward' = (exp :: Backprop (Kleisli m) x x) >>> dup - - backward' :: Backprop (Kleisli m) (x, x) x - backward' = (*) - --- | Differentiable logging power function. -pow :: - forall x m. - (Show x, Divisive x, Distributive x, Subtractive x, NH.FromIntegral x NHP.Integer, MonadLogger m) => - NHP.Integer -> - Backprop (Kleisli m) x x -pow n = MkBackprop call' forward' backward' - where - call' :: Kleisli m x x - call' = initUnaryFunc ("pow " <> show n) (NH.^ fromInteger n) - - forward' :: Backprop (Kleisli m) x (x, x) - forward' = dup >>> first (pow n :: Backprop (Kleisli m) x x) - - backward' :: Backprop (Kleisli m) (x, x) x - backward' = second (pow (n P.- 1) >>> linear (NH.fromIntegral n)) >>> (*) - --- | Differentiable logging sin function. -sin :: - forall x m. - (Show x, TrigField x, MonadLogger m) => - Backprop (Kleisli m) x x -sin = MkBackprop call' forward' backward' - where - call' :: Kleisli m x x - call' = initUnaryFunc "sin" NH.sin - - forward' :: Backprop (Kleisli m) x (x, x) - forward' = dup >>> first (sin :: Backprop (Kleisli m) x x) - - backward' :: Backprop (Kleisli m) (x, x) x - backward' = second (cos :: Backprop (Kleisli m) x x) >>> (*) - --- | Differentiable logging cos function. -cos :: - forall x m. - (Show x, TrigField x, MonadLogger m) => - Backprop (Kleisli m) x x -cos = MkBackprop call' forward' backward' - where - call' :: Kleisli m x x - call' = initUnaryFunc "cos" NH.cos - - forward' :: Backprop (Kleisli m) x (x, x) - forward' = dup >>> first (sin :: Backprop (Kleisli m) x x) - - backward' :: Backprop (Kleisli m) (x, x) x - backward' = second (sin >>> negate :: Backprop (Kleisli m) x x) >>> (*) diff --git a/src/InfBackprop.hs b/src/InfBackprop.hs deleted file mode 100644 --- a/src/InfBackprop.hs +++ /dev/null @@ -1,125 +0,0 @@ -{-# OPTIONS_HADDOCK show-extensions #-} - --- | Module : InfBackprop --- Copyright : (C) 2023 Alexey Tochin --- License : BSD3 (see the file LICENSE) --- Maintainer : Alexey Tochin --- --- Automatic differentiation and backpropagation. --- See 'InfBackprop.Tutorial' for details. -module InfBackprop - ( -- * Base - - -- ** Types - Backprop (MkBackprop), - BackpropFunc, - -- Manipulations - call, - forward, - backward, - derivative, - derivativeN, - - -- ** Categorical Bifunctor - (***), - first, - second, - - -- * Differentiable functions - - -- ** Elementary functions - const, - linear, - (+), - (-), - negate, - (*), - (/), - - -- ** Tuple manipulations - dup, - setFirst, - setSecond, - forget, - forgetFirst, - forgetSecond, - - -- ** Exponential family functions - log, - logBase, - exp, - (**), - pow, - - -- ** Trigonometric functions - cos, - sin, - tan, - asin, - acos, - atan, - atan2, - sinh, - cosh, - tanh, - asinh, - acosh, - atanh, - - -- * Monadic differentiable functions - pureBackprop, - backpropExpr, - loggingBackpropExpr, - - -- * Tools - pureKleisli, - simpleDifferentiable, - ) -where - -import Control.CatBifunctor (first, second, (***)) -import Debug.LoggingBackprop (backpropExpr, loggingBackpropExpr, pureKleisli) -import InfBackprop.Common - ( Backprop (MkBackprop), - BackpropFunc, - backward, - call, - const, - derivative, - derivativeN, - forward, - pureBackprop, - ) -import Prelude.InfBackprop - ( acos, - acosh, - asin, - asinh, - atan, - atan2, - atanh, - cos, - cosh, - dup, - exp, - forget, - forgetFirst, - forgetSecond, - linear, - log, - logBase, - negate, - pow, - setFirst, - setSecond, - simpleDifferentiable, - sin, - sinh, - tan, - tanh, - (*), - (**), - (+), - (-), - (/), - ) diff --git a/src/InfBackprop/Common.hs b/src/InfBackprop/Common.hs deleted file mode 100644 --- a/src/InfBackprop/Common.hs +++ /dev/null @@ -1,340 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_HADDOCK show-extensions #-} - --- | Module : InfBackprop.Common --- Copyright : (C) 2023 Alexey Tochin --- License : BSD3 (see the file LICENSE) --- Maintainer : Alexey Tochin --- --- Provides base types and methods for backpropagation category morphism. -module InfBackprop.Common - ( -- * Basic - Backprop (MkBackprop), - call, - forward, - backward, - StartBackprop, - startBackprop, - forwardBackward, - numba, - numbaN, - derivative, - derivativeN, - - -- * Differentiable functions - BackpropFunc, - const, - - -- * Differentiable monadic functions - pureBackprop, - ) -where - -import Control.Arrow (Kleisli (Kleisli)) -import Control.CatBifunctor (CatBiFunctor, first, (***)) -import Control.Category (Category, id, (.), (>>>)) -import GHC.Natural (Natural) -import IsomorphismClass (IsomorphicTo) -import IsomorphismClass.Extra () -import IsomorphismClass.Isomorphism (Isomorphism, iso) -import NumHask (one, zero) -import NumHask.Algebra.Additive (Additive) -import NumHask.Algebra.Ring (Distributive) -import NumHask.Extra () -import Prelude (Monad, flip, fromIntegral, iterate, pure, (!!), ($)) -import qualified Prelude as P - --- | Backprop morphism. --- #backprop# --- Base type for an infinitely differentiable object. --- It depends on categorical type @cat@ that is mostly common @(->)@, --- see 'BackpropFunc' which by it's definition is equivalent to --- --- @ --- data BackpropFunc input output = forall cache. MkBackpropFunc { --- call :: input -> output, --- forward :: BackpropFunc input (output, cache), --- backward :: BackpropFunc (output, cache) input --- } --- @ --- --- The diagram below illustrates the how it works for the first derivative. --- Consider the role of function @f@ in the derivative of the composition @g(f(h(...)))@. --- #backprop_func# --- --- @ --- h · f · g --- · · --- · forward · --- · --- input >-----+-----> output >--- · --- · V · --- ... · | · ... --- · | cache · --- · | · --- · V · --- · --< dInput <-----+-----< dOutput <-- · --- · backward · --- @ --- --- Notice that 'forward' and 'backward' are of type 'BackpropFunc' but not @(->)@. --- This is needed for further differentiation. --- However for the first derivative this difference can be ignored. --- --- The return type of 'forward' contains additional term @cache@. --- It is needed to save and transfer data calculated in the forward step to the backward step for reuse. --- See an example in --- --- [Differentiation with logging](#differentiation_with_logging) --- section . --- --- == __Remark__ --- Mathematically speaking we have to distinguish the types for 'forward' and for 'backward' methods because the second --- acts on the cotangent bundle. --- However, for simplicity and due to technical reasons we identify the types @input@ and @dInput@ --- as well as @output@ and @dOutput@ which is enough for our purposes because these types are usually real numbers --- or arrays of real numbers. -data Backprop cat input output = forall cache. - MkBackprop - { -- | Simple internal category object extraction. - call :: cat input output, - -- | Returns forward category. - -- In the case @cat = (->)@, the method coincides with 'Backprop'@ cat input output@ itself - -- but the output contains an additional data term @cache@ with some calculation result that can be reused on in - -- 'backward'. - forward :: Backprop cat input (output, cache), - -- | Returns backward category. In the case @cat = (->)@, the method takes the additional data term @cache@ that is - -- calculated in 'forward'. - backward :: Backprop cat (output, cache) input - } - -composition' :: - forall cat x y z. - (Isomorphism cat, CatBiFunctor (,) cat) => - Backprop cat x y -> - Backprop cat y z -> - Backprop cat x z -composition' - (MkBackprop callF (forwardF :: Backprop cat x (y, hF)) (backwardF :: Backprop cat (y, hF) x)) - (MkBackprop callG (forwardG :: Backprop cat y (z, hG)) (backwardG :: Backprop cat (z, hG) y)) = - MkBackprop call_ forward_ backward_ - where - call_ :: cat x z - call_ = callF >>> callG - - forward_ :: Backprop cat x (z, (hG, hF)) - forward_ = - (forwardF `composition'` first forwardG) `composition'` (iso :: Backprop cat ((z, hG), hF) (z, (hG, hF))) - - backward_ :: Backprop cat (z, (hG, hF)) x - backward_ = - (iso :: Backprop cat (z, (hG, hF)) ((z, hG), hF)) `composition'` first backwardG `composition'` backwardF - -iso' :: - forall cat x y. - (IsomorphicTo x y, Isomorphism cat, CatBiFunctor (,) cat) => - Backprop cat x y -iso' = MkBackprop call_ (forward_ :: Backprop cat x (y, ())) (backward_ :: Backprop cat (y, ()) x) - where - call_ :: cat x y - call_ = iso - - forward_ :: Backprop cat x (y, ()) - forward_ = (iso :: Backprop cat x y) `composition'` (iso :: Backprop cat y (y, ())) - - backward_ :: Backprop cat (y, ()) x - backward_ = (iso :: Backprop cat (y, ()) y) `composition'` (iso :: Backprop cat y x) - -instance - (Isomorphism cat, CatBiFunctor (,) cat) => - Category (Backprop cat) - where - id = iso' - (.) = flip composition' - -instance - (Isomorphism cat, CatBiFunctor (,) cat) => - Isomorphism (Backprop cat) - where - iso = iso' - -instance - (Isomorphism cat, CatBiFunctor (,) cat) => - CatBiFunctor (,) (Backprop cat) - where - (***) - (MkBackprop call1 (forward1 :: Backprop cat x1 (y1, h1)) (backward1 :: Backprop cat (y1, h1) x1)) - (MkBackprop call2 (forward2 :: Backprop cat x2 (y2, h2)) (backward2 :: Backprop cat (y2, h2) x2)) = - MkBackprop call12 forward12 backward12 - where - call12 :: cat (x1, x2) (y1, y2) - call12 = call1 *** call2 - - forward12 :: Backprop cat (x1, x2) ((y1, y2), (h1, h2)) - forward12 = forward1 *** forward2 >>> (iso :: Backprop cat ((y1, h1), (y2, h2)) ((y1, y2), (h1, h2))) - - backward12 :: Backprop cat ((y1, y2), (h1, h2)) (x1, x2) - backward12 = (iso :: Backprop cat ((y1, y2), (h1, h2)) ((y1, h1), (y2, h2))) >>> backward1 *** backward2 - --- | Implementation of the process illustrated in the --- [diagram](#backprop_func). --- The first argument is a backprop morphism @y -> dy@ --- The second argument is a backprop morphism @x -> y@ --- The output is the backprop @x -> dx@ build according the --- [diagram](#backprop_func) -forwardBackward :: - (Isomorphism cat, CatBiFunctor (,) cat) => - -- | backprop morphism between @y@ and @dy@ - -- that is inferred after the forward step for @f@ and before the backward step for @f@ - Backprop cat y y -> - -- | some backprop morphism @f@ between @x@ and @y@ - Backprop cat x y -> - -- | the output backprop morphism from @x@ to @dx@ that is the composition. - Backprop cat x x -forwardBackward dy (MkBackprop _ forward_ backward_) = forward_ >>> first dy >>> backward_ - --- | Interface for categories @cat@ and value types @x@ that support starting the backpropagation. --- For example for @(->)@ and @Float@ we are able to start the backpropagation like --- @f(g(x))@ -> @1 · f'(g(x)) · ...@ --- because @f@ is a @Float@ valued (scalar) function. --- Calculating Jacobians is not currently implemented. -class Distributive x => StartBackprop cat x where - -- | Morphism that connects forward and backward chain. - -- Usually it is just @1@ that is supposed to be multiplied on the derivative of the top function. - startBackprop :: Backprop cat x x - --- | Backpropagation derivative in terms of backprop morphisms. -numba :: - (Isomorphism cat, CatBiFunctor (,) cat, StartBackprop cat y) => - Backprop cat x y -> - Backprop cat x x -numba = forwardBackward startBackprop - --- | Backpropagation ns derivative in terms of backprop morphisms. -numbaN :: - (Isomorphism cat, CatBiFunctor (,) cat, StartBackprop cat x) => - Natural -> - Backprop cat x x -> - Backprop cat x x -numbaN n f = iterate numba f !! fromIntegral n - --- | Backpropagation derivative as categorical object. --- If @cat@ is @(->)@ the output is simply a function. --- --- ==== __Examples of usage__ --- --- >>> import InfBackprop (sin) --- >>> import Prelude (Float) --- >>> derivative sin (0 :: Float) --- 1.0 -derivative :: - (Isomorphism cat, CatBiFunctor (,) cat, StartBackprop cat y) => - Backprop cat x y -> - cat x x -derivative = call . numba - --- | Backpropagation derivative of order n as categorical object. --- If @cat@ is @(->)@ the output is simply a function. --- --- ==== __Examples of usage__ --- --- >>> import InfBackprop (pow, const) --- >>> import Prelude (Float, fmap) --- >>> myFunc = (pow 2) :: Backprop (->) Float Float --- --- >>> fmap (derivativeN 0 myFunc) [-3, -2, -1, 0, 1, 2, 3] --- [9.0,4.0,1.0,0.0,1.0,4.0,9.0] --- --- >>> fmap (derivativeN 1 myFunc) [-3, -2, -1, 0, 1, 2, 3] --- [-6.0,-4.0,-2.0,0.0,2.0,4.0,6.0] --- --- >>> fmap (derivativeN 2 myFunc) [-3, -2, -1, 0, 1, 2, 3] --- [2.0,2.0,2.0,2.0,2.0,2.0,2.0] --- --- >>> fmap (derivativeN 3 myFunc) [-3, -2, -1, 0, 1, 2, 3] --- [0.0,0.0,0.0,0.0,0.0,0.0,0.0] -derivativeN :: - (Isomorphism cat, CatBiFunctor (,) cat, StartBackprop cat x) => - Natural -> - Backprop cat x x -> - cat x x -derivativeN n = call . numbaN n - --- | Infinitely differentiable function. --- The definition of the type synonym is equivalent to --- --- @ --- data BackpropFunc input output = forall cache. MkBackpropFunc { --- call :: input -> output, --- forward :: BackpropFunc input (output, cache), --- backward :: BackpropFunc (output, cache) input --- } --- @ --- --- See 'Backprop' for details. --- --- ==== __Examples of usage__ --- --- >>> import Prelude (fmap, Float) --- >>> import InfBackprop (pow, call, derivative) --- >>> myFunc = pow 2 :: BackpropFunc Float Float --- >>> f = call myFunc :: Float -> Float --- >>> fmap f [-3, -2, -1, 0, 1, 2, 3] --- [9.0,4.0,1.0,0.0,1.0,4.0,9.0] --- >>> df = derivative myFunc :: Float -> Float --- >>> fmap df [-3, -2, -1, 0, 1, 2, 3] --- [-6.0,-4.0,-2.0,0.0,2.0,4.0,6.0] -type BackpropFunc = Backprop (->) - -instance forall x. (Distributive x) => StartBackprop (->) x where - startBackprop = const one - --- | Infinitely differentiable constant function. --- --- === __Examples of usage__ --- --- >>> import Prelude (Float) --- >>> import InfBackprop (call, derivative, derivativeN) --- --- >>> call (const 5) () --- 5 --- --- >>> derivative (const (5 :: Float)) 42 --- 0 --- --- >>> derivativeN 2 (const (5 :: Float)) 42 --- 0.0 -const :: - forall c x. - (Additive c, Additive x) => - c -> - BackpropFunc x c -const c = MkBackprop call' forward' backward' - where - call' :: x -> c - call' = P.const c - forward' :: BackpropFunc x (c, ()) - forward' = const c >>> (iso :: BackpropFunc c (c, ())) - backward' :: BackpropFunc (c, ()) x - backward' = (iso :: BackpropFunc (c, ()) c) >>> const zero - --- | Lifts a backprop function morphism to the corresponding pure Kleisli morphism. -pureBackprop :: forall a b m. Monad m => Backprop (->) a b -> Backprop (Kleisli m) a b -pureBackprop - ( MkBackprop - (call'' :: a -> b) - (forward'' :: Backprop (->) a (b, c)) - (backward'' :: Backprop (->) (b, c) a) - ) = - MkBackprop call' forward' backward' - where - call' :: Kleisli m a b - call' = Kleisli $ pure . call'' - - forward' :: Backprop (Kleisli m) a (b, c) - forward' = pureBackprop forward'' - - backward' :: Backprop (Kleisli m) (b, c) a - backward' = pureBackprop backward'' - -instance (Distributive x, Monad m) => StartBackprop (Kleisli m) x where - startBackprop = pureBackprop startBackprop diff --git a/src/InfBackprop/Tutorial.hs b/src/InfBackprop/Tutorial.hs deleted file mode 100644 --- a/src/InfBackprop/Tutorial.hs +++ /dev/null @@ -1,474 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -{-# OPTIONS_HADDOCK show-extensions #-} - --- | Module : InfBackprop.Tutorial --- Copyright : (C) 2023 Alexey Tochin --- License : BSD3 (see the file LICENSE) --- Maintainer : Alexey Tochin --- --- Tutorial [inf-backprop](https://hackage.haskell.org/package/inf-backprop) package. -module InfBackprop.Tutorial - ( -- * Quick start - -- $quick_start - - -- * Derivatives for symbolic expressions - -- $derivatives_for_symbolic_expressions - - -- * Symbolic expressions visualization - -- $symbolic_expressions_visualization - - -- * How it works - -- $how_it_works - - -- * Declaring custom derivative - -- $declaring_custom_derivative - - -- * Differentiation of monadic function - -- $differentiation_monadic_types - - -- * Differentiation with logging - -- $differentiation_with_logging - ) -where - -import Control.Arrow (Kleisli, (<<<), (>>>)) -import Control.Monad.Logger (MonadLogger) -import Debug.SimpleExpr (SimpleExpr, simplify) -import InfBackprop - ( Backprop, - BackpropFunc, - backward, - call, - cos, - derivative, - first, - forward, - pow, - pureBackprop, - second, - (***), - ) -import Prelude (Maybe (Just, Nothing), Monad) - --- $quick_start --- >>> :set -XNoImplicitPrelude --- >>> import Prelude (Float, fmap) --- >>> import InfBackprop (BackpropFunc, call, derivative, derivativeN, pow) --- --- We can define differentiable function --- --- \[ --- f(x) := x^2 --- \] --- --- as follows --- --- >>> smoothF = pow 2 :: BackpropFunc Float Float --- --- where 'pow' is a power differentiable function and --- 'BackpropFunc'@ :: * -> * -> * @ --- is a type for infinitely differentiable (smooth) functions. --- We can get the function values by 'call' method like --- --- >>> f = call smoothF :: Float -> Float --- >>> fmap f [-3, -2, -1, 0, 1, 2, 3] --- [9.0,4.0,1.0,0.0,1.0,4.0,9.0] --- --- as well as the first derivative by 'derivative', which is --- --- \[ --- f'(x) = 2 \cdot x --- \] --- --- >>> df = derivative smoothF :: Float -> Float --- >>> fmap df [-3, -2, -1, 0, 1, 2, 3] --- [-6.0,-4.0,-2.0,0.0,2.0,4.0,6.0] --- --- or the second derivative --- --- \[ --- f''(x) = 2 --- \] --- --- >>> d2f = derivativeN 2 smoothF :: Float -> Float --- >>> fmap d2f [-3, -2, -1, 0, 1, 2, 3] --- [2.0,2.0,2.0,2.0,2.0,2.0,2.0] --- --- and so on. --- --- A composition of two functions like --- --- \[ --- g(x) := \log x^3 --- \] --- --- must be defined with the categorical composition '(>>>)' (or '(<<<)') --- --- >>> import InfBackprop (log) --- >>> import Control.Category ((>>>), (<<<)) --- >>> smoothG = pow 3 >>> log --- --- For more complicated expressions, for example, --- --- \[ --- h(x) := x^2 + x^3 --- \] --- --- we use arrow notations '(***)', 'first' and 'second' as follows --- --- >>> import InfBackprop ((+), dup) --- >>> import Control.CatBifunctor ((***)) --- --- >>> smoothH = dup >>> (pow 2 *** pow 3) >>> (+) :: BackpropFunc Float Float --- --- where --- --- @ --- dup :: BackpropFunc a (a, a) --- @ --- --- is differentiable function that simply splits the single implicit argument @x@ into the tuple '(x, x)'. --- THis is needed path tje implicit @x@ to two independent functions 'pow' @2@ and 'pow' @3@. --- The last --- --- @ --- (+) :: BackpropFunc (a, a) a --- @ --- --- operation transforms the pair of implicit arguments into their sum. - --- $derivatives_for_symbolic_expressions --- --- >>> import Prelude (($)) --- >>> import Control.Category ((<<<)) --- >>> import InfBackprop (BackpropFunc, call, derivative, derivativeN, sin, pow, (**), pow, setSecond, const) --- --- We use --- [simple-expr](https://hackage.haskell.org/package/simple-expr) --- package here. --- --- >>> import Debug.SimpleExpr.Expr (SimpleExpr, variable, simplify) --- --- For example a symbolic function --- --- \[ --- f(x) := \sin x^2 --- \] --- --- can be defined as follows --- --- >>> x = variable "x" --- >>> f = sin <<< pow 2 :: BackpropFunc SimpleExpr SimpleExpr --- --- see 'Debug.SimpleExpr.Tutorial' for details. --- We can call the symbolic function like --- --- >>> call f x --- sin(x·x) --- --- and find the symbolic derivative --- --- \[ --- \frac{d}{d x} f(x) = \frac{d}{d x} \sin x^2 = 2\, x \cos x^2 --- \] --- --- as follows --- --- >>> simplify $ derivative f x --- cos(x·x)·(2·x) --- --- as well as the second and higher derivatives --- --- >>> simplify $ derivativeN 2 f x --- (((2·x)·-(sin(x·x)))·(2·x))+(2·cos(x·x)) - --- $symbolic_expressions_visualization --- The --- [simple-expr](https://hackage.haskell.org/package/simple-expr) --- package is equipped with a visulaisation tool that can be used to illustrate how the differentiation works. --- --- >>> import Control.Category ((<<<)) --- >>> import InfBackprop (call, backpropExpr) --- >>> import Debug.SimpleExpr.Expr (SimpleExpr, variable, simplify) --- >>> import Debug.SimpleExpr.GraphUtils (exprToGraph) --- >>> import Data.Graph.VisualizeAlternative (plotDGraph) --- --- As a warm up consider a trivial composition of two functions --- --- \[ --- g(f(x)) --- \] --- --- is defined as --- --- >>> x = variable "x" --- >>> call (backpropExpr "g" <<< backpropExpr "f") x --- g(f(x)) --- --- It can be plotted by --- --- @ plotExpr $ call (backpropExpr "g" <<< backpropExpr "f") x @ --- --- ![image description](doc/images/composition.png) --- --- The graph for the first derivative can depicted by --- --- @ plotExpr $ simplify $ derivative (backpropExpr "g" <<< backpropExpr "f") x @ --- --- ![image description](doc/images/composition_derivative.png) --- --- where --- 'simplify'@ :: @'SimpleExpr'@ -> @'SimpleExpr` --- is a simple removal such things like @*1@ and @+0@. --- --- As well as the second derivative is straightforward --- --- @ plotExpr $ simplify $ derivativeN 2 (backpropExpr "g" <<< backpropExpr "f") x @ --- --- ![image description](doc/images/composition_second_derivative.png) - --- $how_it_works --- The idea would be clear from the example of three functions composition --- --- \[ --- g(f(h(x))) --- \] --- with a focus on function @f@. --- --- Its first derivative over @x@ is --- --- \[ --- g(f(h(x))). --- \] --- --- \[ --- h'(x) \cdot f'(h(x)) \cdot g'(f(h(x))). --- \] --- --- According to the backpropagation strategy, the order of the calculation should be as follows. --- --- 1. Find @h(x)@. --- --- 2. Find @f(h(x))@. --- --- 3. Find @g(f(h(x)))@. --- --- 4. Find the top derivative @g'(f(h(x)))@. --- --- 5. Find the next to the top derivative @f'(h(x))@. --- --- 6. Multiply @g'(f(h(x)))@ on @f'(h(x))@. --- --- 7. Find the next derivative @h'(x)@. --- --- 8. Multiply the output of point 6 on @h'(x)@. --- --- The generalization for longer composition is straightforward. --- --- All calculations related to the function @f@ can be divided into two parts. --- We have to find @f@ of @h(x)@ first (forward step) and then the derivative @f'@ of the same argument @h(x)@ and --- multiply it on the derivative @g'(f(h(x)))@ obtained during the similar calculations for @g@ (backward step). --- Notice that the value of @h(x)@ is reused on the backward step. --- To implement this, we define type 'Backprop' (see the corresponding --- documentation for details). - --- $declaring_custom_derivative --- >>> import Prelude (Float) --- >>> import qualified Prelude --- >>> import Control.Category ((>>>)) --- >>> import InfBackprop ((*), negate, dup, BackpropFunc, Backprop(MkBackprop), second) --- --- As an illustrative example a differentiable version of 'cos' numerical function can be defined as follows --- (see the documentation for 'Backprop' for details) --- --- @ --- cos :: BackpropFunc Float Float --- cos = MkBackprop call' forward' backward' where --- call' :: Float -> Float --- call' = Prelude.cos --- --- forward' :: BackpropFunc Float (Float, Float) --- forward' = dup >>> first cos --- --- backward' :: BackpropFunc (Float, Float) Float --- backward' = second (sin >>> negate) >>> (*) --- --- sin :: BackpropFunc Float Float --- sin = ... --- @ --- --- Here we use @Prelude@ implementation for ordinary @cos@ function in 'call'. --- The forward function is differentiable (which is needed for further derivatives) function --- with two output values. --- Roughly speaking 'forward' is --- @x -> (sin x, x)@. --- The first term of the tuple is just @sin@ and --- the second terms @x@ in the tuple is the value to be reused on the backward step. --- The 'backward' is --- @(dy, x) -> dy * (-cos x)@, --- where @dy@ is the derivative found on the previous backward step and the second value is @x@ stored by `forward`. --- We simply multiply with @(*)@ the derivative @dy@ on the derivative of @sin@ that is @-cos@. --- --- The stored value is not necessary just @x@. It could be anything useful for the backward step, see for example --- the implementation for @exp@ and the corresponding --- [example](InfBackprop.Tutorial#differentiation_with_logging) --- below. - --- $differentiation_monadic_types #differentiation_monadic_types# --- Differentiable versions of monadic functions @a -> m b@ can also be backpropagated. --- For example, consider a real-valued power function defined for positive real numbers. --- For a negative number, it returns 'Nothing', which is a signal to stop computing the derivative and return 'Nothing' --- in the spirit of the behavior of the monad 'Maybe'. --- For this purpose, we can use that the type 'Backprop' type is defined for any category, --- not only for functions @(->)@. --- In particular, we can try 'Backprop'@(@'Kleisli' 'Maybe'@)@ instead of 'Backprop'@(->)@ from the previous sections. --- --- >>> import Prelude (Maybe, Maybe(Just, Nothing), ($), Ord, (>), Float) --- >>> import InfBackprop (Backprop(MkBackprop), derivative, dup, (*), linear, pureBackprop, first, second) --- >>> import Control.Arrow (Kleisli(Kleisli), runKleisli, (>>>)) --- >>> import qualified NumHask as NH --- --- The functoin --- --- @ --- pureBackprop :: Monad m => Backprop (->) a b -> Backprop (Kleisli m) a b --- @ --- --- is to trivially lift an ordinary backpropagation functions to the monadic function type. --- --- Define the power function as follows --- --- >>> :{ --- powR :: forall a. (Ord a, NH.ExpField a) => --- a -> Backprop (Kleisli Maybe) a a --- powR p = MkBackprop call' forward' backward' --- where --- call' :: Kleisli Maybe a a --- call' = Kleisli $ \x -> if x > NH.zero --- then Just $ x NH.** p --- else Nothing --- -- --- forward' :: Backprop (Kleisli Maybe) a (a, a) --- forward' = pureBackprop dup >>> first (powR p) --- -- --- backward' :: Backprop (Kleisli Maybe) (a, a) a --- backward' = second der >>> pureBackprop (*) where --- der = powR (p NH.- NH.one) >>> pureBackprop (linear p) --- :} --- --- and calculate --- --- \[ --- \frac{d}{dx} x^{\frac12} = \frac{1}{2 \sqrt{x}} --- \] --- --- for @x=4@ and @x=-4@ like --- --- >>> runKleisli (derivative (powR 0.5)) (4 :: Float) --- Just 0.25 --- >>> runKleisli (derivative (powR 0.5)) (-4 :: Float) --- Nothing - --- $differentiation_with_logging #differentiation_with_logging# --- --- Our objective now is to add logging to the derivative calculation. --- The type 'Backprop' @cat a b@ type is parametrized by a category @cat@, input @a@ and output @b@. --- If @cat@ is @(->)@ the type is reduced to 'BackpropFunc' we worked with above. --- To add logging to the calculation we shall replace @(->)@ by --- 'MonadLogger' @m =>@ 'Kleisli' @m@. --- We will need the imports below --- --- >>> import Prelude (Integer, Float, ($), (+), (*)) --- >>> import Control.Monad.Logger (runStdoutLoggingT, MonadLogger) --- >>> import Control.Arrow ((>>>), runKleisli, Kleisli) --- >>> import InfBackprop (derivative, loggingBackpropExpr) --- >>> import Debug.SimpleExpr.Expr (variable) --- >>> import Debug.LoggingBackprop (initUnaryFunc, initBinaryFunc, pureKleisli, exp, sin) --- --- where the module 'Debug.loggingBackpropExpr' contains some useful functionality. --- For example, lifts for unary functions --- --- @ --- initUnaryFunc :: (Show a, Show b, MonadLogger m) => String -> (a -> b) -> Kleisli m a b --- @ --- --- and binary functions --- --- @ --- initBinaryFunc :: (Show a, Show b, Show c, MonadLogger m) => String -> (a -> b -> c) -> Kleisli m (a, b) c --- @ --- --- These two terms map given functions to Kleisli category terms, that allows logging during their execution. --- --- Let us first explain how it works with the following example. --- --- \[ --- f(x) = y \cdot 3 + y \cdot 4, \quad y = x + 2. --- \] --- --- This function can be defined as follows --- --- >>> :{ --- fLogging :: MonadLogger m => Kleisli m Integer Integer --- fLogging = --- initUnaryFunc "+2" (+2) >>> --- (pureKleisli (\x -> (x, x))) >>> --- (initUnaryFunc "*3" (*3) *** initUnaryFunc "*4" (*4)) >>> --- initBinaryFunc "sum" (+) --- :} --- --- We run the calculation with @ x = 5 @ as follows --- --- >>> runStdoutLoggingT $ runKleisli fLogging 5 --- [Info] Calculating +2 of 5 => 7 --- [Info] Calculating *3 of 7 => 21 --- [Info] Calculating *4 of 7 => 28 --- [Info] Calculating sum of 21 and 28 => 49 --- 49 --- --- We are now ready to consider an example with derivatives. --- Let us calculate a simple example as follows --- --- \[ --- \frac{d}{dx} \mathrm{f} (e^x) = e^x f'(e^x) --- \] --- --- We define symbolic function @f@ by --- --- @ --- loggingBackpropExpr :: String -> BackpropFunc SimpleExpr SimpleExpr --- @ --- --- and the entire derivative is --- --- >>> runStdoutLoggingT $ runKleisli (derivative (exp >>> loggingBackpropExpr "f")) (variable "x") --- [Info] Calculating exp of x => exp(x) --- [Info] Calculating f of exp(x) => f(exp(x)) --- [Info] Calculating f' of exp(x) => f'(exp(x)) --- [Info] Calculating multiplication of 1 and f'(exp(x)) => 1·f'(exp(x)) --- [Info] Calculating multiplication of 1·f'(exp(x)) and exp(x) => (1·f'(exp(x)))·exp(x) --- (1·f'(exp(x)))·exp(x) --- --- For illustration we can set 'f = sin' and 'x=2' --- --- \[ --- \left. \frac{d}{dx} \sin (e^x) \right|_{x=2} = e^2 \cos (e^2) --- \] --- --- >>> runStdoutLoggingT $ runKleisli (derivative (exp >>> sin)) (2 :: Float) --- [Info] Calculating exp of 2.0 => 7.389056 --- [Info] Calculating sin of 7.389056 => 0.893855 --- [Info] Calculating cos of 7.389056 => 0.44835615 --- [Info] Calculating multiplication of 1.0 and 0.44835615 => 0.44835615 --- [Info] Calculating multiplication of 0.44835615 and 7.389056 => 3.312929 --- 3.312929 --- --- The first thing to mention in these logs is that the last forward step --- @sin(exp x)@ --- is still computed, unlike the examples from the previous section. --- This is due to the monadic nature of the calculation chain, that must disappear as soon as we return to --- @(->)@ from 'Kleisli' @m@. --- --- The second thing to mention here is that the exponent --- @exp x@ --- is calculated only once thanks to the cache term passed from the `forward` to the `backward` method. diff --git a/src/IsomorphismClass/Extra.hs b/src/IsomorphismClass/Extra.hs deleted file mode 100644 --- a/src/IsomorphismClass/Extra.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS_HADDOCK show-extensions #-} - --- | Module : IsomorphismClass.Extra --- Copyright : (C) 2023 Alexey Tochin --- License : BSD3 (see the file LICENSE) --- Maintainer : Alexey Tochin --- --- Extra instances for 'IsomorphicTo' typeclass from 'isomorphism-class' package. -module IsomorphismClass.Extra () where - -#if MIN_VERSION_isomorphism_class(0,3,0) -#else -import Control.Category (id) -#endif -import Data.Void (Void, absurd) -import IsomorphismClass (IsomorphicTo, to) -import Prelude (Either (Left, Right), fst, snd) - -#if MIN_VERSION_isomorphism_class(0,3,0) -#else -instance {-# INCOHERENT #-} IsomorphicTo a a where - to = id -#endif - --- Type products - -instance {-# INCOHERENT #-} IsomorphicTo a (a, ()) where - to = fst - -instance {-# INCOHERENT #-} IsomorphicTo (a, ()) a where - to = (,()) - -instance {-# INCOHERENT #-} IsomorphicTo a ((), a) where - to = snd - -instance {-# INCOHERENT #-} IsomorphicTo ((), a) a where - to = ((),) - --- | Type product commutativity --- --- ==== __Examples of usage__ --- --- >>> import IsomorphismClass.Isomorphism (iso) --- >>> (iso :: (->) (a, b) (b, a)) (1, "x") --- ("x",1) -instance {-# INCOHERENT #-} IsomorphicTo (a, b) (b, a) where - to (b, a) = (a, b) - -instance {-# INCOHERENT #-} IsomorphicTo (a, (b, c)) ((a, b), c) where - to ((a, b), c) = (a, (b, c)) - -instance {-# INCOHERENT #-} IsomorphicTo ((a, b), c) (a, (b, c)) where - to (a, (b, c)) = ((a, b), c) - -instance {-# INCOHERENT #-} IsomorphicTo ((a, b), (c, d)) ((a, c), (b, d)) where - to ((a, c), (b, d)) = ((a, b), (c, d)) - --- instance {-# INCOHERENT #-} IsomorphicTo (a, (b, (c, d))) (a, ((c, d), b)) where --- to (a, ((c, d), b)) = (a, (b, (c, d))) --- --- instance {-# INCOHERENT #-} IsomorphicTo (a, ((c, d), b)) (a, (b, (c, d))) where --- to (a, (b, (c, d))) = (a, ((c, d), b)) - --- Type sums - -instance {-# INCOHERENT #-} IsomorphicTo a (Either a Void) where - to (Left a) = a - to (Right a) = absurd a - -instance {-# INCOHERENT #-} IsomorphicTo (Either a Void) a where - to = Left - --- | Type sum commutativity. --- --- ==== __Examples of usage__ --- --- >>> import IsomorphismClass.Isomorphism (iso) --- >>> (iso :: (->) (Either a b) (Either b a)) (Left 1) --- Right 1 --- >>> (iso :: (->) (Either a b) (Either b a)) (Right "x") --- Left "x" -instance {-# INCOHERENT #-} IsomorphicTo a (Either Void a) where - to (Right a) = a - to (Left a) = absurd a - -instance {-# INCOHERENT #-} IsomorphicTo (Either Void a) a where - to = Right - -instance {-# INCOHERENT #-} IsomorphicTo (Either a b) (Either b a) where - to (Left b) = Right b - to (Right b) = Left b - -instance {-# INCOHERENT #-} IsomorphicTo (Either a (Either b c)) (Either (Either a b) c) where - to (Left (Left a)) = Left a - to (Left (Right b)) = Right (Left b) - to (Right c) = Right (Right c) - -instance {-# INCOHERENT #-} IsomorphicTo (Either (Either a b) c) (Either a (Either b c)) where - to (Left a) = Left (Left a) - to (Right (Left b)) = Left (Right b) - to (Right (Right c)) = Right c - -instance {-# INCOHERENT #-} IsomorphicTo (Either (Either a b) (Either c d)) (Either (Either a c) (Either b d)) where - to (Left (Left a)) = Left (Left a) - to (Left (Right c)) = Right (Left c) - to (Right (Left b)) = Left (Right b) - to (Right (Right d)) = Right (Right d) - --- instance {-# INCOHERENT #-} IsomorphicTo (Either a (Either b (Either c d))) (Either a (Either (Either c d) b)) where --- to (Left a) = Left a --- to (Right (Left b)) = Right (Right b) --- to (Right (Right (Left c))) = Right --- --- --- to (a, ((c, d), b)) = (a, (b, (c, d))) --- --- instance {-# INCOHERENT #-} IsomorphicTo (Either a (Either (Either c d) b)) (Either a (Either b (Either c d))) where --- to (a, (b, (c, d))) = (a, ((c, d), b)) diff --git a/src/IsomorphismClass/Isomorphism.hs b/src/IsomorphismClass/Isomorphism.hs deleted file mode 100644 --- a/src/IsomorphismClass/Isomorphism.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# OPTIONS_HADDOCK show-extensions #-} - --- | Module : IsomorphismClass.Isomorphism --- Copyright : (C) 2023 Alexey Tochin --- License : BSD3 (see the file LICENSE) --- Maintainer : Alexey Tochin --- --- Isomorphism class and instances. -module IsomorphismClass.Isomorphism - ( Isomorphism, - iso, - ) -where - -import Control.Applicative (pure) -import Control.Arrow (Kleisli (Kleisli)) -import Control.Category ((.)) -import Control.Comonad (Cokleisli (Cokleisli), Comonad, extract) -import Control.Monad (Monad) -import GHC.Base (Type) -import IsomorphismClass (IsomorphicTo, from, to) -import Prelude (($)) - --- | A generalization of isomorphism. --- Type argument @c@ is usually a category. -class Isomorphism (c :: Type -> Type -> Type) where - -- | Categorical morphism that that is related to an isomorphism map from @a@ to @b@. - iso :: IsomorphicTo a b => c a b - --- | Trivial instance of 'Isomorphism' that is the map type @(->)@. --- --- ==== __Examples of usage__ --- --- >>> import Prelude (Int, fst, Either (Right)) --- >>> import Data.Void (Void) --- >>> import IsomorphismClass.Extra () --- --- >>> (iso :: (->) (a, b) (b, a)) (1, "x") --- ("x",1) --- --- >>> (iso :: (->) (a, ()) a) (42, ()) --- 42 --- --- >>> (iso :: (->) (Either Void a) a) (Right 42) --- 42 -instance Isomorphism (->) where - iso :: IsomorphicTo a b => a -> b - iso = from - --- | Kleisli (monadic) instance of 'Isomorphism'. --- --- ==== __Examples of usage__ --- --- >>> import Prelude (Int, fst, Either (Right)) --- >>> import Data.Void (Void) --- >>> import Control.Arrow (runKleisli) --- >>> import IsomorphismClass.Extra () --- --- >>> runKleisli (iso :: (Kleisli []) (a, b) (b, a)) (1, "x") --- [("x",1)] -instance Monad m => Isomorphism (Kleisli m) where - iso :: IsomorphicTo a b => Kleisli m a b - iso = Kleisli $ pure . to - --- | Cokleisli (comonadic) instance of 'Isomorphism'. --- --- ==== __Examples of usage__ --- --- >>> import Prelude (Int, fst, Either (Right), (+)) --- >>> import Data.Void (Void) --- >>> import Control.Comonad (Cokleisli(Cokleisli), runCokleisli) --- >>> import Control.Comonad.Store (store, runStore, Store) --- >>> import IsomorphismClass.Extra () --- --- >>> runCokleisli (iso :: (Cokleisli (Store Int)) (a, b) (b, a)) (store (\x -> (x + 1, x + 2)) 0) --- (2,1) -instance Comonad w => Isomorphism (Cokleisli w) where - iso :: IsomorphicTo a b => Cokleisli w a b - iso = Cokleisli $ to . extract diff --git a/src/NumHask/Extra.hs b/src/NumHask/Extra.hs deleted file mode 100644 --- a/src/NumHask/Extra.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | Module : NumHask.Extra --- Copyright : (C) 2023 Alexey Tochin --- License : BSD3 (see the file LICENSE) --- Maintainer : Alexey Tochin --- --- Additional orphan instances for --- [mumhusk](https://hackage.haskell.org/package/numhask) --- typeclasses. -module NumHask.Extra () where - -import NumHask (Additive, zero, (+)) -import Prelude hiding (Num, (+)) - -instance {-# INCOHERENT #-} Additive () where - (+) = const - zero = () - -instance {-# INCOHERENT #-} (Additive x, Additive y) => Additive (x, y) where - zero = (zero, zero) - (a, b) + (c, d) = (a + c, b + d) - -instance {-# INCOHERENT #-} (Additive x, Additive y, Additive z) => Additive (x, y, z) where - zero = (zero, zero, zero) - (x1, y1, z1) + (x2, y2, z2) = (x1 + x2, y1 + y2, z1 + z2) - -instance {-# INCOHERENT #-} (Additive x, Additive y, Additive z, Additive t) => Additive (x, y, z, t) where - zero = (zero, zero, zero, zero) - (x1, y1, z1, t1) + (x2, y2, z2, t2) = (x1 + x2, y1 + y2, z1 + z2, t1 + t2) - -instance - {-# INCOHERENT #-} - (Additive x, Additive y, Additive z, Additive t, Additive s) => - Additive (x, y, z, t, s) - where - zero = (zero, zero, zero, zero, zero) - (x1, y1, z1, t1, s1) + (x2, y2, z2, t2, s2) = (x1 + x2, y1 + y2, z1 + z2, t1 + t2, s1 + s2) diff --git a/src/Numeric/InfBackprop.hs b/src/Numeric/InfBackprop.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/InfBackprop.hs @@ -0,0 +1,195 @@ +-- | Module : Data.Vector.InfBackpropExtra +-- Copyright : (C) 2025 Alexey Tochin +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Alexey Tochin +-- +-- | Module providing all functionality of the library. +-- It re-exports all important types and functions from submodules. +-- See the documentation of individual submodules for details. +module Numeric.InfBackprop + ( -- * Common + + -- ** Base + Tangent, + Dual, + Cotangent, + CT, + RevDiff (MkRevDiff, value, backprop), + RevDiff', + DifferentiableFunc, + initDiff, + call, + derivativeOp, + constDiff, + scalarArg, + scalarVal, + autoArg, + autoVal, + stopDiff, + simpleDifferentiableFunc, + + -- ** Relation to lens and profunctors + toLensOps, + toLens, + fromLens, + fromProfunctors, + toProfunctors, + fromVanLaarhoven, + toVanLaarhoven, + + -- ** Derivative operators + scalarArgDerivative, + customArgDerivative, + customValDerivative, + scalarValDerivative, + simpleDerivative, + simpleValueAndDerivative, + customArgValDerivative, + + -- * Differentiable types + + -- ** Tuple + twoArgsDerivative, + twoArgsDerivativeOverX, + twoArgsDerivativeOverY, + tupleDerivativeOverX, + tupleDerivativeOverY, + mkTupleArg, + tupleArg, + tupleArgDerivative, + mkTupleVal, + tupleVal, + tupleValDerivative, + + -- ** Triple + threeArgsToTriple, + threeArgsDerivative, + derivative3ArgsOverX, + derivative3ArgsOverY, + derivative3ArgsOverZ, + tripleDerivativeOverX, + tripleDerivativeOverY, + tripleDerivativeOverZ, + mkTripleArg, + tripleArg, + tripleArgDerivative, + mkTripleVal, + tripleVal, + tripleValDerivative, + + -- ** Boxed Vector + mkBoxedVectorArg, + boxedVectorArg, + boxedVectorArgDerivative, + mkBoxedVectorVal, + boxedVectorVal, + boxedVectorValDerivative, + + -- ** Stream + mkStreamArg, + streamArg, + streamArgDerivative, + mkStreamVal, + streamVal, + streamValDerivative, + + -- ** FiniteSupportStream + mkFiniteSupportStreamArg, + finiteSupportStreamArg, + finiteSupportStreamArgDerivative, + mkFiniteSupportStreamVal, + finiteSupportStreamVal, + finiteSupportStreamValDerivative, + + -- ** Maybe + maybeArg, + mkMaybeArg, + maybeArgDerivative, + maybeVal, + mkMaybeVal, + maybeValDerivative, + ) +where + +import Numeric.InfBackprop.Core + ( CT, + Cotangent, + DifferentiableFunc, + Dual, + RevDiff (MkRevDiff, backprop, value), + RevDiff', + Tangent, + autoArg, + autoVal, + boxedVectorArg, + boxedVectorArgDerivative, + boxedVectorVal, + boxedVectorValDerivative, + call, + constDiff, + customArgDerivative, + customArgValDerivative, + customValDerivative, + derivative3ArgsOverX, + derivative3ArgsOverY, + derivative3ArgsOverZ, + derivativeOp, + finiteSupportStreamArg, + finiteSupportStreamArgDerivative, + finiteSupportStreamVal, + finiteSupportStreamValDerivative, + fromLens, + fromProfunctors, + fromVanLaarhoven, + initDiff, + maybeArg, + maybeArgDerivative, + maybeVal, + maybeValDerivative, + mkBoxedVectorArg, + mkBoxedVectorVal, + mkFiniteSupportStreamArg, + mkFiniteSupportStreamVal, + mkMaybeArg, + mkMaybeVal, + mkStreamArg, + mkStreamVal, + mkTripleArg, + mkTripleVal, + mkTupleArg, + mkTupleVal, + scalarArg, + scalarArgDerivative, + scalarVal, + scalarValDerivative, + simpleDerivative, + simpleDifferentiableFunc, + simpleValueAndDerivative, + stopDiff, + streamArg, + streamArgDerivative, + streamVal, + streamValDerivative, + threeArgsDerivative, + threeArgsToTriple, + toLens, + toLensOps, + toProfunctors, + toVanLaarhoven, + tripleArg, + tripleArgDerivative, + tripleDerivativeOverX, + tripleDerivativeOverY, + tripleDerivativeOverZ, + tripleVal, + tripleValDerivative, + tupleArg, + tupleArgDerivative, + tupleDerivativeOverX, + tupleDerivativeOverY, + tupleVal, + tupleValDerivative, + twoArgsDerivative, + twoArgsDerivativeOverX, + twoArgsDerivativeOverY, + ) diff --git a/src/Numeric/InfBackprop/Core.hs b/src/Numeric/InfBackprop/Core.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/InfBackprop/Core.hs @@ -0,0 +1,3327 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + +-- | Module : Data.Vector.InfBackpropExtra +-- Copyright : (C) 2025 Alexey Tochin +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Alexey Tochin +-- +-- Backpropagation differentiation core types and functions. +module Numeric.InfBackprop.Core + ( -- * Common + + -- ** Base + Tangent, + Dual, + Cotangent, + CT, + RevDiff (MkRevDiff, value, backprop), + RevDiff', + DifferentiableFunc, + initDiff, + call, + derivativeOp, + toLensOps, + constDiff, + StopDiff (stopDiff), + HasConstant (constant), + simpleDifferentiableFunc, + + -- ** Relation to lens and profunctors + toLens, + fromLens, + fromProfunctors, + toProfunctors, + fromVanLaarhoven, + toVanLaarhoven, + + -- ** Derivative operators + AutoDifferentiableArgument, + DerivativeRoot, + DerivativeCoarg, + DerivativeArg, + AutoDifferentiableValue, + DerivativeValue, + autoArg, + autoVal, + sameTypeDerivative, + simpleDerivative, + simpleValueAndDerivative, + customArgDerivative, + customValDerivative, + customArgValDerivative, + + -- * Differentiable functions + + -- ** Basic + differentiableSum, + differentiableSub, + differentiableNegate, + differentiableMult, + differentiableDiv, + differentiableRecip, + differentiableMultAction, + differentiableConv, + + -- ** Exponential and logarithmic functions + differentiablePow, + differentiableExp, + differentiableLog, + differentiableLogBase, + differentiableSqrt, + + -- ** Trigonometric functions + differentiableSin, + differentiableCos, + differentiableTan, + differentiableSinh, + differentiableCosh, + differentiableTanh, + differentiableAsin, + differentiableAcos, + differentiableAtan, + differentiableAtan2, + differentiableAsinh, + differentiableAcosh, + differentiableAtanh, + + -- * Differentiable types + + -- ** Scalar + scalarArg, + scalarVal, + scalarArgDerivative, + scalarValDerivative, + + -- ** Tuple + mkTupleArg, + tupleArg, + tupleArgDerivative, + tupleDerivativeOverX, + tupleDerivativeOverY, + twoArgsDerivative, + twoArgsDerivativeOverX, + twoArgsDerivativeOverY, + mkTupleVal, + tupleVal, + tupleValDerivative, + + -- ** Triple + threeArgsToTriple, + tripleArg, + mkTripleArg, + tripleArgDerivative, + tripleDerivativeOverX, + tripleDerivativeOverY, + tripleDerivativeOverZ, + threeArgsDerivative, + derivative3ArgsOverX, + derivative3ArgsOverY, + derivative3ArgsOverZ, + mkTripleVal, + tripleVal, + tripleValDerivative, + + -- ** BoxedVector + boxedVectorArg, + mkBoxedVectorArg, + boxedVectorArgDerivative, + boxedVectorVal, + mkBoxedVectorVal, + boxedVectorValDerivative, + + -- ** Stream + streamArg, + mkStreamArg, + streamArgDerivative, + streamVal, + mkStreamVal, + streamValDerivative, + + -- ** FiniteSupportStream + finiteSupportStreamArg, + mkFiniteSupportStreamArg, + finiteSupportStreamArgDerivative, + finiteSupportStreamVal, + mkFiniteSupportStreamVal, + finiteSupportStreamValDerivative, + + -- ** Maybe + maybeArg, + mkMaybeArg, + maybeArgDerivative, + maybeVal, + mkMaybeVal, + maybeValDerivative, + ) +where + +import Control.Applicative ((<$>), (<*>)) +import Control.Comonad.Identity (Identity (Identity, runIdentity)) +import Control.ExtendableMap (ExtandableMap, extendMap) +import qualified Control.Lens as CL +import Control.Monad.ST (runST) +import Data.Bifunctor (first) +import Data.Coerce (coerce) +import Data.Composition ((.:)) +import Data.Finite (Finite) +import Data.FiniteSupportStream (FiniteSupportStream (MkFiniteSupportStream, toVector), cons, empty, head, singleton, tail, unsafeMap) +import Data.Function (on) +import Data.Functor.Compose (Compose (Compose, getCompose)) +import Data.Functor.Const (Const (Const, getConst)) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.List.NonEmpty (xor) +import Data.Primitive (Prim) +import Data.Profunctor (Profunctor (dimap)) +import Data.Profunctor.Strong (Costrong (unfirst, unsecond)) +import Data.Proxy (Proxy (Proxy)) +import Data.Stream (Stream) +import qualified Data.Stream as DS +import Data.Tuple (curry, fst, snd, uncurry) +import Data.Tuple.Extra ((***)) +import Data.Type.Equality (type (~)) +import qualified Data.Vector as DV +import qualified Data.Vector.Fixed.Boxed as DVFB +import Data.Vector.Fusion.Util (Box (Box, unBox)) +import qualified Data.Vector.Generic as DVG +import Data.Vector.Generic.Base + ( Vector + ( basicLength, + basicUnsafeCopy, + basicUnsafeFreeze, + basicUnsafeIndexM, + basicUnsafeSlice, + basicUnsafeThaw, + elemseq + ), + ) +import qualified Data.Vector.Generic.Base as DVGB +import qualified Data.Vector.Generic.Mutable as DVGM +import qualified Data.Vector.Generic.Mutable.Base as DVGBM +import qualified Data.Vector.Generic.Sized as DVGS +import qualified Data.Vector.Generic.Sized.Internal as DVGSI +import qualified Data.Vector.Primitive as DVP +import qualified Data.Vector.Unboxed as DVU +import qualified Data.Vector.Unboxed.Mutable as DVUM +import Data.Word (Word, Word16, Word32, Word64, Word8) +import Debug.SimpleExpr (SimpleExpr, SimpleExprF) +import Debug.SimpleExpr.Expr (SE, number) +import Debug.SimpleExpr.Utils.Algebra + ( AlgebraicPower ((^^)), + Convolution ((|*|)), + IntegerPower, + MultiplicativeAction ((*|)), + (^), + ) +import Debug.SimpleExpr.Utils.Traced (Traced (MkTraced)) +import Debug.Trace (trace) +import Foreign (oneBits) +import GHC.Base + ( Applicative, + Eq ((==)), + Float, + Functor, + Int, + Maybe (Just, Nothing), + Ord (compare, max, min, (<), (<=), (>), (>=)), + Type, + const, + flip, + fmap, + id, + pure, + return, + undefined, + ($), + (++), + (.), + (<*>), + ) +import GHC.Generics (C, Generic, type (:.:) (unComp1)) +import GHC.Integer (Integer) +import GHC.Natural (Natural) +import qualified GHC.Num as GHCN +import GHC.Real (Integral, fromIntegral, realToFrac, toInteger) +import qualified GHC.Real as GHCR +import GHC.Show (Show (show)) +import GHC.TypeLits (KnownChar) +import GHC.TypeNats (KnownNat, Nat) +import GHC.Types (Int) +import NumHask + ( Additive, + AdditiveAction, + Complex, + Distributive, + Divisive, + ExpField, + Field, + FromInteger (fromInteger), + FromIntegral, + Multiplicative, + Subtractive, + TrigField, + acos, + acosh, + asin, + asinh, + atan, + atan2, + atanh, + cos, + cosh, + exp, + fromIntegral, + log, + logBase, + negate, + one, + pi, + recip, + sin, + sinh, + sqrt, + tan, + tanh, + two, + zero, + (*), + (**), + (+), + (-), + (/), + ) +import NumHask.Data.Integral (FromInteger) +import Numeric.InfBackprop.Instances.NumHask () +import Numeric.InfBackprop.Utils.SizedVector (BoxedVector, boxedVectorBasis, boxedVectorSum) +import Numeric.InfBackprop.Utils.Tuple (cross, cross3, curry3, fork, fork3, uncurry3) +import Optics (Lens, Lens', getting, lens, set, simple, view, (%)) + +-- | Converts a type into its tangent space type. +type family Tangent (a :: Type) :: Type + +type instance Tangent Float = Float + +type instance Tangent GHCN.Integer = GHCN.Integer + +type instance Tangent SimpleExpr = SimpleExpr + +type instance Tangent (a0, a1) = (Tangent a0, Tangent a1) + +type instance Tangent (a0, a1, a2) = (Tangent a0, Tangent a1, Tangent a2) + +type instance Tangent [a] = [Tangent a] + +type instance Tangent (DVFB.Vec n a) = DVFB.Vec n (Tangent a) + +type instance Tangent (DVGS.Vector v n a) = DVGS.Vector v n (Tangent a) + +type instance Tangent (Stream a) = Stream (Tangent a) + +type instance Tangent (FiniteSupportStream a) = FiniteSupportStream (Tangent a) + +type instance Tangent (Maybe a) = Maybe (Tangent a) + +type instance Tangent (Traced a) = Traced (Tangent a) + +type instance Tangent (Complex a) = Complex (Tangent a) + +-- | Converts a type into its dual space type. +type family Dual (x :: Type) :: Type + +type instance Dual Float = Float + +type instance Dual GHCN.Integer = GHCN.Integer + +type instance Dual SimpleExpr = SimpleExpr + +type instance Dual (a, b) = (Dual a, Dual b) + +type instance Dual (a, b, c) = (Dual a, Dual b, Dual c) + +type instance Dual [a] = [Dual a] + +type instance Dual (DVFB.Vec n a) = DVFB.Vec n (Dual a) + +type instance Dual (DVGS.Vector v n a) = DVGS.Vector v n (Dual a) + +type instance Dual (Stream a) = FiniteSupportStream (Dual a) + +type instance Dual (FiniteSupportStream a) = Stream (Dual a) + +type instance Dual (SimpleExprF a) = SimpleExprF (Dual a) + +type instance Dual (Maybe a) = Maybe (Dual a) + +type instance Dual (Traced a) = Traced (Dual a) + +type instance Dual (Complex a) = Complex (Dual a) + +-- | Cotangent type alias. +type Cotangent a = Dual (Tangent a) + +-- | Cotangent type alias. +type CT a = Cotangent a + +-- | Base type for differentiable instances with the backpropagation. +-- +-- ==== __Examples__ +-- +-- >>> :{ +-- differentiableSin_ :: RevDiff t Float Float -> RevDiff t Float Float +-- differentiableSin_ (MkRevDiff v bp) = MkRevDiff (sin v) (bp . (cos v *)) +-- :} +-- +-- >>> value $ differentiableSin_ (MkRevDiff 0.0 id) +-- 0.0 +-- +-- >>> backprop (differentiableSin_ (MkRevDiff 0.0 id)) 1.0 +-- 1.0 +-- +-- === `GHC.Num.Num` typeclass instance +-- +-- This instance enables the use of standard numeric operations and literals +-- directly with `RevDiff` values, simplifying the syntax for +-- automatic differentiation computations.-- +-- The instance supports `GHC.Num.Num` operations including arithmetic +-- operators @(+), (-), (*)@, comparison functions (`GHC.Num.abs`, `GHC.Num.signum`), and automatic +-- conversion from integer literals via `fromInteger`. +-- +-- ==== __Examples__ +-- +-- >>> import Debug.SimpleExpr (variable, SE, simplify) +-- >>> import GHC.Integer (Integer) +-- +-- >>> x = variable "x" +-- +-- ===== Using numeric literals in automatic differentiation +-- +-- This instance allows `RevDiff` values to be created directly from integer +-- literals, eliminating the need for explicit conversion functions. +-- +-- Consider computing the partial derivative: +-- +-- \[ +-- \left.\frac{\partial}{\partial y} (x \cdot y)\right|_{y=2} +-- \] +-- +-- Without the `GHC.Num.Num` instance, we would need explicit conversion: +-- +-- >>> simplify $ twoArgsDerivativeOverY (*) x (stopDiff $ number 2) :: SE +-- x +-- +-- With the `GHC.Num.Num` instance for `RevDiff`, this simplifies to: +-- +-- >>> simplify $ twoArgsDerivativeOverY (*) x (number 2) :: SE +-- x +-- +-- And combined with the `GHC.Num.Num` instance for `SE`, +-- we achieve the most concise form: +-- +-- >>> simplify $ twoArgsDerivativeOverY (*) x 2 +-- x +-- +-- This progression shows how the typeclass instances work together to enable +-- increasingly natural mathematical notation. +-- +-- ===== Power function differentiation +-- +-- The instance enables natural exponentiation syntax with automatic differentiation: +-- +-- >>> x ** 3 :: SE +-- x^3 +-- >>> simplify $ simpleDerivative (** 3) x :: SE +-- 3*(x^2) +-- >>> simplify $ simpleDerivative (simpleDerivative (** 3)) x :: SE +-- (2*x)*3 +-- +-- ===== Absolute value and signum functions +-- +-- The instance provides symbolic differentiation for absolute value and signum: +-- +-- >>> simplify $ simpleDerivative GHCN.abs (variable "x") :: SE +-- sign(x) +-- +-- >>> simplify $ simpleDerivative GHCN.signum (variable "x") :: SE +-- 0 +-- +-- For numeric evaluation, the second derivative of absolute value at a point +-- gives the expected result: +-- +-- >>> (simpleDerivative (simpleDerivative GHCN.abs)) (1 :: Float) :: Float +-- 0.0 +-- +-- Notice that the signum function returns zero for all values, including zero. +-- +-- >>> simpleDerivative GHCN.signum (0 :: Float) :: Float +-- 0.0 +-- +-- >>> simplify $ (simpleDerivative (simpleDerivative GHCN.abs)) (variable "x") :: SE +-- 0 +-- +-- === `GHCR.Fractional` typeclass instance +-- +-- Thank to this instance we can use numerical literals like '1.0', '2.0', etc., +-- see the examples below. +-- +-- ==== __Examples__ +-- +-- >>> import GHC.Float (Float) +-- >>> import Debug.SimpleExpr (variable, SE, simplify) +-- +-- >>> f x = 8 / x +-- >>> simpleDerivative f (2.0 :: Float) +-- -2.0 +-- >>> simplify $ simpleDerivative f (variable "x") :: SE +-- -((8/x)/x) +data RevDiff a b c = MkRevDiff {value :: c, backprop :: b -> a} + deriving (Generic) + +-- | Type alias for common case where the backpropagation is in the cotangent space. +type RevDiff' a b = RevDiff (CT a) (CT b) b + +type instance Tangent (RevDiff a b c) = RevDiff a (Tangent b) (Tangent c) + +type instance Dual (RevDiff a b c) = RevDiff a (Dual b) (Dual c) + +-- | Converts a differentiable function into a regular function. +-- +-- ==== __Examples__ +-- +-- >>> import Debug.SimpleExpr (variable) +-- >>> import Debug.DiffExpr (unarySymbolicFunc) +-- +-- >>> :{ +-- differentiableCos_ :: RevDiff t Float Float -> RevDiff t Float Float +-- differentiableCos_ (MkRevDiff v bp) = MkRevDiff (cos v) (bp . negate . (sin v *)) +-- :} +-- +-- >>> call differentiableCos_ 0.0 +-- 1.0 +-- +-- >>> x = variable "x" +-- >>> f = unarySymbolicFunc "f" +-- >>> f x +-- f(x) +-- +-- >>> call f x +-- f(x) +call :: (RevDiff' a a -> RevDiff' a b) -> a -> b +call f = value . f . initDiff + +-- | Converts a differentiable function into into its derivative in the form of +-- multiplicative operator. +-- +-- ==== __Examples__ +-- +-- >>> import Debug.SimpleExpr (variable) +-- >>> import Debug.DiffExpr (unarySymbolicFunc) +-- +-- >>> :{ +-- differentiableSin_ :: RevDiff t Float Float -> RevDiff t Float Float +-- differentiableSin_ (MkRevDiff v bp) = MkRevDiff (sin v) (bp . (cos v *)) +-- :} +-- +-- >>> (derivativeOp differentiableSin_ 0.0) 1.0 +-- 1.0 +-- +-- >>> c = variable "c" +-- >>> x = variable "x" +-- >>> f = unarySymbolicFunc "f" +-- >>> f x +-- f(x) +-- >>> (derivativeOp f x) c +-- f'(x)*c +derivativeOp :: (RevDiff' a a -> RevDiff' a b) -> a -> CT b -> CT a +derivativeOp f = backprop . f . initDiff + +-- | Converts a function into a pair of its value and backpropagation function, +-- which are the lense get and set functions, respectively. +toLensOps :: (RevDiff ca ca a -> RevDiff ca cb b) -> a -> (b, cb -> ca) +toLensOps f x = (y, bp) + where + MkRevDiff y bp = f $ initDiff x + +-- | Creates a differentiable function from a function and its derivative. +-- This is a convenience function for defining new differentiable operations. +-- +-- ==== __Examples__ +-- +-- >>> :{ +-- differentiableCos_ :: RevDiff t Float Float -> RevDiff t Float Float +-- differentiableCos_ = simpleDifferentiableFunc cos (negate . sin) +-- :} +-- +-- >>> call differentiableCos_ 0.0 +-- 1.0 +-- +-- >>> simpleDerivative differentiableCos_ 0.0 +-- -0.0 +simpleDifferentiableFunc :: + (Multiplicative b) => + (b -> b) -> + (b -> b) -> + RevDiff a b b -> + RevDiff a b b +simpleDifferentiableFunc f f' (MkRevDiff x bpc) = MkRevDiff (f x) (\cy -> bpc $ f' x * cy) + +-- | Initializes a `MkRevDiff` instance with given value +-- and identity backpropagation function. +-- This is useful for starting the backpropagation chain. +-- +-- ==== __Examples__ +-- +-- >>> :{ +-- differentiableCos_ :: RevDiff t Float Float -> RevDiff t Float Float +-- differentiableCos_ (MkRevDiff v bp) = MkRevDiff (cos v) (bp . negate . (sin v *)) +-- :} +-- +-- >>> value $ differentiableCos_ (initDiff 0.0) +-- 1.0 +-- +-- >>> backprop (differentiableCos_ (initDiff 0.0)) 1.0 +-- -0.0 +initDiff :: a -> RevDiff b b a +initDiff x = MkRevDiff x id + +-- | Converts a differentiable function into a /law-breaking/ 'Lens'. +-- This is mutually inverse with 'fromLens'. +-- +-- ==== __Examples__ +-- +-- >>> import Optics (Lens', lens, view, set, getting, (%)) +-- >>> import Debug.SimpleExpr (variable, SE) +-- +-- >>> sinLens = toLens sin :: Lens' SE SE +-- >>> x = variable "x" +-- >>> c = variable "c" +-- >>> (view . getting) sinLens x +-- sin(x) +-- >>> set sinLens c x +-- cos(x)*c +-- >>> squareLens = toLens (^2) :: Lens' SE SE +-- >>> (view . getting) (squareLens % sinLens) x +-- sin(x^2) +toLens :: (RevDiff b b a -> RevDiff b d c) -> Lens a b c d +toLens f = lens (value . bp) (backprop . bp) + where + bp = f . initDiff + +-- | Converts a /law-breaking/ 'Lens' into a differentiable function. +-- This is mutually inverse with 'toLens'. +-- +-- ==== __Examples__ +-- +-- >>> import Optics (lens) +-- >>> import Debug.SimpleExpr (variable, SE, simplify) +-- +-- >>> sinV2 = fromLens $ lens sin (\x -> (cos x *)) +-- >>> x = variable "x" +-- >>> c = variable "c" +-- >>> call sinV2 x +-- sin(x) +-- >>> simplify $ simpleDerivative sinV2 x :: SE +-- cos(x) +fromLens :: Lens a (CT a) b (CT b) -> RevDiff' a a -> RevDiff' a b +fromLens l (MkRevDiff x bp) = MkRevDiff ((view . getting) l x) (\cy -> bp $ set l cy x) + +-- | Profunctor instance for `RevDiff`. +instance Profunctor (RevDiff t) where + dimap :: (a -> b) -> (c -> d) -> RevDiff t b c -> RevDiff t a d + dimap f g (MkRevDiff v bp) = MkRevDiff (g v) (bp . f) + +-- | Costrong instance for `RevDiff`. +instance Costrong (RevDiff t) where + unfirst :: RevDiff t (a, d) (b, d) -> RevDiff t a b + unfirst (MkRevDiff v bp) = MkRevDiff (fst v) (bp . (,snd v)) + unsecond :: RevDiff t (d, a) (d, b) -> RevDiff t a b + unsecond (MkRevDiff v bp) = MkRevDiff (snd v) (bp . (fst v,)) + +-- | Type `DifferentiableFunc`@ a b@ may be associated with the differentiable +-- functions from @a@ to @b@. +-- Composition `(.)` of +-- @DifferentiableFunc b c@ and @DifferentiableFunc a b@ is @DifferentiableFunc a c@ +-- by definition. +-- +-- See `fromProfunctors`, `toProfunctors`, `fromVanLaarhoven` and `fromVanLaarhoven` +-- for illustraing how to use this type. +-- +-- ==== __Examples__ +-- +-- >>> :{ +-- differentiableCos_ :: DifferentiableFunc Float Float +-- differentiableCos_ (MkRevDiff x bpc) = MkRevDiff (cos x) (bpc . ((negate $ sin x) *)) +-- :} +-- +-- >>> call differentiableCos_ 0.0 +-- 1.0 +-- +-- >>> simpleDerivative differentiableCos_ 0.0 +-- -0.0 +type DifferentiableFunc a b = forall t. RevDiff t (CT a) a -> RevDiff t (CT b) b + +-- Profunctor and Van Laarhoven representations. + +-- | Transorfms profunctor (Costrong) map into a 'RevDiff' map. +-- Inverse of 'toProfunctors'. +fromProfunctors :: + (forall p. (Costrong p) => p (CT a) a -> p (CT b) b) -> DifferentiableFunc a b +fromProfunctors = id + +-- | Profunctor representation of the `RevDiff` like for lens map in the spirit of optics. +-- Inverse of `fromProfunctors`. +toProfunctors :: + -- (RevDiff a a -> RevDiff a b) -> + -- (RevDiff (CT a) (CT a) a -> RevDiff (CT a) (CT b) b) -> + (Costrong p) => + DifferentiableFunc a b -> + p (CT a) a -> + p (CT b) b +toProfunctors f = unsecond . dimap (uncurry u) (fork id v) + where + v = call f + u = derivativeOp f + +-- Van Laarhoven representation of the `RevDiff` type. + +-- | Converts a Van Laarhoven representation to a function over `RevDiff` types +-- Inverse of `toVanLaarhoven`. +fromVanLaarhoven :: + forall a b. + (forall f. (Functor f) => (b -> f (CT b)) -> a -> f (CT a)) -> + DifferentiableFunc a b +-- RevDiff t a -> +-- RevDiff t b +fromVanLaarhoven vll (MkRevDiff x bpx) = MkRevDiff y (bpx . bp) + where + (y, bp) = getCompose $ vll (\y_ -> Compose (y_, id)) x + +-- | Converts a function over `RevDiff` types into a Van Laarhoven representation. +-- Inverse of `fromVanLaarhoven`. +toVanLaarhoven :: + (Functor f) => + -- (RevDiff a a -> RevDiff a b) -> + DifferentiableFunc a b -> + (b -> f (CT b)) -> + a -> + f (CT a) +toVanLaarhoven g f x = fmap bp (f y) + where + MkRevDiff y bp = g $ initDiff x + +-- -- | Performs backpropagation starting from 'one' and returns the result. +-- -- In particular, +-- -- for constant functions, this will return zero since their derivative is zero. +-- -- +-- -- ==== __Examples__ +-- -- +-- -- >>> diff $ initDiff (42.0 :: Float) :: Float +-- -- 1.0 +-- -- +-- -- >>> diff (constDiff 42.0 :: RevDiff Float Float Float) :: Float +-- -- 0.0 +-- diff :: (Multiplicative b) => RevDiff a b c -> a +-- diff x = backprop x one + +-- | Creates a constant differentiable function. +-- The derivative of a constant function is always zero. +-- +-- ==== __Examples__ +-- +-- >>> value (constDiff 42.0 :: RevDiff' Float Float) +-- 42.0 +-- +-- >>> backprop (constDiff 42.0 :: RevDiff' Float Float) 1.0 +-- 0.0 +constDiff :: (Additive a) => c -> RevDiff a b c +constDiff x = MkRevDiff x (const zero) + +-- | Derivative for a scalar-to-scalar function. +-- +-- ==== __Examples__ +-- +-- >>> import Debug.SimpleExpr (variable, simplify, SimpleExpr) +-- >>> import Debug.DiffExpr (unarySymbolicFunc) +-- +-- >>> simpleDerivative sin (0.0 :: Float) +-- 1.0 +-- +-- >>> x = variable "x" +-- +-- >>> simplify $ simpleDerivative (^ 2) x +-- 2*x +-- +-- >>> f = unarySymbolicFunc "f" +-- +-- >>> simplify $ simpleDerivative f x :: SimpleExpr +-- f'(x) +simpleDerivative :: + forall a b. + (Multiplicative (CT b)) => + (RevDiff' a a -> RevDiff' a b) -> + a -> + CT a +simpleDerivative f x = backprop (f (initDiff x)) one + +-- | Derivative of a function from any type to the same type. +-- The type structure of the input and output values must be the same. +-- +-- ==== __Examples__ +-- +-- >>> f = sin :: TrigField a => a -> a +-- >>> f' = sameTypeDerivative f :: Float -> Float +-- +-- >>> f' 0.0 +-- 1.0 +sameTypeDerivative :: + (Multiplicative (CT a)) => + (RevDiff (CT a) (CT a) a -> RevDiff (CT a) (CT a) a) -> + a -> + CT a +sameTypeDerivative = simpleDerivative + +-- | Returns both the value and the derivative for a scalar-to-scalar function. +-- +-- ==== __Examples__ +-- +-- >>> import Debug.SimpleExpr (variable, simplify, SimpleExpr) +-- >>> import Debug.DiffExpr (unarySymbolicFunc) +-- +-- >>> simpleValueAndDerivative sin (0.0 :: Float) +-- (0.0,1.0) +-- +-- >>> x = variable "x" +-- >>> f = unarySymbolicFunc "f" +-- +-- >>> simplify $ simpleValueAndDerivative f x :: (SimpleExpr, SimpleExpr) +-- (f(x),f'(x)) +simpleValueAndDerivative :: + forall a b. + (Multiplicative (CT b)) => + (RevDiff' a a -> RevDiff' a b) -> + a -> + (b, CT a) +simpleValueAndDerivative f x = (value out, backprop out one) + where + out = f (initDiff x) + +-- | Derivative of a function from any type to any type. +-- The type structure of the input and output values must be specified +-- in the first and second arguments, respectively. +-- The output value type of the derivative is infereced automatically. +-- +-- ==== __Examples__ +-- +-- >>> :{ +-- sphericToVec :: (TrigField a) => +-- (a, a) -> BoxedVector 3 a +-- sphericToVec (theta, phi) = DVGS.fromTuple (cos theta * cos phi, cos theta * sin phi, sin theta) +-- :} +-- +-- >>> sphericToVec' = customArgValDerivative tupleArg boxedVectorVal sphericToVec +-- +-- Here 'tupleArg' manifests that the argument type is a tuple. +-- The second term 'boxedVectorVal' specifies that the output value type is a boxed vector. +-- +-- >>> sphericToVec' (0 :: Float, 0 :: Float) +-- Vector [(0.0,0.0),(0.0,1.0),(1.0,0.0)] +customArgValDerivative :: + (RevDiff (CT a) (CT a) a -> b) -> + (c -> d) -> + (b -> c) -> + a -> + d +customArgValDerivative argTerm valTerm f = valTerm . f . argTerm . initDiff + +-- | Axulary type for building nested argument structure descriptors. +type RevDiffArg a b c d = RevDiff a b c -> d + +-- | Typeclass needed for the automatic agrument descriptor derivation. +-- See instance implementations for `RevDiff`, tuple and `BoxedVector` below. +-- +-- ==== __Examples__ +-- +-- >>> :{ +-- sphericToVector :: (TrigField a) => +-- (a, a) -> BoxedVector 3 a +-- sphericToVector (theta, phi) = +-- DVGS.fromTuple (cos theta * cos phi, cos theta * sin phi, sin theta) +-- :} +-- +-- >>> sphericToVector' = customArgValDerivative autoArg boxedVectorVal sphericToVector +-- >>> sphericToVector' (0 :: Float, 0 :: Float) +-- Vector [(0.0,0.0),(0.0,1.0),(1.0,0.0)] +class + (Additive (DerivativeRoot a), Additive (DerivativeCoarg a)) => + AutoDifferentiableArgument a + where + -- | Differentiable function root + type DerivativeRoot a :: Type + + -- | Differentiable function coargument + type DerivativeCoarg a :: Type + + -- | Differentiable functin argument + type DerivativeArg a :: Type + + -- | Automatic argument descriptor. + autoArg :: RevDiff (DerivativeRoot a) (DerivativeCoarg a) (DerivativeArg a) -> a + +-- | `AutoDifferentiableArgument` instance for the scalar argument term. +instance + (Additive a, Additive b) => + AutoDifferentiableArgument (RevDiff a b c) + where + type DerivativeRoot (RevDiff a b c) = a + type DerivativeCoarg (RevDiff a b c) = b + type DerivativeArg (RevDiff a b c) = c + autoArg = id + +-- | Typeclass needed for the automatic value term derivation. +-- +-- ==== __Examples__ +-- +-- >>> :{ +-- sphericToVector :: (TrigField a) => +-- (a, a) -> BoxedVector 3 a +-- sphericToVector (theta, phi) = DVGS.fromTuple (cos theta * cos phi, cos theta * sin phi, sin theta) +-- :} +-- +-- >>> sphericToVector' = customArgValDerivative tupleArg autoVal sphericToVector +-- >>> sphericToVector' (0 :: Float, 0 :: Float) +-- Vector [(0.0,0.0),(0.0,1.0),(1.0,0.0)] +class AutoDifferentiableValue a where + -- | Differentiable function value type. + type DerivativeValue a :: Type + + -- | Automatic value descriptor. + autoVal :: a -> DerivativeValue a + +-- | Scalar value term. +-- +-- ==== __Examples__ +-- +-- >>> :{ +-- product :: (Multiplicative a) => (a, a) -> a +-- product (x, y) = x * y +-- :} +-- +-- >>> product' = customArgValDerivative tupleArg scalarVal product +-- +-- >>> product' (2 :: Float, 3 :: Float) +-- (3.0,2.0) +-- +-- >>> import Debug.SimpleExpr (variable, simplify, SimpleExpr) +-- >>> x = variable "x" +-- >>> y = variable "y" +-- >>> simplify $ product' (x, y) :: (SimpleExpr, SimpleExpr) +-- (y,x) +scalarVal :: + (Multiplicative b) => + RevDiff a b c -> + a +scalarVal (MkRevDiff _ bp) = bp one + +-- | `AutoDifferentiableValue` instance for the scalar value term. +instance + (Multiplicative b) => + AutoDifferentiableValue (RevDiff a b c) + where + type DerivativeValue (RevDiff a b c) = a + autoVal :: RevDiff a b c -> a + autoVal = scalarVal + +-- | Derivative operator for a function with a specified argument type, +-- but with the value type derived automatically. +-- +-- ==== __Examples__ +-- +-- >>> :{ +-- sphericToVec :: (TrigField a) => +-- (a, a) -> BoxedVector 3 a +-- sphericToVec (theta, phi) = DVGS.fromTuple (cos theta * cos phi, cos theta * sin phi, sin theta) +-- :} +-- +-- >>> sphericToVec' = customArgDerivative tupleArg sphericToVec +-- +-- Here 'tupleArg' indicates that the argument type is a tuple. +-- +-- >>> sphericToVec' (0 :: Float, 0 :: Float) +-- Vector [(0.0,0.0),(0.0,1.0),(1.0,0.0)] +customArgDerivative :: + (AutoDifferentiableValue c) => + (RevDiff (CT a) (CT a) a -> b) -> + (b -> c) -> + a -> + DerivativeValue c +customArgDerivative arg = customArgValDerivative arg autoVal + +-- | Derivative operator for a function with specified argument type +-- but automatically derived value type. +-- +-- ==== __Examples__ +-- +-- >>> :{ +-- sphericToVector :: (TrigField a) => +-- (a, a) -> BoxedVector 3 a +-- sphericToVector (theta, phi) = DVGS.fromTuple (cos theta * cos phi, cos theta * sin phi, sin theta) +-- :} +-- +-- >>> sphericToVector' = customValDerivative boxedVectorVal sphericToVector +-- +-- The term 'boxedVectorVal' specifies that the output value type is a boxed vector. +-- +-- >>> sphericToVector' (0 :: Float, 0 :: Float) +-- Vector [(0.0,0.0),(0.0,1.0),(1.0,0.0)] +customValDerivative :: + ( DerivativeRoot b ~ CT (DerivativeArg b), + DerivativeCoarg b ~ CT (DerivativeArg b), + AutoDifferentiableArgument b + ) => + (c -> d) -> + (b -> c) -> + DerivativeArg b -> + d +customValDerivative = customArgValDerivative autoArg + +-- Scalar + +-- | Scalar (trivial) argument descriptor for differentiable functions. +-- +-- ==== __Examples__ +-- +-- >>> import Debug.DiffExpr (unarySymbolicFunc, SymbolicFunc) +-- >>> import Debug.SimpleExpr (variable, SimpleExpr, simplify, SE) +-- +-- >>> scalarArgDerivative = customArgDerivative scalarArg +-- +-- >>> t = variable "t" +-- >>> :{ +-- v :: SymbolicFunc a => a -> BoxedVector 3 a +-- v t = DVGS.fromTuple ( +-- unarySymbolicFunc "v_x" t, +-- unarySymbolicFunc "v_y" t, +-- unarySymbolicFunc "v_z" t +-- ) +-- :} +-- +-- >>> v t +-- Vector [v_x(t),v_y(t),v_z(t)] +-- +-- >>> v' = simplify . scalarArgDerivative v :: SE -> BoxedVector 3 SE +-- >>> v' t +-- Vector [v_x'(t),v_y'(t),v_z'(t)] +scalarArg :: RevDiff a b c -> RevDiff a b c +scalarArg = id + +-- | Derivative operator for a function from a scalar to any supported value type. +-- +-- ==== __Examples__ +-- +-- >>> import Debug.SimpleExpr (variable, simplify, SE) +-- +-- >>> :{ +-- f :: TrigField a => a -> (a, a) +-- f t = (cos t, sin t) +-- :} +-- +-- >>> f' = scalarArgDerivative f +-- +-- >>> f (0 :: Float) +-- (1.0,0.0) +-- >>> f' (0 :: Float) +-- (-0.0,1.0) +-- +-- >>> t = variable "t" +-- >>> f t +-- (cos(t),sin(t)) +-- >>> simplify $ scalarArgDerivative f t :: (SE, SE) +-- (-(sin(t)),cos(t)) +scalarArgDerivative :: + (AutoDifferentiableValue c) => + (RevDiff' a a -> c) -> + a -> + DerivativeValue c +scalarArgDerivative = customArgValDerivative id autoVal + +-- | Derivative operator for a function +-- from any supported argument type to a scalar value. +-- +-- ==== __Examples__ +-- +-- >>> import Debug.SimpleExpr (variable, simplify, SE) +-- +-- >>> :{ +-- f :: Additive a => (a, a) -> a +-- f (x, y) = x + y +-- :} +-- +-- >>> f (2 :: Float, 3 :: Float) +-- 5.0 +-- >>> x = variable "x" +-- >>> y = variable "y" +-- >>> f (x, y) +-- x+y +-- +-- >>> :{ +-- f' :: (Additive a, Distributive (CT a)) => (a, a) -> (CT a, CT a) +-- f' = scalarValDerivative f +-- :} +-- +-- >>> f' (2 :: Float, 3 :: Float) +-- (1.0,1.0) +-- >>> simplify $ f' (x, y) :: (SE, SE) +-- (1,1) +scalarValDerivative :: + ( DerivativeRoot b ~ CT a, + DerivativeCoarg b ~ CT a, + DerivativeArg b ~ a, + Multiplicative (CT c), + AutoDifferentiableArgument b + ) => + (b -> RevDiff d (CT c) c) -> + a -> + d +scalarValDerivative = customArgValDerivative autoArg scalarVal + +-- RevDiff type instances + +-- | `RevDiff` instance for the `Show` typeclass. +instance (Show (b -> a), Show c) => Show (RevDiff a b c) where + show (MkRevDiff x bp) = "MkRevDiff " ++ show x ++ " " ++ show bp + +-- | Typeclass for the automatic iterrupt of the backpropagation. +-- +-- ==== __Examples__ +-- +-- >>> :{ +-- simpleDerivative +-- (\x -> x * twoArgsDerivativeOverY (+) x (stopDiff (1 :: Float))) +-- (2024 :: Float) +-- :} +-- 1.0 +class StopDiff a b where + -- | Stops differentiation by converting a nested `RevDiff` type + -- into a non-differentiable type. + stopDiff :: a -> b + +-- | Base case: stopping differentiation for the same type. +instance StopDiff a a where + stopDiff = id + +-- | Recursive case: stopping differentiation for `RevDiff` type. +instance + (StopDiff a d, Additive b) => + StopDiff a (RevDiff b c d) + where + stopDiff = constDiff . stopDiff + +-- | Typeclass for creating constant differentiable functions. +class HasConstant a b c d where + constant :: Proxy a -> b -> c -> d + +-- | Base case: constant function for the same type. +instance HasConstant a b a b where + constant _ x _ = x + +-- | Recursive case: constant function for `RevDiff` type. +instance + forall a b c d e f t. + (HasConstant a b c d, Additive t, e ~ CT c, f ~ CT d) => + HasConstant a b (RevDiff t e c) (RevDiff t f d) + where + constant _ x (MkRevDiff v _) = constDiff $ constant (Proxy @a) x v + +-- | Differentiable version of sum `(+)` for the `RevDiff` type. +-- +-- This function implements automatic differentiation for addition by applying +-- the sum rule: +-- \[ +-- \frac{d}{dx} (f(x) + g(x)) = \frac{df(x)}{dx} + \frac{dg(x)}{dx} +-- \]. +-- The gradient flows equally to +-- both operands during backpropagation. +differentiableSum :: + (Additive c) => + RevDiff a (b, b) (c, c) -> + RevDiff a b c +differentiableSum (MkRevDiff (x0, x1) bpc) = + MkRevDiff (x0 + x1) (\cy -> bpc (cy, cy)) + +-- | `Additive` instance for the `RevDiff` type. +instance + (Additive a, Additive c) => + Additive (RevDiff a b c) + where + zero = constDiff zero + (+) = differentiableSum .: twoArgsToTuple + +-- | Differentiable version of subtraction `(-)` for the `RevDiff` type. +-- +-- Implements the difference rule: +-- \[ +-- \frac{d}{dx} (f(x) - g(x)) = \frac{df(x)}{dx} - \frac{dg(x)}{dx}. +-- \] +-- Duringt the backpropagation, the gradient flows positively to the first operand +-- and negatively to the second operand. +differentiableSub :: + (Subtractive b, Subtractive c) => + RevDiff a (b, b) (c, c) -> + RevDiff a b c +differentiableSub (MkRevDiff (x0, x1) bpc) = + MkRevDiff (x0 - x1) (\cy -> bpc (cy, negate cy)) + +-- | Differentiable version of sign change function `negate` for `RevDiff` type. +-- +-- Implements the negation rule: +-- \[ +-- \frac{d}{dx} (-f(x)) = -\frac{df(x)}{dx}. +-- \] +-- The gradient is simply +-- negated during backpropagation. +differentiableNegate :: + (Subtractive a, Subtractive c) => + RevDiff a b c -> + RevDiff a b c +differentiableNegate (MkRevDiff x bp) = MkRevDiff (negate x) (negate . bp) + +-- | `Subtractive` instance for the `RevDiff` type. +instance + ( Additive a, + Subtractive a, + Subtractive b, + Subtractive c + ) => + Subtractive (RevDiff a b c) + where + negate = differentiableNegate + (-) = differentiableSub .: twoArgsToTuple + +-- | Differentiable version of commutative multiplication `(*)` for the `RevDiff` type. +-- +-- Implements the product rule: +-- \[ +-- \frac{d}{dx} (f(x) \cdot g(x)) = f(x) \cdot \frac{d g(x)}{dx} + \frac{df(x)}{dx} \cdot g(x). +-- \] +-- Each operand receives the gradient multiplied by the value of the other operand. +differentiableMult :: + (Multiplicative b) => + RevDiff a (b, b) (b, b) -> + RevDiff a b b +differentiableMult (MkRevDiff (x0, x1) bpc) = + MkRevDiff (x0 * x1) (\cy -> bpc (x1 * cy, x0 * cy)) + +-- | `Multiplicative` instance for the `RevDiff` type. +instance + (Additive a, Multiplicative b) => + Multiplicative (RevDiff a b b) + where + one = constDiff one + (*) = differentiableMult .: twoArgsToTuple + +instance + (MultiplicativeAction Integer b, MultiplicativeAction Integer cb) => + MultiplicativeAction Integer (RevDiff ct cb b) + where + c *| (MkRevDiff x bp) = MkRevDiff (c *| x) (bp . (c *|)) + +-- | Differentiable version of multiplicative action `(*|)` for the `RevDiff` type. +-- +-- Implements the product rule for scalar \( f \) +-- and, for example, vector \( g_i \): +-- +-- \[ +-- \frac{d}{dx} \left( f(x) \cdot g_i(x) \right) = +-- f(x) \cdot \frac{d g_i(x)}{dx} + \frac{df(x)}{dx} \cdot g_i(x). +-- \] +-- Each operand receives the gradient multiplied by the value of the other operand. +differentiableMultAction :: + (MultiplicativeAction a b, MultiplicativeAction a cb, Convolution b cb ca) => + RevDiff ct (ca, cb) (a, b) -> + RevDiff ct cb b +differentiableMultAction (MkRevDiff (x, y) bpc) = + MkRevDiff (x *| y) (\cz -> bpc (y |*| cz, x *| cz)) + +instance + (MultiplicativeAction a b, MultiplicativeAction a cb, Convolution b cb ca, Additive ct) => + MultiplicativeAction (RevDiff ct ca a) (RevDiff ct cb b) + where + (*|) = differentiableMultAction .: twoArgsToTuple + +-- | Differentiable version of convolution `(|*|)` for the `RevDiff` type. +-- +-- Implements the product rule for, for example, vectors +-- \( f_i \) +-- and +-- \( g_i \): +-- +-- \[ +-- \frac{d}{dx} \sum_i f_i(x) \cdot g_i(x) = +-- \sum_i f_i(x) \cdot \frac{d g_i(x)}{dx} + \frac{d f_i(x)}{dx} \cdot g_i(x) +-- \] +-- Each operand receives the gradient multiplied by the value of the other operand. +differentiableConv :: + (Convolution a b c, Convolution cc b ca, Convolution a cc cb) => + RevDiff ct (ca, cb) (a, b) -> + RevDiff ct cc c +differentiableConv (MkRevDiff (x, y) bpc) = + MkRevDiff (x |*| y) (\cz -> bpc (cz |*| y, x |*| cz)) + +instance + (Convolution a b c, Convolution cc b ca, Convolution a cc cb, Additive ct) => + Convolution (RevDiff ct ca a) (RevDiff ct cb b) (RevDiff ct cc c) + where + (|*|) = differentiableConv .: twoArgsToTuple + +-- | Differentiable version of division `(/)` for the `RevDiff` type. +-- +-- Implements the quotient rule: +-- \[ +-- \frac{d}{dx} (f(x)/g(x)) = +-- \frac{\frac{df(x)}{dx} \cdot g(x) - f(x) \cdot \frac{dg(x)}{dx}}{g^2(x)}. +-- \] +-- The numerator receives gradient divided by the denominator, while the +-- denominator receives negative gradient scaled by the quotient divided by itself. +differentiableDiv :: + (Subtractive b, Divisive b) => + RevDiff a (b, b) (b, b) -> + RevDiff a b b +differentiableDiv (MkRevDiff (x0, x1) bpc) = + MkRevDiff (x0 / x1) (\cy -> bpc (cy / x1, negate $ x0 / x1 / x1 * cy)) + +-- | Differentiable version of `recip` for `RevDiff` type. +-- +-- Implements +-- \[ +-- \frac{d}{dx} \frac{1}{f(x)} = -\frac{1}{f^2(x)} \cdot \frac{df(x)}{dx}. +-- \] +-- The gradient is scaled by the negative +-- square of the reciprocal. +differentiableRecip :: + (Divisive b, Subtractive b, IntegerPower b) => + RevDiff a b b -> + RevDiff a b b +differentiableRecip (MkRevDiff x bpc) = MkRevDiff r (bpc . negate . (r ^ 2 *)) + where + r = recip x + +-- | `Divisive` instance for the `RevDiff` type. +instance + (Additive a, Divisive b, Subtractive b, IntegerPower b) => + Divisive (RevDiff a b b) + where + recip = differentiableRecip + (/) = differentiableDiv .: twoArgsToTuple + +-- | Differentiable version of exponentiation `(**)` for the `RevDiff` type. +-- +-- Implements +-- \[ +-- \frac{d}{dx} f^{g(x)}(x) = f^{g(x)}(x) \cdot (\log f(x) \cdot \frac{dg(x)}{dx} + \frac{g(x)}{f(x)} \cdot \frac{df(x)}{dx}), +-- \] +-- handling both base +-- and exponent dependencies in the gradient computation. +differentiablePow :: + (ExpField b) => + RevDiff a (b, b) (b, b) -> + RevDiff a b b +differentiablePow (MkRevDiff (x, p) bpc) = + MkRevDiff xp (\cy -> bpc (p * (x ** (p - one)) * cy, log x * xp * cy)) + where + xp = x ** p + +-- | Differentiable version of `exp` for the `RevDiff` type. +-- +-- Implements +-- \[ +-- \frac{d}{dx} \exp{f(x)} = \exp{f(x)} \cdot \frac{df(x)}{dx}. +-- \] +-- The exponential function is its own derivative, +-- making the gradient computation particularly elegant. +differentiableExp :: + (ExpField b) => + RevDiff a b b -> + RevDiff a b b +differentiableExp (MkRevDiff x bp) = MkRevDiff y (bp . (y *)) + where + y = exp x + +-- | Differentiable version of natural logarithm for the `RevDiff` type. +-- +-- Implements +-- \[ +-- \frac{d}{dx} \log \left| f(x) \right| = \frac{1}{f(x)} \cdot \frac{df(x)}{dx}. +-- \] +-- For real numbers, this computes +-- the derivative of +-- \(\log |x|\), +-- which is defined for all non-zero values. +-- +-- Unsafety note: This function and derivative will raise an error if @f@ is zero, as the +-- logarithm and `recip` from @numhask@ is undefined at zero point. +-- +-- ==== __Examples__ +-- +-- >>> import Debug.SimpleExpr (variable, SE, simplify) +-- +-- >>> simplify $ simpleDerivative differentiableLog (variable "x") :: SE +-- 1/x +differentiableLog :: + (ExpField b) => + RevDiff a b b -> + RevDiff a b b +differentiableLog (MkRevDiff x bp) = MkRevDiff (log x) (bp . (/ x)) + +-- | Differentiable version of `logBase` for the `RevDiff` type. +-- +-- Implements +-- \[ +-- \frac{d}{dx} \log_b f(x) +-- \] +-- where both base and argument may be differentiable. +-- Uses the change of base formula and applies the chain rule appropriately. +differentiableLogBase :: + (ExpField b, IntegerPower b) => + RevDiff a (b, b) (b, b) -> + RevDiff a b b +differentiableLogBase (MkRevDiff (b, x) bpc) = + MkRevDiff + (logX / logB) + (\cy -> bpc (negate $ logX / (logB ^ 2) / b * cy, recip x / logB * cy)) + where + logX = log x + logB = log b + +-- | Differentiable version of `sqrt` for the `RevDiff` type. +-- +-- Implements +-- \[ +-- \frac{d}{dx} \sqrt{f(x)} = \frac{1}{2 \sqrt {f(x)}} \cdot \frac{df(x)}{dx}. +-- The gradient is scaled by the +-- reciprocal of twice the square root of the input. +differentiableSqrt :: + (ExpField b) => + RevDiff a b b -> + RevDiff a b b +differentiableSqrt (MkRevDiff x bp) = MkRevDiff y (\cy -> bp $ recip (two * y) * cy) + where + y = sqrt x + +-- | `ExpField` instance for the `RevDiff` type. +instance + (ExpField b, Additive a, Subtractive a, IntegerPower b) => + ExpField (RevDiff a b b) + where + exp = differentiableExp + log = differentiableLog + (**) = differentiablePow .: twoArgsToTuple + logBase = differentiableLogBase .: twoArgsToTuple + sqrt = differentiableSqrt + +-- | Differentiable version of `atan2` for the `RevDiff` type. +-- +-- Computes the two-argument arctangent function: +-- \[ +-- \mathrm{arctg2}(y, x) = \arctg\left(\frac{y}{x}\right) +-- \] +-- +-- The gradient computation accounts for both arguments using the formula: +-- \[ +-- \frac{d}{dx} \mathrm{arctg2}(f(x),g(x)) = +-- - \frac{g(x)}{f(x)^2+g(x)^2} \cdot \frac{df(x)}{dx} +-- + \frac{f(x)}{f(x)^2+g(x)^2} \cdot \frac{dg(x)}{dx} +-- \] +differentiableAtan2 :: + (TrigField b, IntegerPower b) => + RevDiff a (b, b) (b, b) -> + RevDiff a b b +differentiableAtan2 (MkRevDiff (y, x) bpc) = + MkRevDiff + (atan2 y x) + (\cy -> bpc (x / r2 * cy, negate $ y / r2 * cy)) + where + r2 = x ^ 2 + y ^ 2 + +instance + ( AlgebraicPower Int a, + MultiplicativeAction Int a, + Multiplicative a + ) => + AlgebraicPower Int (RevDiff c a a) + where + x ^^ n = f x -- differentiablePow .: twoArgsToTuple + where + f = + simpleDifferentiableFunc + (^^ n) + (\x' -> n *| (x' ^^ (n - 1))) + +-- (fromIntegral n * integralPow (n - one)) + +instance + ( AlgebraicPower Integer a, + MultiplicativeAction Integer a, + Multiplicative a + ) => + AlgebraicPower Integer (RevDiff c a a) + where + x ^^ n = f x + where + f = + simpleDifferentiableFunc + (^^ n) + (\x' -> n *| (x' ^^ (n - 1))) + +-- | Differentiable version of sine function for the `RevDiff` type. +-- +-- Implements +-- \[ +-- d\frac{d}{dx} \sin f(x) = \cos f(x) * \frac{df(x)}{dx} +-- \] +-- using the standard trigonometric derivative. +-- +-- ==== __Examples__ +-- +-- >>> call differentiableSin 0.0 :: Float +-- 0.0 +-- >>> simpleDerivative differentiableSin 0.0 :: Float +-- 1.0 +differentiableSin :: + (TrigField b) => + RevDiff a b b -> + RevDiff a b b +differentiableSin = simpleDifferentiableFunc sin cos + +-- | Differentiable version of cosine function for the `RevDiff` type. +-- +-- Implements +-- \[ +-- \frac{d}{dx} \cos f(x) = -\sin f(x) \cdot \frac{df(x)}{dx} +-- \] +-- using the standard trigonometric derivative. +-- +-- ==== __Examples__ +-- +-- >>> call differentiableCos 0.0 :: Float +-- 1.0 +-- >>> simpleDerivative differentiableCos 0.0 :: Float +-- -0.0 +differentiableCos :: + (TrigField b) => + RevDiff a b b -> + RevDiff a b b +differentiableCos = simpleDifferentiableFunc cos (negate . sin) + +-- | Differentiable version of tangent function for the `RevDiff` type. +-- +-- Implements +-- \[ +-- \frac{d]{dx} \tg f(x) = +-- \sec^2 f(x) * \frac{df(x)}{dx} = \frac{1}{cos^2 f(x)} \cdot \frac{df(x)}{dx}. +-- \] +-- +-- ==== __Examples__ +-- +-- >>> call differentiableTan 0.0 :: Float +-- 0.0 +-- >>> simpleDerivative differentiableTan 0.0 :: Float +-- 1.0 +differentiableTan :: + (TrigField b, IntegerPower b) => + RevDiff a b b -> + RevDiff a b b +differentiableTan = simpleDifferentiableFunc tan ((^ (-2)) . cos) + +-- | Differentiable version of arcsine function for the `RevDiff` type. +-- +-- Implements +-- \[ +-- \frac{d}{dx} \arcsin f(x) = \frac{1}{\sqrt{1-f^2(x)}} \cdot \frac{df(x)}{dx}. +-- \] +-- +-- ==== __Examples__ +-- +-- >>> call differentiableAsin 0.0 :: Float +-- 0.0 +-- >>> simpleDerivative differentiableAsin 0.0 :: Float +-- 1.0 +differentiableAsin :: + (TrigField b, ExpField b, IntegerPower b) => + RevDiff a b b -> + RevDiff a b b +differentiableAsin = simpleDifferentiableFunc asin (recip . sqrt . (one -) . (^ 2)) + +-- | Differentiable version of arccosine function for the `RevDiff` type. +-- +-- Implements +-- \[ +-- \frac{d}{dx} \arccos f(x) = -\frac{1}{\sqrt{1-f^2(x)}} \cdot \frac{df(x)}{dx}. +-- \] +-- +-- ==== __Examples__ +-- +-- >>> call differentiableAcos 0.0 :: Float +-- 1.5707964 +-- >>> simpleDerivative differentiableAcos 0.0 :: Float +-- -1.0 +differentiableAcos :: + (TrigField b, ExpField b, IntegerPower b) => + RevDiff a b b -> + RevDiff a b b +differentiableAcos = + simpleDifferentiableFunc acos (negate . recip . sqrt . (one -) . (^ 2)) + +-- | Differentiable version of arctangent function for the `RevDiff` type. +-- +-- Implements +-- \[ +-- \frac{d}{dx} \mathrm{arctg} f(x) = \frac{1}{1 + f^2(x)} \cdot \frac{df(x)}{dx}. +-- \] +-- +-- ==== __Examples__ +-- +-- >>> call differentiableAtan 0.0 :: Float +-- 0.0 +-- >>> simpleDerivative differentiableAtan 0.0 :: Float +-- 1.0 +differentiableAtan :: + (TrigField b, IntegerPower b) => + RevDiff a b b -> + RevDiff a b b +differentiableAtan = simpleDifferentiableFunc atan (recip . (one +) . (^ 2)) + +-- | Differentiable version of hyperbolic sine function for the `RevDiff` type. +-- +-- Implements +-- \[ +-- \frac{d}{dx} \sinh f(x) = \cosh f(x) \cdot \frac{df(x)}{dx}. +-- \] +-- +-- ==== __Examples__ +-- +-- >>> call differentiableSinh 0.0 :: Float +-- 0.0 +-- >>> simpleDerivative differentiableSinh 0.0 :: Float +-- 1.0 +differentiableSinh :: + (TrigField b) => + RevDiff a b b -> + RevDiff a b b +differentiableSinh = simpleDifferentiableFunc sinh cosh + +-- | Differentiable version of hyperbolic cosine function for the `RevDiff` type. +-- +-- Implements +-- \[ +-- \frac{d}{dx} \mathrm{csch} f(x) = \mathrm{sh} f(x) \cdot \frac{df(x)}{dx}. +-- \] +-- +-- ==== __Examples__ +-- +-- >>> call differentiableCosh 0.0 :: Float +-- 1.0 +-- >>> simpleDerivative differentiableCosh 0.0 :: Float +-- 0.0 +differentiableCosh :: + (TrigField b) => + RevDiff a b b -> + RevDiff a b b +differentiableCosh = simpleDifferentiableFunc cosh sinh + +-- | Differentiable version of hyperbolic tangent function for the `RevDiff` type. +-- +-- Implements +-- \[ +-- \frac{d}{dx} \mathrm{th} f(x) = +-- \mathrm{sech}^2 f(x) \cdot \frac{df}{dx} = \frac{1}{\mathrm{ch}^2 f(x)} \cdot \frac{df}{dx}. +-- \] +-- +-- ==== __Examples__ +-- +-- >>> call differentiableTanh 0.0 :: Float +-- 0.0 +-- >>> simpleDerivative differentiableTanh 0.0 :: Float +-- 1.0 +differentiableTanh :: + (TrigField b, IntegerPower b) => + RevDiff a b b -> + RevDiff a b b +differentiableTanh = simpleDifferentiableFunc tanh ((^ (-2)) . cosh) + +-- | Differentiable version of inverse hyperbolic sine function for the `RevDiff` type. +-- +-- Implements +-- \[ +-- \DeclareMathOperator{\arcsh}{arcsh} +-- \frac{d}{dx} \arcsh f(x) = \frac{1}{\sqrt{1 + f^2 (x)}} \cdot \frac{df}{dx}. +-- \] +-- +-- ==== __Examples__ +-- +-- >>> call differentiableAsinh 0.0 :: Float +-- 0.0 +-- >>> simpleDerivative differentiableAsinh 0.0 :: Float +-- 1.0 +differentiableAsinh :: + (TrigField b, ExpField b, IntegerPower b) => + RevDiff a b b -> + RevDiff a b b +differentiableAsinh = simpleDifferentiableFunc asinh (recip . sqrt . (one +) . (^ 2)) + +-- | Differentiable version of inverse hyperbolic cosine function for the `RevDiff` type. +-- +-- Implements +-- \[ +-- \DeclareMathOperator{\arcch}{arcch} +-- \frac{d}{dx} \arcch f(x) = \frac{1}{f^2(x) - 1} \cdot \frac{df}{dx}. +-- \] +differentiableAcosh :: + (TrigField b, ExpField b, IntegerPower b) => + RevDiff a b b -> + RevDiff a b b +differentiableAcosh = simpleDifferentiableFunc acosh (recip . sqrt . (one -) . (^ 2)) + +-- | Differentiable version of inverse hyperbolic tangent function for the `RevDiff` type. +-- +-- Implements +-- \[ +-- \frac{d}{dx} \arcth f(x) = \frac{1}{1 - f^2 (x)} \cdot \frac{df}{dx}. +-- +-- ==== __Examples__ +-- +-- >>> call differentiableAtanh 0.0 :: Float +-- 0.0 +-- >>> simpleDerivative differentiableAtanh 0.0 :: Float +-- 1.0 +differentiableAtanh :: + (TrigField b, IntegerPower b) => + RevDiff a b b -> + RevDiff a b b +differentiableAtanh = simpleDifferentiableFunc atanh (recip . (one -) . (^ 2)) + +-- | `TrigField` instance for the `RevDiff` type. +instance + (Additive a, Subtractive a, ExpField b, TrigField b, IntegerPower b) => + TrigField (RevDiff a b b) + where + -- Constants + pi = constDiff pi + + -- Basic trig functions + sin = differentiableSin + cos = differentiableCos + tan = differentiableTan + + -- Inverse trig functions + asin = differentiableAsin + acos = differentiableAcos + atan = differentiableAtan + atan2 = differentiableAtan2 .: twoArgsToTuple + + -- Hyperbolic functions + sinh = differentiableSinh + cosh = differentiableCosh + tanh = differentiableTanh + + -- Inverse hyperbolic functions + asinh = differentiableAsinh + acosh = differentiableAcosh + atanh = differentiableAtanh + +-- | Differentiable version of absolute value function for the `RevDiff` type. +-- +-- Implements +-- \[ +-- \frac{d}{dx} \left_| f(x) \right_| = \sign(f) \cdot \frac{df}{dx}, +-- \] +-- where \( \sign(f) \) is the signum function. +-- The derivative is undefined at zero but returns zero in this implementation. +-- +-- ==== __Examples__ +-- +-- >>> import Debug.SimpleExpr (variable, SE, simplify) +-- +-- >>> simplify $ simpleDerivative differentiableAbs (variable "x") :: SE +-- sign(x) +-- +-- >>> simpleDerivative differentiableAbs (10 :: Float) :: Float +-- 1.0 +-- >>> simpleDerivative differentiableAbs (-10 :: Float) :: Float +-- -1.0 +-- >>> simpleDerivative differentiableAbs (0 :: Float) :: Float +-- 0.0 +differentiableAbs :: + (GHCN.Num b, Multiplicative b) => + RevDiff a b b -> + RevDiff a b b +differentiableAbs (MkRevDiff x bpc) = + MkRevDiff (GHCN.abs x) (bpc . (GHCN.signum x *)) + +-- | Differentiable version of signum function for the `RevDiff` type. +-- +-- The signum function has derivative zero everywhere except at zero (where it's undefined). +-- This implementation returns zero for all inputs, including zero. +-- +-- ==== __Examples__ +-- +-- >>> import Debug.SimpleExpr (variable, SE, simplify) +-- +-- >>> simplify $ simpleDerivative differentiableSign (variable "x") :: SE +-- 0 +-- +-- >>> simpleDerivative differentiableSign (10 :: Float) :: Float +-- 0.0 +-- >>> simpleDerivative differentiableSign (-10 :: Float) :: Float +-- 0.0 +-- >>> simpleDerivative differentiableSign (0 :: Float) :: Float +-- 0.0 +differentiableSign :: + (Additive a, GHCN.Num b) => + RevDiff a b b -> + RevDiff a b b +differentiableSign (MkRevDiff x _) = constDiff $ GHCN.signum x + +-- | `RevDiff` instance for the `GHC.Num.Num` typeclass. +instance + ( Additive a, + Subtractive a, + GHCN.Num b, + Subtractive b, + Multiplicative b + ) => + GHCN.Num (RevDiff a b b) + where + (+) = (GHCN.+) + (-) = (GHCN.-) + (*) = (GHCN.*) + negate = differentiableNegate + abs = differentiableAbs + signum = differentiableSign + fromInteger = constDiff . GHCN.fromInteger + +-- | `RevDiff` instance of the `NumHask.Data.Integral.FromInteger` typeclass. +instance + (FromInteger c, Additive a) => + FromInteger (RevDiff a b c) + where + fromInteger = constDiff . fromInteger + +-- | `RevDiff` and `Int8` instance of the `NumHask.Data.Integral.FromIntegral` typeclass. +instance + (FromIntegral c Int8, Additive a) => + FromIntegral (RevDiff a b c) Int8 + where + fromIntegral = constDiff . NumHask.fromIntegral + +-- | `RevDiff` and `Int16` instance +-- of the `NumHask.Data.Integral.FromIntegral` typeclass. +instance + (FromIntegral c Int16, Additive a) => + FromIntegral (RevDiff a b c) Int16 + where + fromIntegral = constDiff . NumHask.fromIntegral + +-- | `RevDiff` and `Int32` instance +-- of the `NumHask.Data.Integral.FromIntegral` typeclass. +instance + (FromIntegral c Int32, Additive a) => + FromIntegral (RevDiff a b c) Int32 + where + fromIntegral = constDiff . NumHask.fromIntegral + +-- | `RevDiff` and `Int64` instance +-- of the `NumHask.Data.Integral.FromIntegral` typeclass. +instance + (FromIntegral c Int64, Additive a) => + FromIntegral (RevDiff a b c) Int64 + where + fromIntegral = constDiff . NumHask.fromIntegral + +-- | `RevDiff` and `Int` instance +-- of the `NumHask.Data.Integral.FromIntegral` typeclass. +instance + (FromIntegral c Int, Additive a) => + FromIntegral (RevDiff a b c) Int + where + fromIntegral = constDiff . NumHask.fromIntegral + +-- | `RevDiff` and `Word8` instance +-- of the `NumHask.Data.Integral.FromIntegral` typeclass. +instance + (FromIntegral c Word8, Additive a) => + FromIntegral (RevDiff a b c) Word8 + where + fromIntegral = constDiff . NumHask.fromIntegral + +-- | `RevDiff` and `Word16` instance +-- of the `NumHask.Data.Integral.FromIntegral` typeclass. +instance + (FromIntegral c Word16, Additive a) => + FromIntegral (RevDiff a b c) Word16 + where + fromIntegral = constDiff . NumHask.fromIntegral + +-- | `RevDiff` and `Word32` instance +-- of the `NumHask.Data.Integral.FromIntegral` typeclass. +instance + (FromIntegral c Word32, Additive a) => + FromIntegral (RevDiff a b c) Word32 + where + fromIntegral = constDiff . NumHask.fromIntegral + +-- | `RevDiff` and `Word64` instance +-- of the `NumHask.Data.Integral.FromIntegral` typeclass. +instance + (FromIntegral c Word64, Additive a) => + FromIntegral (RevDiff a b c) Word64 + where + fromIntegral = constDiff . NumHask.fromIntegral + +-- | `RevDiff` and `Word` instance +-- of the `NumHask.Data.Integral.FromIntegral` typeclass. +instance + (FromIntegral c Word, Additive a) => + FromIntegral (RevDiff a b c) Word + where + fromIntegral = constDiff . NumHask.fromIntegral + +-- | `RevDiff` and `Integer` instance +-- of the `NumHask.Data.Integral.FromIntegral` typeclass. +instance + (FromIntegral c Integer, Additive a) => + FromIntegral (RevDiff a b c) Integer + where + fromIntegral = constDiff . NumHask.fromIntegral + +-- | `RevDiff` and `Natural` instance +-- of the `NumHask.Data.Integral.FromIntegral` typeclass. +instance + (FromIntegral c Natural, Additive a) => + FromIntegral (RevDiff a b c) Natural + where + fromIntegral = constDiff . NumHask.fromIntegral + +-- | `RevDiff` instance for the `GHC.Real.Fractional` typeclass. +instance + ( Additive a, + Subtractive a, + Subtractive b, + Divisive b, + GHCR.Fractional b, + IntegerPower b + ) => + GHCR.Fractional (RevDiff a b b) + where + (/) = differentiableDiv .: twoArgsToTuple + recip = differentiableRecip + fromRational = constDiff . GHCR.fromRational + +-- | Transforms two `RevDiff` instances into a 'RevDiff' instances with a tuple. +-- Inverese operation is 'tupleArg'. +twoArgsToTuple :: + (Additive a) => + RevDiff a b0 c0 -> + RevDiff a b1 c1 -> + RevDiff a (b0, b1) (c0, c1) +twoArgsToTuple (MkRevDiff x0 bpc0) (MkRevDiff x1 bpc1) = + MkRevDiff (x0, x1) (\(cy0, cy1) -> bpc0 cy0 + bpc1 cy1) + +-- | Tuple argument descriptor for differentiable functions. +-- Transforms a `RevDiff` instances of a tuple into a tuple of `RevDiff` instances. +-- This allows applying differentiable operations to both elements of the tuple. +-- +-- ==== __Examples__ +-- +-- >>> import Debug.SimpleExpr (variable, SE, simplify) +-- >>> import Debug.DiffExpr (SymbolicFunc, unarySymbolicFunc) +-- +-- >>> :{ +-- f :: Multiplicative a => (a, a) -> a +-- f (x, y) = x * y +-- :} +-- +-- >>> :{ +-- f' :: (Distributive a, CT a ~ a) => (a, a) -> (a, a) +-- f' = customArgDerivative tupleArg f +-- :} +-- +-- >>> simplify $ f' (variable "x", variable "y") +-- (y,x) +tupleArg :: + (Additive b0, Additive b1) => + RevDiff a (b0, b1) (c0, c1) -> + (RevDiff a b0 c0, RevDiff a b1 c1) +tupleArg (MkRevDiff (x0, x1) bpc) = + ( MkRevDiff x0 (\cy -> bpc (cy, zero)), + MkRevDiff x1 (\cy -> bpc (zero, cy)) + ) + +-- | Tuple argument descriptor builder. +-- See [this tutorial section] +-- (Numeric-InfBackprop-Tutorial.html#g:sophisticated-45-argument-45-function-45-how-45-it-45-works) +-- for details and examples. +mkTupleArg :: + (Additive b0, Additive b1) => + RevDiffArg a b0 c0 d0 -> + RevDiffArg a b1 c1 d1 -> + RevDiffArg a (b0, b1) (c0, c1) (d0, d1) +mkTupleArg f0 f1 = cross f0 f1 . tupleArg + +-- | Tuple instance for `AutoDifferentiableArgument` typeclass. +-- It makes it possible to differntiate tuple argument funcitons. +instance + ( AutoDifferentiableArgument a0, + AutoDifferentiableArgument a1, + DerivativeRoot a0 ~ DerivativeRoot a1 + ) => + AutoDifferentiableArgument (a0, a1) + where + type DerivativeRoot (a0, a1) = DerivativeRoot a0 + type DerivativeCoarg (a0, a1) = (DerivativeCoarg a0, DerivativeCoarg a1) + type DerivativeArg (a0, a1) = (DerivativeArg a0, DerivativeArg a1) + autoArg :: RevDiff (DerivativeRoot a0) (DerivativeCoarg a0, DerivativeCoarg a1) (DerivativeArg a0, DerivativeArg a1) -> (a0, a1) + autoArg = mkTupleArg autoArg autoArg + +-- | Tuple differentiable value builder +-- See [this tutorial section] +-- (Numeric-InfBackprop-Tutorial.html#g:multivalued-45-function-45-how-45-it-45-works) +-- for details and examples. +mkTupleVal :: (a0 -> b0) -> (a1 -> b1) -> (a0, a1) -> (b0, b1) +mkTupleVal = cross + +-- | Tuple differentiable value descriptor. +-- See [this tutorial section] +-- (Numeric-InfBackprop-Tutorial.html#g:multivalued-45-function-45-how-45-it-45-works) +-- for details and examples. +tupleVal :: + (Multiplicative b0, Multiplicative b1) => + (RevDiff a0 b0 c0, RevDiff a1 b1 c1) -> + (a0, a1) +tupleVal = mkTupleVal scalarVal scalarVal + +-- | Tuple instance for `AutoDifferentiableValue` typeclass. +-- It makes it possible to differntiate tuple value funcitons. +instance + (AutoDifferentiableValue a0, AutoDifferentiableValue a1) => + AutoDifferentiableValue (a0, a1) + where + type DerivativeValue (a0, a1) = (DerivativeValue a0, DerivativeValue a1) + autoVal :: (a0, a1) -> (DerivativeValue a0, DerivativeValue a1) + autoVal = mkTupleVal autoVal autoVal + +-- | Differentiable operator for functions with tuple argument +-- and any supported by `AutoDifferentiableValue` value type. +-- This function is equivalent to 'twoArgsDerivative' up to the curring. +-- +-- ==== __Examples__ +-- +-- >>> import Debug.SimpleExpr (variable, simplify, SE) +-- >>> import Debug.DiffExpr (SymbolicFunc, unarySymbolicFunc) +-- +-- >>> :{ +-- x = variable "x" +-- y = variable "y" +-- f :: SymbolicFunc a => a -> a +-- f = unarySymbolicFunc "f" +-- g :: SymbolicFunc a => a -> a +-- g = unarySymbolicFunc "g" +-- h :: (SymbolicFunc a, Multiplicative a) => (a, a) -> a +-- h (x, y) = f x * g y +-- :} +-- +-- >>> f(x)*g(y) +-- f(x)*g(y) +-- +-- >>> :{ +-- h' :: (SE, SE) -> (SE, SE) +-- h' = simplify . tupleArgDerivative h +-- :} +-- +-- >>> h' (x, y) +-- (f'(x)*g(y),g'(y)*f(x)) +-- +-- >>> :{ +-- h'' :: (SE, SE) -> ((SE, SE), (SE, SE)) +-- h'' = simplify . tupleArgDerivative (tupleArgDerivative h) +-- :} +-- +-- >>> h'' (x, y) +-- ((f''(x)*g(y),g'(y)*f'(x)),(f'(x)*g'(y),g''(y)*f(x))) +tupleArgDerivative :: + (Additive (CT a0), Additive (CT a1), AutoDifferentiableValue b) => + ((RevDiff' (a0, a1) a0, RevDiff' (a0, a1) a1) -> b) -> + (a0, a1) -> + DerivativeValue b +tupleArgDerivative = customArgDerivative tupleArg + +-- | Differentiable operator for functions over tuple argument +-- with respect to the first argument. +-- +-- ==== __Examples__ +-- +-- >>> import Debug.SimpleExpr (variable, simplify, SE) +-- >>> import Debug.DiffExpr (SymbolicFunc, unarySymbolicFunc) +-- +-- >>> :{ +-- x = variable "x" +-- y = variable "y" +-- f :: SymbolicFunc a => a -> a +-- f = unarySymbolicFunc "f" +-- g :: SymbolicFunc a => a -> a +-- g = unarySymbolicFunc "g" +-- h :: (SymbolicFunc a, Multiplicative a) => (a, a) -> a +-- h (x, y) = f x * g y +-- :} +-- +-- >>> f(x)*g(y) +-- f(x)*g(y) +-- +-- >>> :{ +-- h' :: (SE, SE) -> SE +-- h' = simplify . tupleDerivativeOverX h +-- :} +-- +-- >>> h' (x, y) +-- f'(x)*g(y) +-- +-- >>> :{ +-- h'' :: (SE, SE) -> SE +-- h'' = simplify . tupleDerivativeOverX (tupleDerivativeOverX h) +-- :} +-- +-- >>> h'' (x, y) +-- f''(x)*g(y) +tupleDerivativeOverX :: + (AutoDifferentiableValue b, Additive (CT a0)) => + ((RevDiff' a0 a0, RevDiff' a0 a1) -> b) -> + (a0, a1) -> + DerivativeValue b +tupleDerivativeOverX f (x0, x1) = + scalarArgDerivative (\x -> f (x, constDiff x1)) x0 + +-- | Differentiable operator for functions over tuple argument +-- with respect to the second argument. +-- +-- ==== __Examples__ +-- +-- >>> import Debug.SimpleExpr (variable, simplify, SE) +-- >>> import Debug.DiffExpr (SymbolicFunc, unarySymbolicFunc) +-- +-- >>> :{ +-- x = variable "x" +-- y = variable "y" +-- f :: SymbolicFunc a => a -> a +-- f = unarySymbolicFunc "f" +-- g :: SymbolicFunc a => a -> a +-- g = unarySymbolicFunc "g" +-- h :: (SymbolicFunc a, Multiplicative a) => (a, a) -> a +-- h (x, y) = f x * g y +-- :} +-- +-- >>> f(x)*g(y) +-- f(x)*g(y) +-- +-- >>> :{ +-- h' :: (SE, SE) -> SE +-- h' = simplify . tupleDerivativeOverY h +-- :} +-- +-- >>> h' (x, y) +-- g'(y)*f(x) +-- +-- >>> :{ +-- h'' :: (SE, SE) -> SE +-- h'' = simplify . tupleDerivativeOverY (tupleDerivativeOverY h) +-- :} +-- +-- >>> h'' (x, y) +-- g''(y)*f(x) +tupleDerivativeOverY :: + (Additive (CT a1), AutoDifferentiableValue b) => + ((RevDiff' a1 a0, RevDiff' a1 a1) -> b) -> + (a0, a1) -> + DerivativeValue b +tupleDerivativeOverY f (x0, x1) = + scalarArgDerivative (\x -> f (constDiff x0, x)) x1 + +-- | Differentiable operator for functions over two arguments +-- and any supported by 'AutoDifferentiableValue' value type. +-- Equivalent to 'tupleArgDerivative' up to the curring. +-- +-- ==== __Examples__ +-- +-- >>> import Debug.SimpleExpr (variable, simplify, SE) +-- >>> import Debug.DiffExpr (SymbolicFunc, unarySymbolicFunc) +-- +-- >>> :{ +-- x = variable "x" +-- y = variable "y" +-- f :: SymbolicFunc a => a -> a +-- f = unarySymbolicFunc "f" +-- g :: SymbolicFunc a => a -> a +-- g = unarySymbolicFunc "g" +-- h :: (SymbolicFunc a, Multiplicative a) => a -> a -> a +-- h x y = f x * g y +-- :} +-- +-- >>> f(x)*g(y) +-- f(x)*g(y) +-- +-- >>> :{ +-- h' :: SE -> SE -> (SE, SE) +-- h' = simplify . twoArgsDerivative h +-- :} +-- +-- >>> h' x y +-- (f'(x)*g(y),g'(y)*f(x)) +-- +-- >>> :{ +-- h'' :: SE -> SE -> ((SE, SE), (SE, SE)) +-- h'' = simplify . twoArgsDerivative (twoArgsDerivative h) +-- :} +-- +-- >>> h'' x y +-- ((f''(x)*g(y),g'(y)*f'(x)),(f'(x)*g'(y),g''(y)*f(x))) +twoArgsDerivative :: + (Additive (CT a0), Additive (CT a1), AutoDifferentiableValue b) => + (RevDiff' (a0, a1) a0 -> RevDiff' (a0, a1) a1 -> b) -> + a0 -> + a1 -> + DerivativeValue b +twoArgsDerivative f = curry (scalarArgDerivative $ uncurry f . tupleArg) + +-- | Differentiable operator for functions over two arguments +-- with respect to the first argument. +-- Equivalent to `tupleDerivativeOverX` up to the curring. +-- +-- ==== __Examples__ +-- +-- >>> import Debug.SimpleExpr (variable, simplify, SE) +-- >>> import Debug.DiffExpr (SymbolicFunc, unarySymbolicFunc) +-- +-- >>> :{ +-- x = variable "x" +-- y = variable "y" +-- f :: SymbolicFunc a => a -> a +-- f = unarySymbolicFunc "f" +-- g :: SymbolicFunc a => a -> a +-- g = unarySymbolicFunc "g" +-- h :: (SymbolicFunc a, Multiplicative a) => a -> a -> a +-- h x y = f x * g y +-- :} +-- +-- >>> f(x)*g(y) +-- f(x)*g(y) +-- +-- >>> :{ +-- h' :: SE -> SE -> SE +-- h' = simplify . twoArgsDerivativeOverX h +-- :} +-- +-- >>> h' x y +-- f'(x)*g(y) +-- +-- >>> :{ +-- h'' :: SE -> SE -> SE +-- h'' = simplify . twoArgsDerivativeOverX (twoArgsDerivativeOverX h) +-- :} +-- +-- >>> h'' x y +-- f''(x)*g(y) +twoArgsDerivativeOverX :: + (Additive (CT a0), AutoDifferentiableValue b) => + (RevDiff' a0 a0 -> RevDiff' a0 a1 -> b) -> + a0 -> + a1 -> + DerivativeValue b +twoArgsDerivativeOverX f x0 x1 = + scalarArgDerivative (\x -> f x (constDiff x1)) x0 + +-- | Differentiable operator for functions over two arguments +-- with respect to the second argument. +-- Equivalent to `tupleDerivativeOverY` up to the curring. +twoArgsDerivativeOverY :: + (Additive (CT a1), AutoDifferentiableValue b) => + (RevDiff' a1 a0 -> RevDiff' a1 a1 -> b) -> + a0 -> + a1 -> + DerivativeValue b +twoArgsDerivativeOverY f = scalarArgDerivative . f . constDiff + +-- | Differentiable operator for functions with tuple value and any supported by +-- `AutoDifferentiableArgument` argument type. +-- +-- ==== __Examples__ +-- +-- >>> import Debug.SimpleExpr (variable, simplify, SE) +-- +-- >>> :{ +-- f :: TrigField a => a -> (a, a) +-- f x = (sin x, cos x) +-- :} +-- +-- >>> f (variable "x") +-- (sin(x),cos(x)) +-- +-- >>> :{ +-- f' :: SE -> (SE, SE) +-- f' = simplify . tupleValDerivative f +-- :} +-- +-- >>> f' (variable "x") +-- (cos(x),-(sin(x))) +tupleValDerivative :: + ( AutoDifferentiableArgument a, + Multiplicative c0, + Multiplicative c1, + DerivativeCoarg a ~ CT (DerivativeArg a), + DerivativeRoot a ~ CT (DerivativeArg a) + ) => + (a -> (RevDiff b0 c0 d0, RevDiff b1 c1 d1)) -> + DerivativeArg a -> + (b0, b1) +tupleValDerivative = customValDerivative tupleVal + +-- boxedVectorValDerivative :: +-- ( AutoDifferentiableArgument a, +-- Multiplicative c, +-- DerivativeCoarg a ~ CT (DerivativeArg a), +-- DerivativeRoot a ~ CT (DerivativeArg a) +-- ) => +-- (a -> BoxedVector n (RevDiff b c d)) -> +-- DerivativeArg a -> +-- BoxedVector n b +-- boxedVectorValDerivative = customValDerivative boxedVectorVal + +-- Triple + +-- | Differentiable operator for functions over triple arguments +-- with respect to the first argument. +tripleDerivativeOverX :: + (AutoDifferentiableValue b, Additive (CT a0)) => + ((RevDiff' a0 a0, RevDiff' a0 a1, RevDiff' a0 a2) -> b) -> + (a0, a1, a2) -> + DerivativeValue b +tripleDerivativeOverX f (x0, x1, x2) = + scalarArgDerivative + (\x -> f (x, constDiff x1, constDiff x2)) + x0 + +-- | Differentiable operator for functions over triple arguments +-- with respect to the second argument. +tripleDerivativeOverY :: + (AutoDifferentiableValue b, Additive (CT a1)) => + ((RevDiff' a1 a0, RevDiff' a1 a1, RevDiff' a1 a2) -> b) -> + (a0, a1, a2) -> + DerivativeValue b +tripleDerivativeOverY f (x0, x1, x2) = + scalarArgDerivative + (\x -> f (constDiff x0, x, constDiff x2)) + x1 + +-- | Differentiable operator for functions over triple arguments +-- with respect to the third argument. +tripleDerivativeOverZ :: + (AutoDifferentiableValue b, Additive (CT a2)) => + ((RevDiff' a2 a0, RevDiff' a2 a1, RevDiff' a2 a2) -> b) -> + (a0, a1, a2) -> + DerivativeValue b +tripleDerivativeOverZ f (x0, x1, x2) = + scalarArgDerivative + (\x -> f (constDiff x0, constDiff x1, x)) + x2 + +-- | Transforms three `RevDiff` instances into a `RevDiff` instances of a triple. +-- The inverese operation is 'tripleArg'. +threeArgsToTriple :: + (Additive a) => + RevDiff a b0 c0 -> + RevDiff a b1 c1 -> + RevDiff a b2 c2 -> + RevDiff a (b0, b1, b2) (c0, c1, c2) +threeArgsToTriple (MkRevDiff x0 bpc0) (MkRevDiff x1 bpc1) (MkRevDiff x2 bpc2) = + MkRevDiff (x0, x1, x2) (\(cy0, cy1, cy2) -> bpc0 cy0 + bpc1 cy1 + bpc2 cy2) + +-- | Triple argument descriptor for differentiable functions. +-- Transforms a `RevDiff` instances of a triple into a triple of `RevDiff` instances. +-- This allows applying differentiable operations to each element of the triple. +-- +-- ==== __Examples__ +-- +-- >>> import Debug.SimpleExpr (variable, SE, simplify) +-- >>> import Debug.DiffExpr (SymbolicFunc, unarySymbolicFunc) +-- +-- >>> :{ +-- f :: Multiplicative a => (a, a, a) -> a +-- f (x, y, z) = x * y * z +-- :} +-- +-- >>> :{ +-- f' :: (Distributive a, CT a ~ a) => (a, a, a) -> (a, a, a) +-- f' = customArgDerivative tripleArg f +-- :} +-- +-- >>> simplify $ f' (variable "x", variable "y", variable "z") +-- (y*z,x*z,x*y) +tripleArg :: + (Additive b0, Additive b1, Additive b2) => + RevDiff a (b0, b1, b2) (c0, c1, c2) -> + (RevDiff a b0 c0, RevDiff a b1 c1, RevDiff a b2 c2) +tripleArg (MkRevDiff (x0, x1, x2) bpc) = + ( MkRevDiff x0 (\cx -> bpc (cx, zero, zero)), + MkRevDiff x1 (\cy -> bpc (zero, cy, zero)), + MkRevDiff x2 (\cz -> bpc (zero, zero, cz)) + ) + +-- | Triple argument builder. +-- See [this tutorial section] +-- (Numeric-InfBackprop-Tutorial.html#g:sophisticated-45-argument-45-function-45-how-45-it-45-works) +-- for details and examples for the tuple. +mkTripleArg :: + (Additive b0, Additive b1, Additive b2) => + RevDiffArg a b0 c0 d0 -> + RevDiffArg a b1 c1 d1 -> + RevDiffArg a b2 c2 d2 -> + RevDiffArg a (b0, b1, b2) (c0, c1, c2) (d0, d1, d2) +mkTripleArg f0 f1 f2 = cross3 f0 f1 f2 . tripleArg + +-- | Triple instance for `AutoDifferentiableArgument` typeclass. +-- It makes it possible to differntiate triple argument funcitons. +instance + ( AutoDifferentiableArgument a0, + AutoDifferentiableArgument a1, + AutoDifferentiableArgument a2, + DerivativeRoot a0 ~ DerivativeRoot a1, + DerivativeRoot a0 ~ DerivativeRoot a2 + ) => + AutoDifferentiableArgument (a0, a1, a2) + where + type DerivativeRoot (a0, a1, a2) = DerivativeRoot a0 + type DerivativeCoarg (a0, a1, a2) = (DerivativeCoarg a0, DerivativeCoarg a1, DerivativeCoarg a2) + type DerivativeArg (a0, a1, a2) = (DerivativeArg a0, DerivativeArg a1, DerivativeArg a2) + autoArg :: RevDiff (DerivativeRoot a0) (DerivativeCoarg a0, DerivativeCoarg a1, DerivativeCoarg a2) (DerivativeArg a0, DerivativeArg a1, DerivativeArg a2) -> (a0, a1, a2) + autoArg = mkTripleArg autoArg autoArg autoArg + +-- | Triple differentiable value builder +-- See [this tutorial section] +-- (Numeric-InfBackprop-Tutorial.html#g:multivalued-45-function-45-how-45-it-45-works) +-- for details and examples for tuple. +mkTripleVal :: (a0 -> b0) -> (a1 -> b1) -> (a2 -> b2) -> (a0, a1, a2) -> (b0, b1, b2) +mkTripleVal = cross3 + +-- | Triple differentiable value descriptor. +-- See [this tutorial section] +-- (Numeric-InfBackprop-Tutorial.html#g:multivalued-45-function-45-how-45-it-45-works) +-- for details and examples. +tripleVal :: + (Multiplicative b0, Multiplicative b1, Multiplicative b2) => + (RevDiff a0 b0 c0, RevDiff a1 b1 c1, RevDiff a2 b2 c2) -> + (a0, a1, a2) +tripleVal = mkTripleVal scalarVal scalarVal scalarVal + +-- | Triple instance for `AutoDifferentiableValue` typeclass. +instance + ( AutoDifferentiableValue a0, + AutoDifferentiableValue a1, + AutoDifferentiableValue a2 + ) => + AutoDifferentiableValue (a0, a1, a2) + where + type DerivativeValue (a0, a1, a2) = (DerivativeValue a0, DerivativeValue a1, DerivativeValue a2) + autoVal :: (a0, a1, a2) -> (DerivativeValue a0, DerivativeValue a1, DerivativeValue a2) + autoVal = mkTripleVal autoVal autoVal autoVal + +-- | Differentiable operator for functions with triple argument +-- and any supported by `AutoDifferentiableValue` value type. +-- The output is a triple of corresponding partial derivatives. +-- This function is equivalent to 'threeArgsDerivative' up to the curring. +-- +-- ==== __Examples__ +-- +-- >>> import Debug.SimpleExpr (variable, simplify, SE) +-- >>> import Debug.SimpleExpr.Utils.Algebra (AlgebraicPower, square, MultiplicativeAction) +-- >>> import Debug.DiffExpr (SymbolicFunc) +-- +-- +-- >>> :{ +-- x = variable "x" +-- y = variable "y" +-- z = variable "z" +-- norm :: (AlgebraicPower Integer a, Additive a) => (a, a, a) -> a +-- norm (x, y, z) = square x + square y + square z +-- :} +-- +-- >>> norm (x, y, z) +-- ((x^2)+(y^2))+(z^2) +-- +-- >>> :{ +-- norm' :: (SE, SE, SE) -> (SE, SE, SE) +-- norm' = simplify . tripleArgDerivative norm +-- :} +-- +-- >>> simplify $ norm' (x, y, z) +-- (2*x,2*y,2*z) +-- +-- >>> :{ +-- norm'' :: (SE, SE, SE) -> ((SE, SE, SE), (SE, SE, SE), (SE, SE, SE)) +-- norm'' = simplify . tripleArgDerivative (tripleArgDerivative norm) +-- :} +-- +-- >>> norm'' (x, y, z) +-- ((2,0,0),(0,2,0),(0,0,2)) +tripleArgDerivative :: + ( Additive (CT a0), + Additive (CT a1), + Additive (CT a2), + AutoDifferentiableValue b + ) => + ( ( RevDiff' (a0, a1, a2) a0, + RevDiff' (a0, a1, a2) a1, + RevDiff' (a0, a1, a2) a2 + ) -> + b + ) -> + (a0, a1, a2) -> + DerivativeValue b +tripleArgDerivative = customArgDerivative tripleArg + +-- | Differentiable operator for functions over three argument. +-- and any supported by `AutoDifferentiableValue` value type. +-- The output is a triple of corresponding partial derivatives. +-- This function is equivalent to 'tripleArgDerivative' up to the curring. +threeArgsDerivative :: + ( AutoDifferentiableValue b, + Additive (CT a0), + Additive (CT a1), + Additive (CT a2) + ) => + ( RevDiff' (a0, a1, a2) a0 -> + RevDiff' (a0, a1, a2) a1 -> + RevDiff' (a0, a1, a2) a2 -> + b + ) -> + a0 -> + a1 -> + a2 -> + DerivativeValue b +threeArgsDerivative f = curry3 (scalarArgDerivative $ uncurry3 f . tripleArg) + +-- | Differentiable operator for functions over three argument +-- with respect to the first argument. +-- and any supported by `AutoDifferentiableValue` value type. +derivative3ArgsOverX :: + (AutoDifferentiableValue b, Additive (CT a0)) => + (RevDiff' a0 a0 -> RevDiff' a0 a1 -> RevDiff' a0 a2 -> b) -> + a0 -> + a1 -> + a2 -> + DerivativeValue b +derivative3ArgsOverX f x0 x1 x2 = + scalarArgDerivative + (\x0' -> f x0' (constDiff x1) (constDiff x2)) + x0 + +-- | Differentiable operator for functions over three argument +-- with respect to the second argument. +-- and any supported by `AutoDifferentiableValue` value type. +derivative3ArgsOverY :: + (AutoDifferentiableValue b, Additive (CT a1)) => + (RevDiff' a1 a0 -> RevDiff' a1 a1 -> RevDiff' a1 a2 -> b) -> + a0 -> + a1 -> + a2 -> + DerivativeValue b +derivative3ArgsOverY f x0 x1 x2 = + scalarArgDerivative + (\x1' -> f (constDiff x0) x1' (constDiff x2)) + x1 + +-- | Differentiable operator for functions over three argument +-- with respect to the third argument. +-- and any supported by `AutoDifferentiableValue` value type. +derivative3ArgsOverZ :: + (AutoDifferentiableValue b, Additive (CT a2)) => + (RevDiff' a2 a0 -> RevDiff' a2 a1 -> RevDiff' a2 a2 -> b) -> + a0 -> + a1 -> + a2 -> + DerivativeValue b +derivative3ArgsOverZ f x0 x1 = + scalarArgDerivative $ f (constDiff x0) (constDiff x1) + +-- | Differentiable operator for functions with tuple value and any supported by +-- `AutoDifferentiableArgument` argument type. +-- +-- ==== __Examples__ +-- +-- >>> import Debug.SimpleExpr (variable, simplify, SE) +-- +-- >>> :{ +-- f :: (Multiplicative a, IntegerPower a) => a -> (a, a, a) +-- f x = (one, x^1, x^2) +-- :} +-- +-- >>> f (variable "x") +-- (1,x^1,x^2) +-- +-- >>> :{ +-- f' :: SE -> (SE, SE, SE) +-- f' = simplify . tripleValDerivative f +-- :} +-- +-- >>> f' (variable "x") +-- (0,1,2*x) +tripleValDerivative :: + ( AutoDifferentiableArgument a, + Multiplicative c0, + Multiplicative c1, + Multiplicative c2, + DerivativeCoarg a ~ CT (DerivativeArg a), + DerivativeRoot a ~ CT (DerivativeArg a) + ) => + (a -> (RevDiff b0 c0 d0, RevDiff b1 c1 d1, RevDiff b2 c2 d2)) -> + DerivativeArg a -> + (b0, b1, b2) +tripleValDerivative = customValDerivative tripleVal + +-- BoxedVector + +-- | `BoxedVector` differentiable value builder +-- See [this tutorial section] +-- (Numeric-InfBackprop-Tutorial.html#g:multivalued-45-function-45-how-45-it-45-works) +-- for details and examples. +mkBoxedVectorVal :: (a -> b) -> BoxedVector n a -> BoxedVector n b +mkBoxedVectorVal = fmap + +-- | `BoxedVector` instance for `AutoDifferentiableValue` typeclass. +instance + (AutoDifferentiableValue a) => + AutoDifferentiableValue (BoxedVector n a) + where + type DerivativeValue (BoxedVector n a) = BoxedVector n (DerivativeValue a) + autoVal :: BoxedVector n a -> BoxedVector n (DerivativeValue a) + autoVal = mkBoxedVectorVal autoVal + +-- | Boxed array differentiable value descriptor. +-- See [this tutorial section] +-- (Numeric-InfBackprop-Tutorial.html#g:multivalued-45-function-45-how-45-it-45-works) +-- for details and examples. +-- +-- ==== __Examples__ +-- +-- >>> import Debug.SimpleExpr (variable, SE, simplify) +-- >>> import Debug.DiffExpr (unarySymbolicFunc, SymbolicFunc) +-- +-- >>> :{ +-- v :: SymbolicFunc a => a -> BoxedVector 3 a +-- v t = DVGS.fromTuple ( +-- unarySymbolicFunc "v_x" t, +-- unarySymbolicFunc "v_y" t, +-- unarySymbolicFunc "v_z" t +-- ) +-- :} +-- +-- >>> t = variable "t" +-- >>> v t +-- Vector [v_x(t),v_y(t),v_z(t)] +-- +-- >>> v' = simplify . customValDerivative boxedVectorVal v :: SE -> BoxedVector 3 SE +-- >>> v' t +-- Vector [v_x'(t),v_y'(t),v_z'(t)] +boxedVectorVal :: + (Multiplicative b) => + BoxedVector n (RevDiff a b c) -> + BoxedVector n a +boxedVectorVal = mkBoxedVectorVal scalarVal + +-- | Differentiable operator for functions with `BoxedVector` argument +-- and any supported by `AutoDifferentiableValue` value type. +-- The output is a `BoxedVector` instamce of corresponding drivatives. +-- +-- ==== __Examples__ +-- +-- >>> import Debug.SimpleExpr (variable, SE, simplify) +-- >>> import Debug.DiffExpr (unarySymbolicFunc, SymbolicFunc) +-- +-- >>> :{ +-- v :: SymbolicFunc a => a -> BoxedVector 3 a +-- v t = DVGS.fromTuple ( +-- unarySymbolicFunc "v_x" t, +-- unarySymbolicFunc "v_y" t, +-- unarySymbolicFunc "v_z" t +-- ) +-- :} +-- +-- >>> t = variable "t" +-- >>> v t +-- Vector [v_x(t),v_y(t),v_z(t)] +-- +-- >>> v' = simplify . boxedVectorValDerivative v :: SE -> BoxedVector 3 SE +-- >>> v' t +-- Vector [v_x'(t),v_y'(t),v_z'(t)] +boxedVectorValDerivative :: + ( AutoDifferentiableArgument a, + Multiplicative c, + DerivativeCoarg a ~ CT (DerivativeArg a), + DerivativeRoot a ~ CT (DerivativeArg a) + ) => + (a -> BoxedVector n (RevDiff b c d)) -> + DerivativeArg a -> + BoxedVector n b +boxedVectorValDerivative = customValDerivative boxedVectorVal + +-- | Boxed vector argument descriptor for differentiable functions. +-- Transforms a `RevDiff` instances of a boxed vector into a boxed vectror +-- of `RevDiff` instances. +-- This allows applying differentiable operations to each element of the boxed Vector. +-- +-- ==== __Examples__ +-- +-- >>> import Debug.SimpleExpr (variable, SE, simplify) +-- >>> import Debug.DiffExpr (SymbolicFunc, unarySymbolicFunc) +-- +-- >>> :{ +-- f :: Additive a => BoxedVector 3 a -> a +-- f = boxedVectorSum +-- :} +-- +-- >>> :{ +-- f' :: (Distributive a, CT a ~ a) => BoxedVector 3 a -> BoxedVector 3 a +-- f' = customArgDerivative boxedVectorArg f +-- :} +-- +-- >>> simplify $ f' (DVGS.fromTuple (variable "x", variable "y", variable "z")) +-- Vector [1,1,1] +boxedVectorArg :: + (Additive b, KnownNat n) => + RevDiff a (BoxedVector n b) (BoxedVector n c) -> + BoxedVector n (RevDiff a b c) +boxedVectorArg (MkRevDiff array bpc) = DVGS.generate $ \k -> + MkRevDiff (DVGS.index array k) (bpc . boxedVectorBasis k zero) + +-- unpackBoxedVector :: +-- (Additive a, KnownNat n) => +-- BoxedVector n (RevDiff a b c) -> +-- RevDiff a (BoxedVector n b) (BoxedVector n c) +-- unpackBoxedVector array = +-- MkRevDiff' +-- (fmap value array) +-- (boxedVectorSum . (fmap backprop array <*>)) + +-- | `BoxedVector` argument descriptor builder. +mkBoxedVectorArg :: + (Additive b, KnownNat n) => + RevDiffArg a b c d -> + RevDiffArg a (BoxedVector n b) (BoxedVector n c) (BoxedVector n d) +mkBoxedVectorArg f = fmap f . boxedVectorArg + +-- | `BoxedVector` instance for `AutoDifferentiableArgument` typeclass. +instance + ( AutoDifferentiableArgument a, + KnownNat n + ) => + AutoDifferentiableArgument (BoxedVector n a) + where + type DerivativeRoot (BoxedVector n a) = DerivativeRoot a + type DerivativeCoarg (BoxedVector n a) = BoxedVector n (DerivativeCoarg a) + type DerivativeArg (BoxedVector n a) = BoxedVector n (DerivativeArg a) + autoArg :: RevDiff (DerivativeRoot a) (BoxedVector n (DerivativeCoarg a)) (BoxedVector n (DerivativeArg a)) -> BoxedVector n a + autoArg = mkBoxedVectorArg autoArg + +-- | Differentiable operator for functions with boxed array argument +-- and any supported by `AutoDifferentiableValue` value type. +-- The output is a boxed array of corresponding partial derivatives (i.e. gradient). +-- +-- ==== __Examples__ +-- +-- >>> import Debug.SimpleExpr (variable, simplify, SE) +-- >>> import Debug.DiffExpr (SymbolicFunc) +-- >>> import Numeric.InfBackprop.Utils.SizedVector (BoxedVector, boxedVectorSum) +-- >>> import Debug.SimpleExpr.Utils.Algebra (AlgebraicPower, (^)) +-- +-- >>> :{ +-- x = variable "x" +-- y = variable "y" +-- z = variable "z" +-- r = DVGS.fromTuple (x, y, z) :: BoxedVector 3 SE +-- norm2 :: (AlgebraicPower Integer a, Additive a) => BoxedVector 3 a -> a +-- norm2 v = boxedVectorSum (v^2) +-- :} +-- +-- >>> simplify $ norm2 r +-- ((x^2)+(y^2))+(z^2) +-- +-- >>> :{ +-- norm2' :: BoxedVector 3 SE -> BoxedVector 3 SE +-- norm2' = simplify . boxedVectorArgDerivative norm2 +-- :} +-- +-- >>> norm2' r +-- Vector [2*x,2*y,2*z] +-- +-- >>> :{ +-- norm2'' :: BoxedVector 3 SE -> BoxedVector 3 (BoxedVector 3 SE) +-- norm2'' = simplify . boxedVectorArgDerivative (boxedVectorArgDerivative norm2) +-- :} +-- +-- >>> norm2'' r +-- Vector [Vector [2,0,0],Vector [0,2,0],Vector [0,0,2]] +boxedVectorArgDerivative :: + (KnownNat n, AutoDifferentiableValue b, Additive (CT a)) => + (BoxedVector n (RevDiff' (BoxedVector n a) a) -> b) -> + BoxedVector n a -> + DerivativeValue b +boxedVectorArgDerivative = customArgDerivative boxedVectorArg + +-- instance (HasSum (BoxedVector n c) d, KnownNat n) => +-- HasSum (RevDiff a (BoxedVector n b) (BoxedVector n c)) (RevDiff a b d) where +-- sum (MkRevDiff vec bp) = MkRevDiff' (sum vec) (bp . DVGS.replicate) + +-- ** Stream + +-- | Stream differentiable value builder +-- See [this tutorial section] +-- (Numeric-InfBackprop-Tutorial.html#g:multivalued-45-function-45-how-45-it-45-works) +-- for details and examples. +mkStreamVal :: (a -> b) -> Stream a -> Stream b +mkStreamVal = fmap + +-- | Stream value structure for differentiable functions. +-- +-- ==== __Examples__ +-- +-- >>> import GHC.Base ((<>)) +-- >>> import Data.Stream (Stream, fromList, take) +-- >>> import Debug.SimpleExpr (variable, SE, simplify) +-- >>> import Debug.DiffExpr (unarySymbolicFunc, SymbolicFunc) +-- +-- >>> :{ +-- s :: SymbolicFunc a => a -> Stream a +-- s t = fromList [unarySymbolicFunc ("s_" <> show n) t | n <- [0..]] +-- :} +-- +-- >>> t = variable "t" +-- >>> take 5 (s t) +-- [s_0(t),s_1(t),s_2(t),s_3(t),s_4(t)] +-- +-- >>> :{ +-- s' :: SE -> Stream SE +-- s' = simplify . customValDerivative streamVal s +-- :} +-- +-- >>> take 5 (s' t) +-- [s_0'(t),s_1'(t),s_2'(t),s_3'(t),s_4'(t)] +streamVal :: + (Multiplicative b) => + Stream (RevDiff a b c) -> + Stream a +streamVal = mkStreamVal scalarVal + +-- | `Stream` instance for `AutoDifferentiableValue` typeclass. +instance + (AutoDifferentiableValue a) => + AutoDifferentiableValue (Stream a) + where + type DerivativeValue (Stream a) = Stream (DerivativeValue a) + autoVal :: Stream a -> Stream (DerivativeValue a) + autoVal = mkStreamVal autoVal + +-- | Derivative operator for a function from any supported argument type to a Stream. +streamValDerivative :: + ( AutoDifferentiableArgument a, + Multiplicative c, + DerivativeCoarg a ~ CT (DerivativeArg a), + DerivativeRoot a ~ CT (DerivativeArg a) + ) => + (a -> Stream (RevDiff b c d)) -> + DerivativeArg a -> + Stream b +streamValDerivative = customValDerivative streamVal + +-- | Stream argument descriptor for differentiable functions. +-- Transforms a `RevDiff` instances of a stream into a stream of `RevDiff` instances. +-- This allows applying differentiable operations to each element of the Stream. +-- +-- ==== __Examples__ +-- +-- >>> import Debug.SimpleExpr (variable, SE, simplify) +-- >>> import GHC.Base ((<>)) +-- +-- >>> :{ +-- f :: Additive a => Stream a -> a +-- f = NumHask.sum . Data.Stream.take 4 :: Additive a => Data.Stream.Stream a -> a +-- :} +-- +-- >>> :{ +-- f' :: (Distributive a, CT a ~ a) => Stream a -> FiniteSupportStream a +-- f' = customArgDerivative streamArg f +-- :} +-- +-- >>> s = Data.Stream.fromList [variable ("s_" <> show n) | n <- [0 :: Int ..]] :: Data.Stream.Stream SE +-- >>> simplify $ f' s +-- [1,1,1,1,0,0,0,... +streamArg :: + (Additive b) => + RevDiff a (FiniteSupportStream b) (Stream c) -> + Stream (RevDiff a b c) +streamArg (MkRevDiff x bpc) = + DS.Cons + (MkRevDiff x_head bpc_head) + (streamArg (MkRevDiff x_tail bpc_tail)) + where + x_head = DS.head x + x_tail = DS.tail x + bpc_head = bpc . singleton + bpc_tail = bpc . cons zero + +-- | Stream argument builder. +-- See [this tutorial section] +-- (Numeric-InfBackprop-Tutorial.html#g:sophisticated-45-argument-45-function-45-how-45-it-45-works) +-- for details and examples for the tuple. +mkStreamArg :: + (Additive b) => + (RevDiff a b c -> d) -> + RevDiff a (FiniteSupportStream b) (Stream c) -> + Stream d +mkStreamArg f = fmap f . streamArg + +-- | `Stream` instance for `AutoDifferentiableArgument` typeclass. +instance + (AutoDifferentiableArgument a) => + AutoDifferentiableArgument (Stream a) + where + type DerivativeRoot (Stream a) = DerivativeRoot a + type DerivativeCoarg (Stream a) = FiniteSupportStream (DerivativeCoarg a) + type DerivativeArg (Stream a) = Stream (DerivativeArg a) + autoArg :: RevDiff (DerivativeRoot a) (FiniteSupportStream (DerivativeCoarg a)) (Stream (DerivativeArg a)) -> Stream a + autoArg = mkStreamArg autoArg + +-- | Differentiable operator for functions with `Stream` argument +-- and any supported by `AutoDifferentiableValue` value type. +-- The output is a boxed array of corresponding partial derivatives (i.e. gradient). +-- +-- ==== __Examples__ +-- +-- >>> import GHC.Base ((<>)) +-- >>> import Debug.SimpleExpr (variable, simplify, SE) +-- >>> import Debug.DiffExpr (SymbolicFunc) +-- >>> import Data.Stream (Stream, fromList, take) +-- +-- >>> s = fromList [variable ("s_" <> show n) | n <- [0 :: Int ..]] :: Stream SE +-- +-- >>> take4Sum = NumHask.sum . take 4 :: Additive a => Stream a -> a +-- >>> simplify $ take4Sum s :: SE +-- s_0+(s_1+(s_2+s_3)) +-- +-- >>> :{ +-- take4Sum' :: (Distributive a, CT a ~ a) => +-- Stream a -> FiniteSupportStream (CT a) +-- take4Sum' = streamArgDerivative take4Sum +-- :} +-- +-- >>> simplify $ take4Sum' s +-- [1,1,1,1,0,0,0,... +-- +-- >>> :{ +-- take4Sum'' :: (Distributive a, CT a ~ a) => +-- Stream a -> FiniteSupportStream (FiniteSupportStream (CT a)) +-- take4Sum'' = streamArgDerivative (streamArgDerivative take4Sum) +-- :} +-- +-- >>> simplify $ take4Sum'' s +-- [[0,0,0,...,[0,0,0,...,[0,0,0,...,... +streamArgDerivative :: + (AutoDifferentiableValue b, Additive (CT a)) => + (Stream (RevDiff' (Stream a) a) -> b) -> + Stream a -> + DerivativeValue b +streamArgDerivative = customArgDerivative streamArg + +-- FiniteSupportStream + +-- | Finite support stream differentiable value builder +-- See [this tutorial section] +-- (Numeric-InfBackprop-Tutorial.html#g:multivalued-45-function-45-how-45-it-45-works) +-- for details and examples. +-- It is expected that the argument function is linear or at least maps zero to zero. +mkFiniteSupportStreamVal :: (a -> b) -> FiniteSupportStream a -> FiniteSupportStream b +mkFiniteSupportStreamVal = unsafeMap + +-- | Finite support stream value structure for differentiable functions. +-- +-- ==== __Examples__ +-- +-- >>> import Debug.SimpleExpr (variable, SE, simplify) +-- >>> import Debug.DiffExpr (unarySymbolicFunc, SymbolicFunc) +-- >>> import Data.FiniteSupportStream (unsafeFromList, FiniteSupportStream) +-- +-- >>> :{ +-- fss :: (Multiplicative a, IntegerPower a) => +-- a -> FiniteSupportStream a +-- fss t = unsafeFromList [t^3, t^2, t, one] +-- :} +-- +-- >>> t = variable "t" +-- >>> fss t +-- [t^3,t^2,t,1,0,0,0,... +-- +-- >>> :{ +-- fss' :: SE -> FiniteSupportStream SE +-- fss' = simplify . customValDerivative finiteSupportStreamVal fss +-- :} +-- +-- >>> (fss' t) +-- [3*(t^2),2*t,1,0,0,0,... +finiteSupportStreamVal :: + (Multiplicative b) => + FiniteSupportStream (RevDiff a b c) -> + FiniteSupportStream a +finiteSupportStreamVal = mkFiniteSupportStreamVal scalarVal + +-- | `FiniteSupportStream` instance for `AutoDifferentiableValue` typeclass. +instance + (AutoDifferentiableValue a) => + AutoDifferentiableValue (FiniteSupportStream a) + where + type DerivativeValue (FiniteSupportStream a) = FiniteSupportStream (DerivativeValue a) + autoVal :: FiniteSupportStream a -> FiniteSupportStream (DerivativeValue a) + autoVal = mkFiniteSupportStreamVal autoVal + +-- | Derivative operator for a function from any supported argument type to +-- a `FiniteSupportStream` instance. +-- +-- ==== __Examples__ +-- +-- >>> import Debug.SimpleExpr (variable, SE, simplify) +-- >>> import Debug.DiffExpr (unarySymbolicFunc, SymbolicFunc) +-- >>> import Data.FiniteSupportStream (unsafeFromList, FiniteSupportStream) +-- +-- >>> :{ +-- fss :: (Multiplicative a, IntegerPower a) => +-- a -> FiniteSupportStream a +-- fss t = unsafeFromList [t^3, t^2, t, one] +-- :} +-- +-- >>> t = variable "t" +-- >>> fss t +-- [t^3,t^2,t,1,0,0,0,... +-- +-- >>> :{ +-- fss' :: SE -> FiniteSupportStream SE +-- fss' = simplify . finiteSupportStreamValDerivative fss +-- :} +-- +-- >>> fss' t +-- [3*(t^2),2*t,1,0,0,0,... +finiteSupportStreamValDerivative :: + ( AutoDifferentiableArgument a, + Multiplicative c, + DerivativeCoarg a ~ CT (DerivativeArg a), + DerivativeRoot a ~ CT (DerivativeArg a) + ) => + (a -> FiniteSupportStream (RevDiff b c d)) -> + DerivativeArg a -> + FiniteSupportStream b +finiteSupportStreamValDerivative = customValDerivative finiteSupportStreamVal + +-- | Finite support stream argument descriptor for differentiable functions. +-- Transforms a `RevDiff` instances of a finite support stream into +-- a finite support stream of `RevDiff` instances. +-- +-- ==== __Examples__ +-- +-- >>> import Debug.SimpleExpr (variable, SE, simplify) +-- >>> import Data.FiniteSupportStream (unsafeFromList, toVector) +-- +-- >>> :{ +-- f :: Additive a => FiniteSupportStream a -> a +-- f = NumHask.sum . toVector +-- :} +-- +-- >>> f (unsafeFromList [1, 2, 3]) +-- 6 +-- +-- >>> :{ +-- f' :: (Distributive a, CT a ~ a) => FiniteSupportStream a -> Stream a +-- f' = customArgDerivative finiteSupportStreamArg f +-- :} +-- +-- >>> Data.Stream.take 5 $ f' (unsafeFromList [1, 2, 3]) +-- [1,1,1,0,0] +finiteSupportStreamArg :: + (Additive b) => + RevDiff a (Stream b) (FiniteSupportStream c) -> + FiniteSupportStream (RevDiff a b c) +finiteSupportStreamArg (MkRevDiff (MkFiniteSupportStream arrX) bpc) = + MkFiniteSupportStream $ DV.imap f arrX + where + f i x = MkRevDiff x (bpc . cStream i) + cStream i cy = go 0 + where + go n = DS.Cons (if i == n then cy else zero) (go (n + 1)) + +-- cons +-- (MkRevDiff' x_head bpc_head) +-- (finiteSupportStreamArg (MkRevDiff' x_tail bpc_tail)) +-- where +-- x_head = trace "taking head" $ head x +-- x_tail = trace "taking tail" $ tail x +-- bpc_head = trace "taking bpc_head" $ bpc . DS.fromList . (: []) +-- bpc_tail = trace "taking bpc_tail" $ bpc . DS.Cons zero + +-- | Finite support stream argument descriptor builder. +-- See [this tutorial section] +-- (Numeric-InfBackprop-Tutorial.html#g:multivalued-45-function-45-how-45-it-45-works) +-- for details and examples. +-- It is expected that the argument function is linear or at least maps zero to zero. +mkFiniteSupportStreamArg :: + (Additive b) => + (RevDiff a b c -> d) -> + RevDiff a (Stream b) (FiniteSupportStream c) -> + FiniteSupportStream d +mkFiniteSupportStreamArg f = unsafeMap f . finiteSupportStreamArg + +-- | `FiniteSupportStream` instance for `AutoDifferentiableArgument` typeclass. +instance + (AutoDifferentiableArgument a) => + AutoDifferentiableArgument (FiniteSupportStream a) + where + type DerivativeRoot (FiniteSupportStream a) = DerivativeRoot a + type DerivativeCoarg (FiniteSupportStream a) = Stream (DerivativeCoarg a) + type DerivativeArg (FiniteSupportStream a) = FiniteSupportStream (DerivativeArg a) + autoArg :: RevDiff (DerivativeRoot a) (Stream (DerivativeCoarg a)) (FiniteSupportStream (DerivativeArg a)) -> FiniteSupportStream a + autoArg = undefined + +-- | Differentiable operator for functions that take a `FiniteSupportStream` argument +-- and return any value type supported by `AutoDifferentiableValue`. +-- The output is a stream of corresponding partial derivatives, +-- computing the gradient of the function with respect to each stream element. +-- See also +-- ["Tangent and Cotangent Spaces" tutorial section](Numeric-InfBackprop-Tutorial.html#g:how-45-it-45-works-45-tangent-45-space) +-- for the connection beetwen streams and finite support streams. +-- +-- ==== __Examples__ +-- +-- >>> import Debug.SimpleExpr (variable, simplify, SE) +-- >>> import Debug.DiffExpr (SymbolicFunc) +-- >>> import Data.Stream (Stream, take) +-- >>> import Data.FiniteSupportStream (FiniteSupportStream, unsafeFromList, toVector) +-- >>> import NumHask (sum) +-- +-- Define a finite support stream with support length 4 containing 4 symbolic variables. +-- +-- >>> s = unsafeFromList [variable "s_0", variable "s_1", variable "s_2", variable "s_3"] :: FiniteSupportStream SE +-- >>> s +-- [s_0,s_1,s_2,s_3,0,0,0,... +-- +-- Now we'll define a function that sums all elements of a finite support stream. +-- +-- >>> finiteSupportStreamSum = sum . toVector :: Additive a => FiniteSupportStream a -> a +-- >>> simplify $ finiteSupportStreamSum s :: SE +-- s_0+(s_1+(s_2+s_3)) +-- +-- We compute the gradient +-- of this function. +-- +-- >>> :{ +-- finiteSupportStreamSum' :: (Distributive a, CT a ~ a) => +-- FiniteSupportStream a -> Stream (CT a) +-- finiteSupportStreamSum' = finiteSupportStreamArgDerivative finiteSupportStreamSum +-- :} +-- +-- Let's compute the gradient at point @s@. It is an infinite stream and we take first 7 elements: +-- +-- >>> take 7 $ simplify $ finiteSupportStreamSum' s +-- [1,1,1,1,0,0,0] +-- +-- As expected, +-- the gradient is a stream with 1's in the first four positions (corresponding +-- to our four variables and the fixed support length 4) and 0's elsewhere: +-- +-- We can compute the second derivative (Hessian matrix) that is stream of streams +-- in our case. +-- +-- >>> :{ +-- finiteSupportStreamSum'' :: (Distributive a, CT a ~ a) => +-- FiniteSupportStream a -> Stream (Stream (CT a)) +-- finiteSupportStreamSum'' = finiteSupportStreamArgDerivative (finiteSupportStreamArgDerivative finiteSupportStreamSum) +-- :} +-- +-- All second derivatives should all be zero. We take first 7 rows and 4 columns of the inifinite Hessian matrix: +-- +-- >>> take 7 $ fmap (take 4) $ simplify $ finiteSupportStreamSum'' s +-- [[0,0,0,0],[0,0,0,0],[0,0,0,0],[0,0,0,0],[0,0,0,0],[0,0,0,0],[0,0,0,0]] +finiteSupportStreamArgDerivative :: + (AutoDifferentiableValue b, Additive (CT a)) => + (FiniteSupportStream (RevDiff' (FiniteSupportStream a) a) -> b) -> + FiniteSupportStream a -> + DerivativeValue b +finiteSupportStreamArgDerivative = customArgDerivative finiteSupportStreamArg + +-- | Maybe differentiable value builder. +-- Creates a mapping function for Maybe types. +-- See [this tutorial section] +-- (Numeric-InfBackprop-Tutorial.html#g:multivalued-45-function-45-how-45-it-45-works) +-- for details and examples. +mkMaybeVal :: (a -> b) -> Maybe a -> Maybe b +mkMaybeVal = fmap + +-- | `Maybe` value structure for differentiable functions. +-- Extracts the derivative with respect to the original function for `Maybe` types. +-- +-- ==== __Examples__ +-- +-- >>> :{ +-- class SafeRecip a where +-- safeRecip :: a -> Maybe a +-- instance SafeRecip Float where +-- safeRecip x = if x == 0.0 then Nothing else Just (recip x) +-- instance (SafeRecip b, Subtractive b, Multiplicative b, IntegerPower b) => +-- SafeRecip (RevDiff a b b) where +-- safeRecip (MkRevDiff v bp) = +-- fmap (\r -> MkRevDiff r (bp . negate . (r^2 *))) (safeRecip v) +-- :} +-- +-- >>> safeRecip (2.0 :: Float) :: Maybe Float +-- Just 0.5 +-- >>> safeRecip (0.0 :: Float) :: Maybe Float +-- Nothing +-- +-- >>> customValDerivative maybeVal safeRecip (2.0 :: Float) +-- Just (-0.25) +-- >>> customValDerivative maybeVal safeRecip (0.0 :: Float) +-- Nothing +maybeVal :: + (Multiplicative b) => + Maybe (RevDiff a b c) -> + Maybe a +maybeVal = mkMaybeVal scalarVal + +-- | `Maybe` instance of `AutoDifferentiableValue`. +instance + (AutoDifferentiableValue a) => + AutoDifferentiableValue (Maybe a) + where + type DerivativeValue (Maybe a) = Maybe (DerivativeValue a) + autoVal :: Maybe a -> Maybe (DerivativeValue a) + autoVal = mkMaybeVal autoVal + +-- | Argument descriptor for differentiable functions with optional argument. +-- Transforms a `RevDiff` instances of an otional type into +-- an optional of `RevDiff` instances. +-- This allows applying differentiable operations to the optiona value. + +-- | Argument descriptor for differentiable functions with optional (`Maybe`) values. +-- +-- Transforms a `RevDiff` instance containing an optional type into an optional +-- `RevDiff` instance. This transformation enables applying differentiable +-- operations to values that may or may not be present, while preserving +-- gradient flow when values exist. +-- +-- When the wrapped value is `Just x`, the function extracts the value and +-- wraps it in a new `RevDiff` instance with appropriately transformed +-- backpropagation. When the value is `Nothing`, the result is `Nothing`, +-- effectively short-circuiting the computation. +-- +-- ==== __Examples__ +-- +-- >>> :{ +-- f :: Additive a => Maybe a -> a +-- f (Just x) = x +-- f Nothing = zero +-- :} +-- +-- >>> customArgDerivative maybeArg f (Just 3 :: Maybe Float) :: Maybe Float +-- Just 1.0 +maybeArg :: RevDiff a (Maybe b) (Maybe c) -> Maybe (RevDiff a b c) +maybeArg (MkRevDiff maybeX bpc) = case maybeX of + Just x -> Just (MkRevDiff x (bpc . Just)) + Nothing -> Nothing + +-- | Maybe argument builder. +-- Applies a function to `Maybe` value obtained from a `RevDiff`. +mkMaybeArg :: + (RevDiff a b c -> d) -> RevDiff a (Maybe b) (Maybe c) -> Maybe d +mkMaybeArg f = fmap f . maybeArg + +-- | `Maybe` instance of `AutoDifferentiableArgument`. +instance + (AutoDifferentiableArgument a) => + AutoDifferentiableArgument (Maybe a) + where + type DerivativeRoot (Maybe a) = DerivativeRoot a + type DerivativeCoarg (Maybe a) = Maybe (DerivativeCoarg a) + type DerivativeArg (Maybe a) = Maybe (DerivativeArg a) + autoArg :: RevDiff (DerivativeRoot a) (Maybe (DerivativeCoarg a)) (Maybe (DerivativeArg a)) -> Maybe a + autoArg = mkMaybeArg autoArg + +-- | Differentiable operator for functions that take a `Maybe` (a value or none) argument +-- and return any value type supported by `AutoDifferentiableValue`. +-- The output is `Maybe` of corresponding derivatives over the inner type. +-- +-- ==== __Examples__ +-- +-- >>> import Debug.SimpleExpr (variable, simplify, SE) +-- >>> import Debug.DiffExpr (SymbolicFunc) +-- >>> import qualified GHC.Num as GHCN +-- +-- >>> :{ +-- maybeF :: TrigField a => Maybe a -> a +-- maybeF (Just x) = sin x +-- maybeF Nothing = zero +-- :} +-- +-- >>> maybeF (Just 0.0 :: Maybe Float) +-- 0.0 +-- +-- >>> maybeF (Nothing :: Maybe Float) +-- 0.0 +-- +-- >>> maybeArgDerivative maybeF (Just 0.0 :: Maybe Float) +-- Just 1.0 +-- +-- >>> maybeArgDerivative maybeF (Nothing :: Maybe Float) +-- Just 0.0 +maybeArgDerivative :: + (AutoDifferentiableValue b) => + (Maybe (RevDiff' (Maybe a) a) -> b) -> + Maybe a -> + DerivativeValue b +maybeArgDerivative = customArgDerivative maybeArg + +-- | Derivative operator for functions with Maybe arguments. +-- This allows computing derivatives of functions that returns Maybe values as output, +-- handling the case when the value is Nothing appropriately. +-- +-- ==== __Examples__ +-- +-- >>> :{ +-- class SafeRecip a where +-- safeRecip :: a -> Maybe a +-- instance SafeRecip Float where +-- safeRecip x = if x == 0.0 then Nothing else Just (recip x) +-- instance (SafeRecip b, Subtractive b, Multiplicative b, IntegerPower b) => +-- SafeRecip (RevDiff a b b) where +-- safeRecip (MkRevDiff v bp) = +-- fmap (\r -> MkRevDiff r (bp . negate . (r^2 *))) (safeRecip v) +-- :} +-- +-- >>> safeRecip (2.0 :: Float) :: Maybe Float +-- Just 0.5 +-- >>> safeRecip (0.0 :: Float) :: Maybe Float +-- Nothing +-- +-- >>> maybeValDerivative safeRecip (2.0 :: Float) +-- Just (-0.25) +-- >>> maybeValDerivative safeRecip (0.0 :: Float) +-- Nothing +maybeValDerivative :: + ( AutoDifferentiableArgument a, + Multiplicative c, + DerivativeCoarg a ~ CT (DerivativeArg a), + DerivativeRoot a ~ CT (DerivativeArg a) + ) => + (a -> Maybe (RevDiff b c d)) -> + DerivativeArg a -> + Maybe b +maybeValDerivative = customValDerivative maybeVal diff --git a/src/Numeric/InfBackprop/Instances/NumHask.hs b/src/Numeric/InfBackprop/Instances/NumHask.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/InfBackprop/Instances/NumHask.hs @@ -0,0 +1,423 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- Module : Numeric.InfBackprop.Instances.NumHask +-- Copyright : (C) 2025 Alexey Tochin +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Alexey Tochin +-- +-- Orphane instances for +-- [numhask](https://hackage.haskell.org/package/numhask) +-- typeclasses. +module Numeric.InfBackprop.Instances.NumHask () where + +{- HLINT ignore "Use fewer imports" -} + +import Control.Applicative (liftA2) +import Data.Bifunctor (bimap) +import qualified Data.Stream as DS +import qualified Data.Vector.Generic as DVG +import qualified Data.Vector.Generic.Sized as DVGS +import GHC.Base (Functor (fmap), Maybe (Just)) +import GHC.TypeNats (KnownNat) +import NumHask + ( Additive, + Divisive, + ExpField, + Multiplicative, + Subtractive, + TrigField, + acos, + acosh, + asin, + asinh, + atan, + atan2, + atanh, + cos, + cosh, + exp, + log, + logBase, + negate, + one, + pi, + recip, + sin, + sinh, + sqrt, + tan, + tanh, + zero, + (*), + (**), + (+), + (-), + (/), + ) +import Numeric.InfBackprop.Utils.Tuple (biCross, biCross3, cross, cross3) + +-- | Instances for NumHask classes for common data types. +-- These instances follow the standard lifting of operations to container types. +-- +-- Note: These are orphan instances. Consider proposing them upstream to numhask. + +-- | Tuple instance of `Additive` typecalss. +instance + (Additive a0, Additive a1) => + Additive (a0, a1) + where + zero = (zero, zero) + (+) = biCross (+) (+) + +-- | Tuple instance of `Subtractive` typeclass. +instance + (Subtractive a0, Subtractive a1) => + Subtractive (a0, a1) + where + negate (x0, x1) = (negate x0, negate x1) + (-) = biCross (-) (-) + +-- | Tuple instance of `Multiplicative` typeclass. +instance + (Multiplicative a0, Multiplicative a1) => + Multiplicative (a0, a1) + where + one = (one, one) + (*) = biCross (*) (*) + +-- | Tuple instance of `Divisive` typeclass. +instance + (Divisive a0, Divisive a1) => + Divisive (a0, a1) + where + recip = cross recip recip + (/) = biCross (/) (/) + +-- | Tuple instance of `ExpField` typeclass. +instance + (ExpField a, ExpField b) => + ExpField (a, b) + where + exp = bimap exp exp + log = bimap log log + (**) = biCross (**) (**) + logBase = biCross logBase logBase + sqrt = bimap sqrt sqrt + +-- | Tuple instance of `TrigField` typeclass. +instance + (TrigField a, TrigField b) => + TrigField (a, b) + where + -- Constants + pi = (pi, pi) + + -- Basic trig functions + sin = bimap sin sin + cos = bimap cos cos + tan = bimap tan tan + + -- Inverse trig functions + asin = bimap asin asin + acos = bimap acos acos + atan = bimap atan atan + atan2 = biCross atan2 atan2 + + -- Hyperbolic functions + sinh = bimap sinh sinh + cosh = bimap cosh cosh + tanh = bimap tanh tanh + + -- Inverse hyperbolic functions + asinh = bimap asinh asinh + acosh = bimap acosh acosh + atanh = bimap atanh atanh + +-- | Triple instance of `Additive`. +instance + (Additive a0, Additive a1, Additive a2) => + Additive (a0, a1, a2) + where + zero = (zero, zero, zero) + (+) = biCross3 (+) (+) (+) + +-- | Triple instance of `Subtractive`. +instance + (Subtractive a0, Subtractive a1, Subtractive a2) => + Subtractive (a0, a1, a2) + where + negate (x0, x1, x2) = (negate x0, negate x1, negate x2) + (-) = biCross3 (-) (-) (-) + +-- | Triple instance of `Multiplicative` typeclass. +instance + (Multiplicative a0, Multiplicative a1, Multiplicative a2) => + Multiplicative (a0, a1, a2) + where + one = (one, one, one) + (*) = biCross3 (*) (*) (*) + +-- | Triple instance of `Divisive` typeclass. +instance + (Divisive a0, Divisive a1, Divisive a2) => + Divisive (a0, a1, a2) + where + recip = cross3 recip recip recip + (/) = biCross3 (/) (/) (/) + +-- | Triple instance of `ExpField`. +instance + (ExpField a0, ExpField a1, ExpField a2) => + ExpField (a0, a1, a2) + where + exp = cross3 exp exp exp + log = cross3 log log log + (**) = biCross3 (**) (**) (**) + logBase = biCross3 logBase logBase logBase + sqrt = cross3 sqrt sqrt sqrt + +-- | Triple instance of `TrigField`. +instance + (TrigField a, TrigField b, TrigField c) => + TrigField (a, b, c) + where + -- Constants + pi = (pi, pi, pi) + + -- Basic trig functions + sin = cross3 sin sin sin + cos = cross3 cos cos cos + tan = cross3 tan tan tan + + -- Inverse trig functions + asin = cross3 asin asin asin + acos = cross3 acos acos acos + atan = cross3 atan atan atan + atan2 = biCross3 atan2 atan2 atan2 + + -- Hyperbolic functions + sinh = cross3 sinh sinh sinh + cosh = cross3 cosh cosh cosh + tanh = cross3 tanh tanh tanh + + -- Inverse hyperbolic functions + asinh = cross3 asinh asinh asinh + acosh = cross3 acosh acosh acosh + atanh = cross3 atanh atanh atanh + +-- | Sized Vector instance of `Additive` typeclass. +instance + (KnownNat n, Additive a, DVG.Vector v a) => + Additive (DVGS.Vector v n a) + where + zero = DVGS.replicate zero + (+) = DVGS.zipWith (+) + +-- | Sized Vector instance of `Subtractive` typeclass. +instance + (KnownNat n, Subtractive a, DVG.Vector v a) => + Subtractive (DVGS.Vector v n a) + where + negate = DVGS.map zero + (-) = DVGS.zipWith (-) + +-- | Sized Vector instance of `Multiplicative` typeclass. +instance + (KnownNat n, Multiplicative a, DVG.Vector v a) => + Multiplicative (DVGS.Vector v n a) + where + one = DVGS.replicate one + (*) = DVGS.zipWith (*) + +-- | Sized Vector instance of `Divisive` typeclass. +instance + (KnownNat n, Divisive a, DVG.Vector v a) => + Divisive (DVGS.Vector v n a) + where + (/) = DVGS.zipWith (/) + +-- | Sized Vector instance of `ExpField` typeclass. +instance + (KnownNat n, ExpField a, DVG.Vector v a) => + ExpField (DVGS.Vector v n a) + where + exp = DVGS.map exp + log = DVGS.map log + (**) = DVGS.zipWith (**) + logBase = DVGS.zipWith logBase + sqrt = DVGS.map sqrt + +-- | Sized Vector instance of `TrigField` typeclass. +instance + (KnownNat n, TrigField a, DVG.Vector v a) => + TrigField (DVGS.Vector v n a) + where + -- Constants + pi = DVGS.replicate pi + + -- Basic trig functions + sin = DVGS.map sin + cos = DVGS.map cos + tan = DVGS.map tan + + -- Inverse trig functions + asin = DVGS.map asin + acos = DVGS.map acos + atan = DVGS.map atan + atan2 = DVGS.zipWith atan2 + + -- Hyperbolic functions + sinh = DVGS.map sinh + cosh = DVGS.map cosh + tanh = DVGS.map tanh + + -- Inverse hyperbolic functions + asinh = DVGS.map asinh + acosh = DVGS.map acosh + atanh = DVGS.map atanh + +-- | `Data.Stream.Stream` instances of `Additive` typeclass. +instance + (Additive a) => + Additive (DS.Stream a) + where + zero = DS.repeat zero + (+) = DS.zipWith (+) + +-- | `Data.Stream.Stream` instances of `Subtractive` typeclass. +instance + (Subtractive a) => + Subtractive (DS.Stream a) + where + negate = fmap negate + (-) = DS.zipWith (-) + +-- | `Data.Stream.Stream` instances of `Multiplicative` typeclass. +instance + (Multiplicative a) => + Multiplicative (DS.Stream a) + where + one = DS.repeat one + (*) = liftA2 (*) + +-- | `Data.Stream.Stream` instances of `Divisive` typeclass. +instance + (Divisive a) => + Divisive (DS.Stream a) + where + recip = fmap recip + (/) = liftA2 (/) + +-- | `Data.Stream.Stream` instances of `ExpField` typeclass. +instance + (ExpField a) => + ExpField (DS.Stream a) + where + exp = fmap exp + log = fmap log + (**) = liftA2 (**) + logBase = liftA2 logBase + sqrt = fmap sqrt + +-- | `Data.Stream.Stream` instances of `TrigField` typeclass. +instance + (TrigField a) => + TrigField (DS.Stream a) + where + -- Constants + pi = DS.repeat pi + + -- Basic trig functions + sin = fmap sin + cos = fmap cos + tan = fmap tan + + -- Inverse trig functions + asin = fmap asin + acos = fmap acos + atan = fmap atan + atan2 = liftA2 atan2 + + -- Hyperbolic functions + sinh = fmap sinh + cosh = fmap cosh + tanh = fmap tanh + + -- Inverse hyperbolic functions + asinh = fmap asinh + acosh = fmap acosh + atanh = fmap atanh + +-- | `Maybe` instance of `Additive`. +instance + (Additive a) => + Additive (Maybe a) + where + zero = Just zero + (+) = liftA2 (+) + +-- | `Maybe` instance of `Subtractive`. +instance + (Subtractive a) => + Subtractive (Maybe a) + where + negate = fmap negate + (-) = liftA2 (-) + +-- | `Maybe` instance of `Multiplicative`. +instance + (Multiplicative a) => + Multiplicative (Maybe a) + where + one = Just one + (*) = liftA2 (*) + +-- | `Maybe` instance of `Divisive`. +instance + (Divisive a) => + Divisive (Maybe a) + where + recip = fmap recip + (/) = liftA2 (/) + +-- | `Maybe` instance of `ExpField`. +instance + (ExpField a) => + ExpField (Maybe a) + where + exp = fmap exp + log = fmap log + (**) = liftA2 (**) + logBase = liftA2 logBase + sqrt = fmap sqrt + +-- | `Maybe` instance of `TrigField`. +instance + (TrigField a) => + TrigField (Maybe a) + where + -- Constants + pi = Just pi + + -- Basic trig functions + sin = fmap sin + cos = fmap cos + tan = fmap tan + + -- Inverse trig functions + asin = fmap asin + acos = fmap acos + atan = fmap atan + atan2 = liftA2 atan2 + + -- Hyperbolic functions + sinh = fmap sinh + cosh = fmap cosh + tanh = fmap tanh + + -- Inverse hyperbolic functions + asinh = fmap asinh + acosh = fmap acosh + atanh = fmap atanh diff --git a/src/Numeric/InfBackprop/Tutorial.hs b/src/Numeric/InfBackprop/Tutorial.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/InfBackprop/Tutorial.hs @@ -0,0 +1,2163 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS -Wno-unused-imports #-} +{-# OPTIONS_HADDOCK show-extensions #-} + +-- | +-- Module : Numeric.InfBackprop.Tutorial +-- Copyright : (C) 2023-2025 Alexey Tochin +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Alexey Tochin +-- +-- Tutorial for the +-- [inf-backprop](https://hackage.haskell.org/package/inf-backprop) package. +module Numeric.InfBackprop.Tutorial + ( -- * Quick Start + + -- ** Basic Examples #quick-start-simple-derivative# + -- $quick-start-simple-derivative + + -- ** Derivatives for Symbolic Expressions #quick-start-derivatives-for-symbolic-expressions# + -- $quick-start-derivatives-for-symbolic-expressions + + -- ** Symbolic Expressions Visualization #squick-start-ymbolic-expressions-visualization# + -- $quick-start-symbolic-expressions-visualization + + -- ** Gradient over a Two-Argument Function #quick-start-function-of-two-argument-functions# + -- $quick-start-gradient-of-two-argument-functions + + -- ** Siskind-Pearlmutter Example #quick-start-siskind-pearlmutter-example# + -- $quick-start-siskind-pearlmutter-example + + -- * How it Works + -- $how-it-works + + -- ** The Backpropagation Derivative #how-it-works-backpropagation# + -- $how-it-works-backpropagation + + -- ** Core Type: `RevDiff` #how-it-works-core-type-RevDiff# + -- $how-it-works-core-type-RevDiff + + -- ** Functions Overloading #how-it-works-functions-overloading# + -- $how-it-works-functions-overloading + + -- ** Tangent and Cotangent Spaces #how-it-works-tangent-space# + -- $how-it-works-tangent-space + + -- * Differentiation for Structured Types #differentiation-for-structured-types# + -- $differentiation-for-structured-types + + -- ** Structured Value Type #differentiation-for-structured-types-structured-value# + -- $differentiation-for-structured-types-structured-value + + -- *** Basic Examples: Structured Value Types #differentiation-for-structured-types-structured-value-basic-examples# + -- $differentiation-for-structured-types-structured-value-basic-examples + + -- *** Custom Derivative: Structured Value Types #differentiation-for-structured-types-structured-value-custom-derivative# + -- $differentiation-for-structured-types-structured-value-custom-derivative + + -- *** How it Works: Structured Value Types #differentiation-for-structured-types-structured-value-how-it-works# + -- $differentiation-for-structured-types-structured-value-how-it-works + + -- *** Defining Custom Value Type #differentiation-for-structured-types-structured-value-defining-custom-value-type# + -- $differentiation-for-structured-types-structured-value-defining-custom-value-type + + -- ** Structured Argument Type #differentiation-for-structured-types-structured-argument-type# + -- $differentiation-for-structured-types-structured-argument-type + + -- *** Basic Examples: Structured Argument Types #differentiation-for-structured-types-structured-argument-type-basic-examples# + -- $differentiation-for-structured-types-structured-argument-type-basic-examples + + -- *** Custom Derivative: Structured Argument Types #differentiation-for-structured-types-structured-argument-type-custom-gradient# + -- $differentiation-for-structured-types-structured-argument-type-custom-gradient + + -- *** How it Works: Structered Argument Types #differentiation-for-structured-types-structured-argument-type-how-it-works# + -- $differentiation-for-structured-types-structured-argument-type-how-it-works + + -- *** Defining Custom Argument Type #differentiation-for-structured-types-structured-argument-type-defining-custom-type# + -- $differentiation-for-structured-types-structured-argument-type-defining-custom-type + + -- * Performance Remarks #performance-remarks# + -- $performance-remarks + + -- ** Subexpression Elimination #sperformance-remarks-ubexpression-elimination# + -- $performance-remarks-subexpression-elimination + + -- ** Forward Step Results Reusage #forward-step-results-reusage# + -- $performance-remarks-forward-step-results-reusage + + -- * What is Next #what-is-next# + -- $what-is-next + ) +where + +import Control.Category ((>>>)) +import Control.Lens (set, view) +import Data.FiniteSupportStream (FiniteSupportStream (toVector), head, singleton) +import qualified Data.List as DL +import Data.Proxy (Proxy (Proxy)) +import Data.Stream (Stream, fromList, head, take) +import qualified Data.Stream as DS +import qualified Data.Stream as Data +import Data.Tuple (fst, snd, uncurry) +import Data.Type.Equality (type (~)) +import qualified Data.Vector as DV +import qualified Data.Vector.Fixed as DVF +import Data.Vector.Generic.Sized (Vector, foldl') +import qualified Data.Vector.Generic.Sized as DVGS +import Debug.DiffExpr + ( BinarySymbolicFunc, + SymbolicFunc, + TSE, + TracedSimpleExpr, + binarySymbolicFunc, + unarySymbolicFunc, + ) +import Debug.SimpleExpr (SE, SimpleExpr, number, simplify, simplifyExpr, variable) +import Debug.SimpleExpr.Utils.Traced (Traced (MkTraced), addTraceUnary) +import Debug.Trace (trace) +import GHC.Base (Float, Int, const, fmap, foldr, id, undefined, ($), (.), (<>)) +import GHC.Integer (Integer) +import GHC.Natural (Natural, minusNatural) +import GHC.Show (Show (show)) +import GHC.TypeNats (KnownNat) +import NumHask + ( Additive, + Distributive, + Divisive, + ExpField, + FromInteger (fromInteger), + Multiplicative, + Ring, + Subtractive, + TrigField, + cos, + cosh, + exp, + log, + negate, + one, + sin, + sinh, + zero, + (*), + (+), + (-), + (/), + ) +import qualified NumHask as NH +import Numeric.InfBackprop + ( CT, + Cotangent, + Dual, + RevDiff (MkRevDiff), + RevDiff', + Tangent, + autoArg, + autoVal, + backprop, + boxedVectorArg, + boxedVectorArgDerivative, + boxedVectorVal, + constDiff, + customArgDerivative, + customArgValDerivative, + fromProfunctors, + fromVanLaarhoven, + initDiff, + mkBoxedVectorArg, + mkBoxedVectorVal, + mkStreamArg, + mkStreamVal, + mkTupleArg, + mkTupleVal, + scalarArg, + scalarArgDerivative, + scalarVal, + scalarValDerivative, + simpleDerivative, + simpleDifferentiableFunc, + simpleValueAndDerivative, + stopDiff, + streamArg, + streamArgDerivative, + toProfunctors, + toVanLaarhoven, + tupleArg, + tupleArgDerivative, + tupleVal, + twoArgsDerivative, + twoArgsDerivativeOverY, + value, + ) +import Numeric.InfBackprop.Instances.NumHask () +import Numeric.InfBackprop.Utils.SizedVector (BoxedVector) +import Numeric.InfBackprop.Utils.Tuple (cross) + +-- $quick-start-simple-derivative +-- +-- >>> import GHC.Base (Float, fmap, ($)) +-- +-- In this section, we'll explore how automatic differentiation transforms ordinary +-- mathematical functions into their derivatives, handling everything from basic +-- polynomials to complex compositions without requiring manual derivation. +-- +-- We'll start by exploring automatic differentiation +-- through the familiar square function: +-- +-- \[ +-- f(x) := x^2 +-- \] +-- +-- To work with our automatic differentiation system, we need operations that can +-- handle not just numbers, but also the dual numbers that carry derivative information. +-- The polymorphic multiplication operator from +-- [numhask](https://hackage.haskell.org/package/numhask) +-- provides this flexibility: +-- +-- >>> import NumHask (Multiplicative, (*), (+), log) +-- +-- The operator `(*)` has the following type signature: +-- +-- > (*) :: Multiplicative a => a -> a -> a +-- +-- This polymorphic operator allows us to write functions +-- that work seamlessly with both regular +-- numbers and the extended number types used in automatic differentiation. +-- +-- Let's define our square function and see it in action with regular `Float` values: +-- +-- >>> f x = x * x +-- >>> fmap f [-3, -2, -1, 0, 1, 2, 3] :: [Float] +-- [9.0,4.0,1.0,0.0,1.0,4.0,9.0] +-- +-- Now comes the remarkable part: computing the derivative automatically. The +-- `simpleDerivative` function applies the chain rule automatically, transforming +-- any function built from differentiable primitives into its derivative function. +-- +-- We know from calculus that the derivative of \(x^2\) should be: +-- +-- \[ +-- f'(x) = 2 \cdot x +-- \] +-- +-- Let's verify this using automatic differentiation: +-- +-- >>> import Numeric.InfBackprop (simpleDerivative) +-- +-- >>> f' = simpleDerivative f :: Float -> Float +-- >>> fmap f' [-3, -2, -1, 0, 1, 2, 3] +-- [-6.0,-4.0,-2.0,0.0,2.0,4.0,6.0] +-- +-- Notice how each result equals \(2x\), perfectly confirming our analytical derivative +-- \(f'(x) = 2x\). The values \(-6, -4, -2, 0, 2, 4, 6\) correspond exactly to \(2\) times +-- each input value. +-- +-- You must provide a type annotation (such as @Float -> Float@) for the derivative +-- function. This ensures correct type inference by the compiler and specifies which +-- numeric type you want to work with. +-- +-- Computing higher-order derivatives follows the same pattern. Since composing +-- `simpleDerivative` twice gives us the second derivative, this demonstrates how +-- automatic differentiation naturally handles higher-order derivatives through +-- function composition. +-- +-- For our square function, the second derivative should be the constant \(2\): +-- +-- \[ +-- f''(x) = 2 +-- \] +-- +-- >>> f'' = simpleDerivative $ simpleDerivative f :: Float -> Float +-- >>> fmap f'' [-3, -2, -1, 0, 1, 2, 3] +-- [2.0,2.0,2.0,2.0,2.0,2.0,2.0] +-- +-- Perfect! The constant value @2.0@ across all inputs confirms that our second +-- derivative is indeed the constant function \(f''(x) = 2\). +-- +-- This approach scales naturally to arbitrarily complex functions. Let's explore +-- how automatic differentiation handles function composition by examining a more +-- intricate example involving logarithms and polynomial terms: +-- +-- \[ +-- g(x) := \log (x^2 + x^3) +-- \] +-- +-- We'll use integer powers from the +-- 'Numeric.InfBackprop.Algebra.IntegralPower' +-- module: +-- +-- >>> import Debug.SimpleExpr.Utils.Algebra ((^)) +-- +-- >>> g x = log (x ^ 2 + x ^ 3) +-- >>> g' = simpleDerivative g :: Float -> Float +-- >>> g 1 :: Float +-- 0.6931472 +-- >>> g' 1 :: Float +-- 2.5 +-- +-- We can verify this result analytically. The derivative of \(\log(x^2 + x^3)\) using +-- the chain rule is: +-- +-- \[ +-- g'(x) = \frac{d}{dx}[\log(x^2 + x^3)] = \frac{1}{x^2 + x^3} \cdot \frac{d}{dx}[x^2 + x^3] = \frac{2x + 3x^2}{x^2 + x^3} +-- \] +-- +-- At \(x = 1\): +-- +-- \[ +-- g'(1) = \frac{2 \cdot 1 + 3 \cdot 1^2}{1^2 + 1^3} = \frac{2 + 3}{1 + 1} = \frac{5}{2} = 2.5 +-- \] +-- +-- The automatic differentiation result matches our analytical calculation perfectly, +-- demonstrating how the system correctly applies the chain rule even for complex +-- composite functions. + +-- $quick-start-derivatives-for-symbolic-expressions +-- +-- >>> import NumHask ((*), sin, cos) +-- >>> import Debug.SimpleExpr (variable, simplify, SimpleExpr, SE) +-- >>> import Numeric.InfBackprop (simpleDerivative) +-- +-- In many cases, it is more convenient to illustrate differentiation using +-- symbolic expressions rather than concrete numeric values. +-- Unlike numeric differentiation, symbolic expressions allow us to +-- inspect, transform, and optimize derivatives algebraically. +-- +-- We use the +-- [simple-expr](https://hackage.haskell.org/package/simple-expr) +-- package to construct and manipulate symbolic expressions. +-- +-- For example, consider the function: +-- +-- \[ +-- f(x) := \sin(x^2) +-- \] +-- +-- We can define it symbolically as follows: +-- +-- >>> import Debug.SimpleExpr.Utils.Algebra (AlgebraicPower, (^)) +-- +-- >>> x = variable "x" :: SimpleExpr +-- >>> f x = sin (x ^ 2) +-- >>> f x :: SimpleExpr +-- sin(x^2) +-- +-- where 'SimpleExpr' is a symbolic expression type from +-- [simple-expr](https://hackage.haskell.org/package/simple-expr) +-- +-- Computing the symbolic derivative +-- +-- \[ +-- f'(x) := 2x \cdot \cos(x^2) +-- \] +-- +-- is equally straightforward: +-- +-- >>> f' = simpleDerivative f +-- >>> simplify $ f' x :: SimpleExpr +-- (2*x)*cos(x^2) +-- +-- The `simplify` function from +-- [simple-expr](https://hackage.haskell.org/package/simple-expr) +-- reduces redundant expressions like +-- @*1@ and @+0@. +-- and presents the result in a more readable algebraic form. +-- +-- Bellow, we will use the @SE@ type synonym for @SimpleExpr@. +-- +-- Note that we continue to use generic definitions of functions like 'cos', +-- as well as operators such as '(*)', from the +-- [numhask](https://hackage.haskell.org/package/numhask) +-- package. + +-- $quick-start-symbolic-expressions-visualization +-- +-- The +-- [simple-expr](https://hackage.haskell.org/package/simple-expr) +-- package includes visualization tools that help illustrate the process of symbolic +-- differentiation. +-- +-- >>> import Debug.SimpleExpr (SimpleExpr, variable, simplify, plotExpr, plotDGraphPng) +-- >>> import Debug.DiffExpr (unarySymbolicFunc) +-- >>> import Numeric.InfBackprop (simpleDerivative) +-- +-- As a warm-up, consider a simple composition of two symbolic functions: +-- +-- \[ +-- x \mapsto g(f(x)) +-- \] +-- +-- This can be represented as: +-- +-- >>> x = variable "x" :: SimpleExpr +-- >>> f = unarySymbolicFunc "f" :: SimpleExpr -> SimpleExpr +-- >>> g = unarySymbolicFunc "g" :: SimpleExpr -> SimpleExpr +-- >>> g (f x) :: SimpleExpr +-- g(f(x)) +-- +-- You can visualize this expression using: +-- +-- > plotExpr $ g (f x) +-- +-- ![Function composition](doc/images/composition.png) +-- +-- To visualize the first derivative of this composition, use: +-- +-- > plotExpr $ simplify $ simpleDerivative (g . f) x +-- +-- ![First derivative](doc/images/composition_derivative.png) +-- +-- Visualizing the second derivative is just as easy: +-- +-- > plotExpr $ simplify $ simpleDerivative (simpleDerivative (g . f)) x +-- +-- ![Second derivative](doc/images/composition_second_derivative.png) + +-- $quick-start-gradient-of-two-argument-functions +-- +-- In this section, we focus on computing partial derivatives of functions +-- with two arguments. +-- +-- As a starting point, consider a symbolic function @h@ that takes two arguments. +-- (See +-- [Derivatives for Symbolic Expressions](#g:quick-45-start-45-derivatives-45-for-45-symbolic-45-expressions) +-- .) +-- +-- >>> x = variable "x" +-- >>> y = variable "y" +-- >>> h = binarySymbolicFunc "h" :: BinarySymbolicFunc a => a -> a -> a +-- >>> h x y +-- h(x,y) +-- +-- To compute partial derivatives, we use the `twoArgsDerivative` operator, +-- which has a somewhat advanced type signature (see Section ??? for details). +-- In practice, its usage is straightforward: +-- +-- >>> :{ +-- h' :: SE -> SE -> (SE, SE) +-- h' x y = simplify $ twoArgsDerivative h x y +-- :} +-- +-- This returns a pair of partial derivatives: +-- +-- >>> h' x y +-- (h'_1(x,y),h'_2(x,y)) +-- +-- We can also compute the second-order derivatives by nesting `twoArgsDerivative`: +-- +-- >>> :{ +-- h'' :: SE -> SE -> ((SE, SE), (SE, SE)) +-- h'' x y = simplify $ twoArgsDerivative (twoArgsDerivative h) x y +-- :} +-- +-- >>> h'' x y +-- ((h'_1'_1(x,y),h'_1'_2(x,y)),(h'_2'_1(x,y),h'_2'_2(x,y))) +-- +-- In this example, @h\'_1\'_2@ refers to the second partial derivative of @h@ +-- with respect to @x@ and then @y@, and so on. +-- +-- Note that `twoArgsDerivative` is polymorphic over the return type of the function, +-- but it works only for functions that take exactly /two arguments/. +-- +-- In contrast, the @customArgValDerivative autoArg@ operator +-- (see +-- [Structured Argument Type](#g:differentiation-45-for-45-structured-45-types-45-structured-45-argument-45-type)) +-- can handle functions of arbitrary arity, but it is /not/ polymorphic +-- over the return type of the function. + +-- $quick-start-siskind-pearlmutter-example +-- +-- We are now ready to revisit a classic example of higher-order automatic differentiation +-- from the paper by Siskind and Pearlmutter: +-- [Siskind & Pearlmutter (2005), "Perturbation Confusion and Referential Transparency"](https://engineering.purdue.edu/~qobi/papers/ifl2005.pdf) +-- The expression of interest is: +-- +-- \[ +-- \left. +-- \frac{\partial}{\partial x} +-- \left( +-- x +-- \left( +-- \left. +-- \frac{\partial}{\partial y} +-- \left( +-- x + y +-- \right) +-- \right|_{y=1} +-- \right) +-- \right) +-- \right|_{x=1} +-- = 1 +-- \] +-- +-- To implement this, we begin by applying the partial derivative operator +-- `twoArgsDerivativeOverY`, which differentiates a binary function +-- with respect to its /second/ argument: +-- +-- For example, to compute +-- +-- \[ +-- \frac{\partial}{\partial y} +-- (x \cdot y) +-- = x +-- \] +-- +-- we write: +-- +-- >>> x = variable "x" +-- >>> y = variable "y" +-- >>> simplify $ twoArgsDerivativeOverY (*) x y :: SE +-- x +-- +-- To evaluate this derivative at @y = 1@, we can use the `stopDiff` function, +-- which performs symbolic substitution. For instance, +-- +-- > stopDiff $ number 1 +-- +-- effectively replaces @y@ with @1@ in the expression. +-- +-- So the expression +-- +-- \[ +-- \left. +-- \frac{\partial}{\partial y} +-- (x \cdot y) +-- \right|_{y=1} +-- = x +-- \] +-- +-- is implemented as: +-- +-- >>> simplify $ twoArgsDerivativeOverY (*) x 1 :: SE +-- x +-- +-- Now we can wrap the entire expression in a derivative with respect to @x@: +-- +-- \[ +-- \frac{d}{dx} +-- \left. +-- \frac{\partial}{\partial y} +-- (x \cdot y) +-- \right|_{y=1} +-- = 1 +-- \] +-- +-- This becomes: +-- +-- >>> :{ +-- simplify $ +-- (simpleDerivative $ \x_ -> twoArgsDerivativeOverY (*) x_ 1) x :: SE +-- :} +-- 1 +-- +-- The same logic works not just for symbolic expressions (`SE`), +-- but also for concrete numeric types such as `Float`: +-- +-- >>> :{ +-- simpleDerivative +-- (\x -> x * twoArgsDerivativeOverY (+) x 1) +-- (2024 :: Float) +-- :} +-- 1.0 +-- +-- Note: when working with numeric types like `Float`, +-- the variable @x@ must be assigned a concrete `Float` value. + +-- $how-it-works-backpropagation +-- +-- To clarify the concept of backpropagation, consider the following example. +-- +-- Let @h@, @f@, and @g@ be three simple functions of type: +-- +-- \[ +-- \mathbb{R} \rightarrow \mathbb{R} +-- \] +-- +-- Now consider their composition: +-- +-- \[ +-- x \mapsto g(f(h(x))) +-- \] +-- +-- The first derivative of this composition, using the chain rule, is: +-- +-- \[ +-- x \mapsto h'(x) \cdot f'(h(x)) \cdot g'(f(h(x))) +-- \] +-- +-- This composition and its derivative can be illustrated +-- using the following computation graph: +-- +-- ![Backpropagation diagram](doc/images/backprop.drawio.png) +-- +-- The top path (from left to right) represents the /forward pass/, +-- where values are computed through the function chain. +-- The bottom path (from right to left) represents the /backward pass/, +-- where derivatives are propagated. +-- +-- According to the backpropagation strategy, +-- the derivative is computed in reverse order, as follows: +-- +-- 1. Evaluate @h(x)@. +-- +-- 2. Compute @f(h(x))@. +-- +-- 3. Compute @g(f(h(x)))@. +-- +-- 4. Compute the top derivative: @g'(f(h(x)))@. +-- +-- 5. Compute the next derivative: @f'(h(x))@. +-- +-- 6. Multiply: @g'(f(h(x))) * f'(h(x))@. +-- +-- 7. Compute the base derivative: @h'(x)@. +-- +-- 8. Multiply the result from step 6 by @h'(x)@. +-- +-- The product of these three derivatives gives the full derivative of the composition. +-- +-- Note: While it is possible to compute this derivative in forward order +-- (i.e., from left to right) or +-- any other order, +-- the backpropagation strategy is more efficient +-- for deep machine learning applications. +-- Forward-mode differentiation is beyond the scope of this library. +-- +-- Generalizing this approach to longer function chains or functions from and to vector spaces +-- is straightforward and follows the same principles. + +-- $how-it-works-core-type-RevDiff +-- +-- All the derivative computations from the previous example — +-- specifically for the function @f@ — +-- can be conceptually divided into two phases: +-- +-- 1. /Forward step/: Compute the value @f(h(x))@. +-- +-- 2. /Backward step/: +-- Compute the derivative @f'(h(x))@, and multiply it by the previously +-- obtained derivative @g'(f(h(x)))@. +-- +-- Note that the value @h(x)@ is used in both the forward and backward steps. +-- +-- The corresponding diagram can be visualized as: +-- +-- ![Backpropagation lens diagram](doc/images/lens.drawio.png) +-- +-- A differentiable function from type @a@ to type @b@ can be represented +-- as a pair of functions: +-- a /forward/ function and a /backward/ (derivative propagation) function: +-- +-- @ +-- newtype DifferentiableFunc a b = MkDifferentiableFunc { +-- forward :: a -> b, +-- backward :: a -> CT b -> CT a +-- } +-- @ +-- +-- The meaning of the `CT` type family (short for /cotangent/) +-- will be discussed in the +-- [next section](#g:how-45-it-45-works-45-tangent-45-space). +-- For now, you may assume @CT a ~ a@. +-- +-- From a categorical perspective, a @DifferentiableFunc@ behaves like a lens: +-- +-- > DifferentiableFunc a b ≈ Lens a (CT a) b (CT b) +-- +-- where @forward@ corresponds to `view`, and @backward@ corresponds to `set`. +-- +-- In principle, one could define a category of differentiable functions using lenses, +-- replacing standard function composition `(.)` with lens composition `(% or >>>)`. +-- However, this comes at a cost: we lose the ability to use familiar syntax such as +-- function application @y = f x@. +-- +-- To preserve the familiar function syntax — e.g., keeping definitions like +-- @sin :: a -> a@ +-- and supporting ordinary function application — we follow an approach inspired by the +-- [ad](https://hackage.haskell.org/package/ad) +-- and +-- [backprop](https://hackage.haskell.org/package/backprop) libraries. +-- See also, for example, +-- [this article](https://arxiv.org/pdf/1804.00746) +-- +-- Fixing a type @t@ (which plays the role of the final output), we can reinterpret +-- a lens-like function +-- +-- > dFunc :: DifferentiableFunc a b +-- +-- as a transformation on differentiable values: +-- +-- > lensToMap :: DifferentiableFunc a b -> DifferentiableFunc t a -> DifferentiableFunc t b +-- > lensToMap dFunc = dFunc <<< -- lens composition +-- +-- So, @lensToMap dFunc@ becomes a plain Haskell function: +-- +-- > DifferentiableFunc t a -> DifferentiableFunc t b +-- +-- Mathematically, this is a /hom-functors/ from +-- the cathegory of law-breaking lenses. +-- +-- Next, note that the type +-- +-- > DifferentiableFunc t a +-- +-- is isomorphic to: +-- +-- > t -> (a, CT a -> CT t) +-- +-- But the actual value of type @t@ is not used the composion with +-- @DifferentiableFunc a b@. +-- Therefore, we can drop the @t@ parameter and reduce the transformation: +-- +-- > DifferentiableFunc t a -> DifferentiableFunc t b +-- +-- to a plain function: +-- +-- > (a, CT a -> CT t) -> (b, CT b -> CT t) +-- +-- This motivates the definition of the core type: +-- +-- @ +-- data RevDiff' t a = MkRevDiff +-- { value :: a +-- , backprop :: CT a -> CT t +-- } +-- @ +-- +-- For example, suppose we have a function: +-- +-- > f :: Float -> Float -- function f +-- > f' :: Float -> Float -- derivative of f +-- +-- Then the differentiable version of @f@ can be defined as: +-- +-- @ +-- differentiableF :: RevDiff' t Float -> RevDiff' t Float +-- differentiableF (MkRevDiff x backprop) = +-- MkRevDiff (f x) (\cx -> backprop ((f' x) * cx)) +-- @ +-- +-- To evaluate the function at a point @x@: +-- +-- > y = value $ differentiableF (MkRevDiff x id) +-- +-- To evaluate its derivative at @x@: +-- +-- > y' = backprop (differentiableF (MkRevDiff x id)) 1.0 +-- +-- Here, the transition from type @a@ to @RevDiff' t a@ carries two parts: +-- +-- - `value`: the forward-pass result +-- +-- - `backprop`: a stack of backward-pass derivative transformations +-- +-- from type @CT a@ to @CT t@. +-- +-- In the example above, the value: +-- +-- > MkRevDiff x id :: RevDiff Float Float +-- +-- represents the /initial value/ of the backpropagation stack. +-- Applying @differentiableF@ +-- results in: +-- +-- > MkRevDiff (f x) (\cx -> id ((f' x) * cx)) = MkRevDiff (f x) ((f' x) *) +-- +-- So applying `backprop` to @1.0 :: @`Float` gives us the derivative value @f' x@. +-- +-- For convenience and flexibility, this package defines a three-parameter type: +-- @ +-- data RevDiff a b c = MkRevDiff {value :: c, backprop :: b -> a} +-- @ +-- +-- This generalized structure allows us to separate the types involved in the +-- forward pass (the value of type @c@) from those used in the backward pass +-- (the gradient computation from @b@ to @a@). +-- +-- We also provide a specialized type alias for common use cases: +-- +-- > type RevDiff' a b = RevDiff (CT a) (CT b) b +-- +-- This three-parameter design enables powerful abstraction capabilities. +-- In particular, it allows us to implement both profunctor and Van Laarhoven +-- representations for differentiable functions, providing multiple ways to +-- compose and manipulate automatic differentiation computations. +-- +-- These alternative representations can be accessed through the conversion +-- functions `fromProfunctors`, `toProfunctors`, `fromVanLaarhoven`, and +-- `toVanLaarhoven`, each offering different compositional properties suited +-- to various use cases. +-- +-- Generalizing this to arbitrary compositions of differentiable functions +-- is straightforward +-- and follows the same backpropagation principle. + +-- $how-it-works-functions-overloading +-- +-- Our goal now is to make functions such as @sin@ and @(*)@ differentiable, +-- while still being able to use them as ordinary functions — in particular, +-- to apply them to arguments and compose them using '(.)'. +-- +-- To this end, we follow the approach used in the +-- [numhask](https://hackage.haskell.org/package/numhask) package. +-- In this package, functions like `sin` and `(*)` are defined as polymorphic methods +-- of typeclasses. +-- +-- For instance, the function `sin` is a method of the typeclass: +-- +-- @ +-- class TrigField a where +-- ... +-- sin :: a -> a +-- @ +-- +-- Similarly, multiplication is defined via: +-- +-- @ +-- class Multiplicative a where +-- ... +-- (*) :: a -> a -> a +-- @ +-- +-- These typeclasses have instances, for example, for the type `Float`. +-- Instancies for `SE` are provided in +-- [simple-expr](https://hackage.haskell.org/package/simple-expr) +-- package. +-- +-- To make `sin` and `(*)` differentiable in the backpropagation framework, +-- it is enough to define instances for: +-- +-- > RevDiff Float Float +-- +-- These instances can be implemented as follows. +-- (The type family 'CT' can be ignored for now, we may assume @CT a ~ a@ for simplicity.) +-- +-- @ +-- instance Additive (CT t) => TrigField (RevDiff t Float) where +-- ... +-- sin :: RevDiff t Float -> RevDiff t Float +-- sin MkRevDiff {value = x, backprop = backpropX} = MkRevDiff { +-- value = sin x, +-- backprop = backpropX . ((cos x) *) +-- } +-- @ +-- +-- @ +-- instance Additive (CT t) => Multiplicative (RevDiff t Float) where +-- ... +-- (*) :: RevDiff t Float -> RevDiff t Float -> RevDiff t Float +-- MkRevDiff x backpropX * MkRevDiff y backpropY = +-- MkRevDiff { +-- value = x * y, +-- backprop = backpropX . (y *) + backpropY . (x *) +-- } +-- @ +-- +-- To compute /second derivatives/, we can use a nested type like: +-- +-- > RevDiff (RevDiff Float Float) (RevDiff Float Float) +-- +-- That is, the outer layer performs backpropagation through the inner derivative. +-- Similarly, higher-order derivatives can be obtained by nesting @RevDiff@ types further. +-- +-- These instances can also be generalized to any numeric type @a@, not just `Float`, +-- allowing us to define /infinitely differentiable/ functions. + +-- $how-it-works-tangent-space +-- +-- In this section, we explain the purpose of the type family `CT` and how it is used. +-- In most practical cases, we can assume @CT a ~ a@ and safely ignore it. +-- +-- One of the challenges in automatic differentiation is that +-- the value type of a function and the value type of its derivative +-- may not coincide, even when the input is scalar (for example, a real number). +-- From a mathematical perspective, this corresponds to the need to work with +-- tangent and cotangent bundles. +-- +-- For instance, if a scalar-valued function takes a vector as input, +-- its derivative is also vector-valued. +-- However, this correspondence does not hold in general. +-- +-- Consider the case where the input is an infinite sequence +-- (such as an infinte list or stream). +-- The derivative of a function on such inputs is a finite-length sequence +-- (a sparse or finite-support vector; see the `FiniteSupportStream` type). +-- Conversely, a function on finite-support streams has a derivative +-- that is generally represented as an infinite stream. +-- +-- This distinction arises because the convolution of two infinite streams +-- is not defined in general. +-- On the other hand, every linear functional on streams can be represented +-- as a convolution with a finite-length vector. +-- Conversely, a convolution with a finite-length vector defines +-- a linear functional on infinite streams. +-- +-- Similarly, any linear functional on all bounded finite-length vectors +-- can be represented as a convolution with an infinite sequence. +-- And conversely, convolution with an infinite sequence yields +-- a linear functional on finite-length vectors. +-- +-- These distinctions are not just mathematical formalisms, +-- but real practical constraints. +-- In particular, the convolution of two streams cannot be calculated. +-- In this package, the Haskell type system cannot safely express, for example, +-- that the derivative of a function over `Stream` should be of type `Stream`, +-- or that the derivative of a function over `FiniteSupportStream` +-- should also be of type `FiniteSupportStream`. +-- +-- Another example comes from geometry. +-- Consider a function defined on the surface of a unit sphere in 3D space. +-- In this case, the derivative at each point must lie in the tangent plane +-- to the sphere at that point — not just any 3D vector. +-- Therefore, the derivative type differs from the function's output type. +-- +-- More generally, in differential geometry, +-- functions are defined on manifolds, +-- and their derivatives take values in the cotangent bundle of the manifold. +-- +-- To model this distinction in Haskell, +-- we introduce the type family `CT`, which stands for "cotangent type". +-- For example: +-- +-- > CT Float = Float +-- +-- > CT (a, b) = (CT a, CT b) +-- +-- > CT (Vector a) = Vector (CT a) +-- +-- > CT (Stream a) = FiniteSupportStream (CT a) +-- +-- > CT (FiniteSupportStream a) = Stream (CT a) +-- +-- > CT (E2NormedVector a) = Vector (CT a) +-- +-- The type family `CT` is defined as a composition of two type families: +-- `Tangent` and `Dual`: +-- +-- > CT a = Dual (Tangent a) +-- +-- The `Tangent` family describes the type of tangent vectors. +-- For example: +-- +-- > Tangent Float = Float +-- +-- > Tangent (Stream a) = Stream (Tangent a) +-- +-- > Tangent (FiniteSupportStream a) = Tangent (FiniteSupportStream a) +-- +-- > Tangent (E2NormedVector a) = Vector (Tangent a) +-- +-- The `Dual` family encodes the dual space (linear functionals): +-- +-- > Dual Float = Float +-- +-- > Dual (Stream a) = FiniteSupportStream (Dual a) +-- +-- > Dual (FiniteSupportStream a) = Stream (Dual a) +-- +-- > Dual (E2NormedVector a) = Undefined +-- +-- In order to support differentiation over a new type that is not already +-- handled by this package, one needs to define appropriate instances +-- for both `Tangent` and `Dual` for that type. + +-- $differentiation-for-structured-types +-- +-- This library supports the differentiation of functions of type +-- @ f :: a -> b @ +-- for potentially any types @a@ and @b@. +-- Thus, the derivative operator has the type: +-- +-- > (a -> b) -> (a -> c) +-- +-- The argument type @a@ is the same for both the original function +-- @f :: a -> b@ and its derivative +-- @f' :: a -> c@. +-- However, the result type @c@ of the derivative +-- depends in a non-trivial way on both @a@ and @b@. +-- +-- For example, the derivative of a vector-valued function of a tuple +-- is a vector of tuples: +-- +-- >>> import Numeric.InfBackprop.Utils.SizedVector (BoxedVector) +-- +-- @ +-- f :: (Float, Float) -> BoxedVector 3 Float +-- f' :: (Float, Float) -> BoxedVector 3 (Float, Float) +-- @ +-- +-- To illustrate the approach, consider a representative example: +-- a function from a tuple to a 3D vector. +-- +-- >>> :{ +-- sphericToVec :: (TrigField a) => (a, a) -> BoxedVector 3 a +-- sphericToVec (theta, phi) = +-- DVGS.fromTuple (cos theta * cos phi, cos theta * sin phi, sin theta) +-- :} +-- +-- We will use the `customArgValDerivative` operator, which takes three arguments: +-- +-- 1. The argument structure descriptor — in this case, `tupleArg`, +-- which is used for the @(a, a)@ input. +-- +-- 2. The value structure descriptor — in this case, `boxedVectorVal`, +-- used for output type @BoxedVector 3 _@. +-- +-- 3. The function to differentiate — in this case, @sphericToVec@. +-- +-- The derivative is then defined as: +-- +-- >>> import Debug.SimpleExpr.Utils.Algebra (IntegerPower) +-- >>> :{ +-- sphericToVec'V1 :: (TrigField a, ExpField a, IntegerPower a, a ~ CT a) => +-- (a, a) -> BoxedVector 3 (a, a) +-- sphericToVec'V1 = customArgValDerivative tupleArg boxedVectorVal sphericToVec +-- :} +-- +-- The type family `CT` and its meaning are explained in section +-- [Tangent and cotangent spaces](#g:how-45-it-45-works-45-tangent-45-space). +-- For now, it can be ignored. +-- The types and definitions of `tupleArg` and `boxedVectorVal`, +-- as well as how to construct them for other types, +-- will be covered in the following sections. +-- +-- Alternatively, the argument and value structure can be inferred automatically +-- using `autoArg` and `autoVal`: +-- +-- >>> :{ +-- sphericToVec'V2 :: (TrigField a, ExpField a, IntegerPower a, a ~ CT a) => +-- (a, a) -> BoxedVector 3 (a, a) +-- sphericToVec'V2 = customArgValDerivative autoArg boxedVectorVal sphericToVec +-- :} +-- +-- >>> :{ +-- sphericToVec'V3 :: (TrigField a, ExpField a, IntegerPower a, a ~ CT a) => +-- (a, a) -> BoxedVector 3 (a, a) +-- sphericToVec'V3 = customArgValDerivative tupleArg autoVal sphericToVec +-- :} +-- +-- Automatically deriving both the argument and value types +-- is often problematic due to type inference limitations in Haskell. +-- +-- In summary, there are three common approaches to managing types +-- in the derivative operator for a function @f :: a -> b@: +-- +-- 1. Define a derivative operator specialized for specific types @a@ and @b@. +-- +-- 2. Define a derivative operator that is polymorphic in the result type @b@, +-- but has a fixed argument type @a@. +-- See section +-- [Structured Value Type](#g:differentiation-45-for-45-structured-45-types-45-structured-45-value). +-- +-- 3. Define a derivative operator that is polymorphic in the argument type @a@, +-- but has a fixed result type @b@. +-- See `scalarValDerivative` in the subsection +-- [Structured Argument Type](#g:differentiation-45-for-45-structured-45-types-45-structured-45-argument-45-type). + +-- $differentiation-for-structured-types-structured-value +-- +-- This section explains how to compute derivatives of functions whose values +-- have structured types (e.g., tuples, vectors, streams, or nested combinations). +-- +-- We begin with +-- [basic examples](#g:differentiation-45-for-45-structured-45-types-45-structured-45-value-45-basic-45-examples) +-- to demonstrate how derivatives work for common structured types. +-- +-- Then, in +-- [custom derivative operators and value structure descriptors](#g:differentiation-45-for-45-structured-45-types-45-structured-45-value-45-custom-45-derivative), +-- we explain how to define derivative operators for any structured value type using +-- custom descriptors. +-- +-- In +-- [how it works: structured value types](#g:differentiation-45-for-45-structured-45-types-45-structured-45-value-45-how-45-it-45-works), +-- we delve into the type signatures and the underlying idea behind value type descriptors. +-- +-- Finally, in +-- [defining custom differentiable value types](#g:differentiation-45-for-45-structured-45-types-45-structured-45-value-45-defining-45-custom-45-value-45-type), +-- we outline how to define your own differentiable types—beyond the scope +-- of the built-in descriptors provided by this package. + +-- $differentiation-for-structured-types-structured-value-basic-examples +-- +-- ==== Tuple-valued function +-- As a first example, we define a symbolic function @f@ of one variable +-- that returns a tuple of two values. +-- +-- >>> :{ +-- f :: TrigField a => a -> (a, a) +-- f t = (cos t, sin t) +-- :} +-- +-- Define a symbolic variable @t@, as shown in the section +-- [Derivatives for Symbolic Expressions](#g:quick-45-start-45-derivatives-45-for-45-symbolic-45-expressions). +-- +-- >>> t = variable "t" +-- >>> f t +-- (cos(t),sin(t)) +-- +-- The simplest way to take the derivative is to use the `scalarArgDerivative` operator, +-- which is polymorphic over the function's value type. +-- It is a polymorphic version of `customArgValDerivative` operator considered +-- in the beginning of the section +-- [Differentiation for Structured Types](#g:differentiation-45-for-45-structured-45-types) +-- It is defined as: +-- +-- > scalarArgDerivative = customArgValDerivative scalarVal autoVal +-- +-- The first argument `scalarVal` indicates that the function's argument type is scalar. +-- The second argument `autoVal` tells the system to infer the value type automatically. +-- +-- The general type signature of `scalarArgDerivative` is discussed in a later section. +-- In this case, it simplifies to: +-- +-- @ +-- scalarArgDerivative :: Multiplicative (CT a) => +-- (RevDiff a a -> (RevDiff a a, RevDiff a a)) -> +-- a -> +-- (CT a, CT a) +-- @ +-- +-- We can now compute derivatives as follows: +-- +-- >>> f' = simplify . scalarArgDerivative f :: SE -> (SE, SE) +-- >>> f' t +-- (-(sin(t)),cos(t)) +-- +-- >>> f'' = simplify . scalarArgDerivative (scalarArgDerivative f) :: SE -> (SE, SE) +-- >>> f'' t +-- (-(cos(t)),-(sin(t))) +-- +-- >>> (scalarArgDerivative (scalarArgDerivative f)) t :: (SE, SE) +-- (-(cos(t)*(1*1))+0,(-(sin(t))*(1*1))+0) +-- +-- >>> temp t = -((cos t)*(one * one)) + zero +-- +-- -- >>> (scalarArgDerivative temp) t :: SE +-- +-- >>> import Debug.SimpleExpr.Utils.Algebra ((^)) +-- +-- >>> (scalarArgDerivative (scalarArgDerivative (scalarArgDerivative f))) (0.0 :: Float) :: (Float, Float) +-- (0.0,-1.0) +-- +-- >>> (scalarArgDerivative exp) t :: SE +-- exp(t)*1 +-- +-- >>> (scalarArgDerivative (scalarArgDerivative (exp))) t :: SE +-- (exp(t)*(1*1))+0 +-- +-- >>> f''' = simplify . scalarArgDerivative (scalarArgDerivative (scalarArgDerivative f)) :: SE -> (SE, SE) +-- >>> f''' t +-- (sin(t),-(cos(t))) +-- +-- Note that all derivateive function argiment types are the same +-- as the original function, but the value typea are different. +-- Here the the polymorphic preoperty of the `scalarArgDerivative` operator +-- comes into play, allowing us to differentiate functions without explicit +-- type annotations. +-- +-- ==== Vector-valued function +-- In the next example, we take the derivative of a vector-valued symbolic function @v@ +-- using boxed vectors from the +-- [vector-sized](https://hackage.haskell.org/package/vector-sized) library. +-- +-- >>> import Numeric.InfBackprop.Utils.SizedVector (BoxedVector) +-- +-- >>> :{ +-- v :: SymbolicFunc a => a -> BoxedVector 3 a +-- v t = DVGS.fromTuple ( +-- unarySymbolicFunc "v_x" t, +-- unarySymbolicFunc "v_y" t, +-- unarySymbolicFunc "v_z" t +-- ) +-- :} +-- +-- >>> v t +-- Vector [v_x(t),v_y(t),v_z(t)] +-- +-- >>> v' = simplify . scalarArgDerivative v :: SE -> BoxedVector 3 SE +-- >>> v' t +-- Vector [v_x'(t),v_y'(t),v_z'(t)] +-- +-- ==== Stream-valued function +-- Other data types, including lazy types such as streams from the +-- [stream](https://hackage.haskell.org/package/stream) +-- library, +-- can also be differentiated. +-- +-- >>> :{ +-- s :: SymbolicFunc a => a -> Stream a +-- s t = fromList [unarySymbolicFunc ("s_" <> show n) t | n <- [0..]] +-- :} +-- +-- >>> take 5 (s t) +-- [s_0(t),s_1(t),s_2(t),s_3(t),s_4(t)] +-- +-- >>> :{ +-- s' :: SE -> Stream SE +-- s' = simplify . scalarArgDerivative s +-- :} +-- +-- >>> take 5 (s' t) +-- [s_0'(t),s_1'(t),s_2'(t),s_3'(t),s_4'(t)] +-- +-- ==== 4. Nested structured-valued function +-- We can also differentiate functions returning values in nested types. For example: +-- +-- >>> :{ +-- g :: SymbolicFunc a => a -> (BoxedVector 3 a, Stream a) +-- g t = (v t, s t) +-- :} +-- +-- This function has the type @a -> (BoxedVector 3 a, Stream a)@. +-- Automatic differentiation remains straightforward: +-- +-- >>> :{ +-- g' :: SE -> (BoxedVector 3 SE, Stream SE) +-- g' = simplify . scalarArgDerivative g +-- :} +-- +-- >>> fst $ g' t +-- Vector [v_x'(t),v_y'(t),v_z'(t)] +-- +-- >>> take 5 $ snd $ g' t +-- [s_0'(t),s_1'(t),s_2'(t),s_3'(t),s_4'(t)] + +-- $differentiation-for-structured-types-structured-value-custom-derivative +-- +-- Instead of the polymorphic `scalarArgDerivative` operator, +-- which is defined as +-- +-- > scalarArgDerivative = customArgValDerivative scalarArg autoVal +-- +-- we can use a more specialized version tailored to the expected value type. +-- These customized derivatives still use `customArgValDerivative` with a specific +-- value structure descriptor but not `autoVal`. +-- +-- ==== Tuple-valued function +-- +-- Consider again the example from the previous subsection: +-- +-- >>> scalarTupleDerivative = customArgValDerivative scalarArg tupleVal +-- +-- Here, `scalarArg` indicates that +-- the input of the function being differentiated +-- is a scalar value, and +-- `tupleVal` indicates that the output of the function being differentiated +-- is a tuple of scalar values. +-- +-- >>> :{ +-- t :: SE +-- t = variable "t" +-- f :: TrigField a => a -> (a, a) +-- f t = (cos t, sin t) +-- f' :: SE -> (SE, SE) +-- f' = simplify . scalarTupleDerivative f +-- :} +-- +-- >>> f' t +-- (-(sin(t)),cos(t)) +-- +-- ==== Vector-valued function +-- +-- Similarly, we can define a derivative operator for a vector-valued function @v@: +-- +-- >>> scalarTupleBoxedVectorDerivative = customArgValDerivative scalarArg boxedVectorVal +-- +-- Here, `boxedVectorVal` declares that the function returns a boxed vector +-- of scalar values. +-- +-- ==== Nested structured output function +-- +-- In the third example from the previous subsection: +-- +-- >>> import Numeric.InfBackprop.Utils.SizedVector (BoxedVector) +-- +-- >>> :{ +-- g :: SymbolicFunc a => a -> (BoxedVector 3 a, Stream a) +-- g = undefined +-- :} +-- +-- the value type of @g@ is more sophisticated, so we must construct +-- a custom value structure manually: +-- +-- >>> tupleBoxedVectorStreamVal = mkTupleVal (mkBoxedVectorVal scalarVal) (mkStreamVal scalarVal) +-- >>> scalarTupleBoxedVectorStreamDerivative = customArgValDerivative scalarArg tupleBoxedVectorStreamVal +-- >>> _ = scalarTupleBoxedVectorStreamDerivative g :: SE -> (BoxedVector 3 SE, Stream SE) +-- +-- Here: +-- +-- - 'mkTupleVal' constructs a value descriptor for a tuple, +-- - 'mkBoxedVectorVal' constructs a value descriptor for a boxed vector, +-- - 'mkStreamVal' constructs a value descriptor for a stream, +-- - and 'scalarVal' denotes the scalar leaf type. +-- +-- In general, these building blocks combine to define custom value descriptors. +-- For example: +-- +-- @ +-- tupleVal = mkTupleVal scalarVal +-- boxedVectorVal = mkBoxedVectorVal scalarVal +-- streamVal = mkStreamVal scalarVal +-- @ +-- +-- And for a scalar-valued function, we simply use: +-- +-- > scalarScalarDerivative = customArgValDerivative scalarArg scalarVal + +-- $differentiation-for-structured-types-structured-value-how-it-works +-- +-- This section explains how the general backpropagation mechanism operates +-- at the level of function result (value) types. +-- +-- ==== Derivative Operator Type Signature +-- +-- To differentiate a scalar-to-scalar function @f :: a -> b@, we use its +-- differentiable form: +-- +-- > f :: RevDiff a a -> RevDiff a b +-- +-- (see the section +-- [How it works: core type `RevDiff`](#g:how-45-it-45-works-45-core-45-type-45-revdiff)). +-- +-- For functions returning structured values, we generalize this to: +-- +-- > f :: RevDiff a a -> c +-- +-- where @c@ is a structured result built from `RevDiff a b` values. +-- We then use a \value structure descriptor\ of type @c -> d@ +-- to extract the final derivative result @d@ from the structure @c@. +-- +-- The resulting derivative operator has the following type: +-- +-- @ +-- scalarCustomArgDerivative :: +-- (c -> d) -> -- how to extract the final output +-- (RevDiff a a -> c) -> -- the differentiable function +-- (a -> d) -- scalar input to final output +-- scalarCustomArgDerivative = customArgValDerivative scalarArg +-- @ +-- +-- Here, the first argument of type @c -> d@ transforms the intermediate structured result +-- into the final derivative value. +-- +-- In fact, @scalarCustomArgDerivative@ is simply function composition: +-- +-- > scalarCustomArgDerivative = (.) +-- +-- ==== Value Descriptor Examples +-- +-- Common value structure descriptors include in particular: +-- +-- 1. /Scalar value/ +-- +-- > scalarVal :: Multiplicative (CT b) => RevDiff a b -> CT a +-- +-- Converts a single differentiable value into a scalar result. +-- +-- 2. /Tuple/ +-- +-- > tupleVal :: +-- > (Multiplicative (CT b0), Multiplicative (CT b1)) => +-- > (RevDiff a0 b0, RevDiff a1 b1) -> (CT a0, CT a1) +-- +-- Converts a tuple of differentiable values into a tuple of scalars. +-- +-- 3. /Boxed Vector/ +-- +-- > boxedVectorVal :: +-- > Multiplicative (CT b) => +-- > BoxedVector n (RevDiff a b) -> BoxedVector n (CT a) +-- +-- Converts a boxed Vector of differentiable values into a boxed Vector of scalars. +-- +-- 4. /Stream/ +-- +-- > streamVal :: +-- > Multiplicative (CT b) => +-- > Stream (RevDiff a b) -> Stream (CT a) +-- +-- Converts a stream of differentiable values into a stream of scalars. +-- +-- 5. /Nested structure/ +-- +-- For example, a function returning a tuple of a boxed vector and a stream: +-- +-- > tupleBoxedVectorStreamVal :: +-- > Multiplicative (CT b) => +-- > (BoxedVector n (RevDiff a0 b0), Stream (RevDiff a1 b1)) -> +-- > (BoxedVector n (CT a), Stream (CT a)) +-- +-- ==== Constructing Value Descriptors +-- +-- You can construct value descriptors using standard higher-order functions: +-- +-- @ +-- mkTupleVal :: (a0 -> b0) -> (a1 -> b1) -> (a0, a1) -> (b0, b1) +-- mkTupleVal = cross +-- +-- mkBoxedVectorVal :: (a -> b) -> BoxedVector n a -> BoxedVector n b +-- mkBoxedVectorVal = fmap +-- +-- mkStreamVal :: (a -> b) -> Stream a -> Stream b +-- mkStreamVal = fmap +-- @ +-- +-- This means that to define a derivative for any custom structured type @MyType a@, +-- you only need to implement: +-- +-- > myTypeVal :: Multiplicative (CT b) => MyType (RevDiff a b) -> MyType (CT a) +-- +-- A typical approach is to define a mapping function: +-- +-- > mkMyTypeVal :: (a -> b) -> MyType a -> MyType b +-- +-- and then obtain the value descriptor by applying it to `scalarVal`: +-- +-- > myTypeVal = mkMyTypeVal scalarVal +-- +-- This approach allows you to differentiate functions returning arbitrarily +-- nested combinations of types, as we did above with tuple @(,)@, +-- `BoxedVector`@ n@, and `Stream`. + +-- $differentiation-for-structured-types-structured-value-defining-custom-value-type +-- +-- ==== Making Custom Scalar Type Differentiable +-- +-- To make a scalar type @a@ differentiable, it is necessary and sufficient to: +-- +-- 1. Define the type families `Tangent` for @a@ and `Dual` for `Tangent a` +-- (see [Tangent and Cotangent Spaces](#g:how-45-it-45-works-45-tangent-45-space)). +-- +-- 2. Ensure that the type +-- +-- > type CT a = Dual (Tangent a) +-- +-- is an instance of `Multiplicative`. +-- +-- The second condition is required to initialize the backpropagation process +-- with the value `one`. +-- +-- ==== Making Custom Type Constructors Differentiable +-- +-- To define derivatives over a custom type constructor @f :: Type -> Type@, +-- the recommended approach is: +-- +-- 1. Define the /value descriptor/: +-- +-- > mkFVal :: (a -> b) -> f a -> f b +-- +-- In most cases, this is just `fmap`, or an optimized equivalent (see previous section). +-- +-- 2. Provide an instance of the @AutoDifferentiableValue@ class: +-- +-- > instance (AutoDifferentiableValue a b) => +-- > AutoDifferentiableValue (f a) (f b) where +-- > autoVal :: f a -> f b +-- > autoVal = mkFVal autoVal +-- +-- This recursively applies `autoVal` within the structure of @f a@. +-- +-- For more sophisticated custom types (e.g. higher-kinded types such as +-- @g :: Type -> Type -> Type@), refer to the implementation of the instance for +-- tuples @(,)@ in @AutoDifferentiableValue@ for guidance. + +-- $differentiation-for-structured-types-structured-argument-type +-- +-- In this section, we consider how to differentiate a function +-- with a structured or nontrivial argument type. +-- +-- The simplest way to compute the derivative of a scalar-valued function (i.e. gradient) +-- is by using the `scalarValDerivative` operator. +-- This operator is polymorphic over the function’s argument type, +-- but it is restricted to functions that return scalar values. +-- +-- In terms of the more general `customArgValDerivative` operator +-- [Differentiation for Structured Types](#g:differentiation-45-for-45-structured-45-types), +-- the `scalarValDerivative` is equivalent to: +-- +-- > scalarValDerivative = customArgValDerivative autoArg scalarVal +-- +-- Here, the first argument `autoArg` indicates that the argument type +-- (i.e. the structure of the input) is inferred automatically. +-- +-- The second argument `scalarVal` specifies that the return value of the function +-- must be a scalar. + +-- $differentiation-for-structured-types-structured-argument-type-basic-examples +-- +-- ==== Gradient over the Euclidean Norm of a Vector +-- Our first example involves a function over a sized boxed vector, +-- `BoxedVector`. We define the squared Euclidean norm of a 3-dimensional vector: +-- +-- >>> import Debug.SimpleExpr.Utils.Algebra (IntegerPower, (^), MultiplicativeAction) +-- >>> import Numeric.InfBackprop.Utils.SizedVector (BoxedVector) +-- +-- >>> :{ +-- eNorm2 :: (IntegerPower a, Additive a) => BoxedVector 3 a -> a +-- eNorm2 x = foldl' (+) zero (fmap (^2) x) +-- :} +-- +-- This is not the most efficient way to define a function on large vectors, +-- but for this example, we focus on type signatures and type inference +-- rather than performance. +-- +-- The gradient of @eNorm2@ can be computed as: +-- +-- >>> :{ +-- eNorm2' :: ( +-- IntegerPower a, +-- MultiplicativeAction Integer a, +-- Distributive a, +-- CT a ~ a +-- ) => BoxedVector 3 a -> BoxedVector 3 a +-- eNorm2' = scalarValDerivative eNorm2 +-- :} +-- +-- As usual, `scalarValDerivative` can be applied to symbolic expressions, +-- such as values of type `SE`: +-- +-- >>> x = variable "x" +-- >>> y = variable "y" +-- >>> z = variable "z" +-- >>> r = DVGS.fromTuple (x, y, z) :: BoxedVector 3 SE +-- >>> simplify $ eNorm2' r :: BoxedVector 3 SE +-- Vector [2*x,2*y,2*z] +-- +-- It also works with numeric types like `Float`: +-- +-- >>> v = DVGS.fromTuple (1, 2, 3) :: BoxedVector 3 Float +-- >>> eNorm2' v :: BoxedVector 3 Float +-- Vector [2.0,4.0,6.0] +-- +-- ==== Gradient over a Stream +-- The `Stream` type can also be used as an argument. +-- However, note that the result of the gradient is not a `Stream`, +-- but rather a bounded stream: `FiniteSupportStream`. +-- See +-- [Tangent and Cotangent Spaces](#g:how-45-it-45-works-45-tangent-45-space) +-- for a brief explanation. +-- +-- Define a formal series +-- +-- \[ +-- s = s_0, s_1, s_2, s_3, \ldots +-- \] +-- +-- as: +-- +-- >>> s = fromList [variable ("s_" <> show n) | n <- [0 :: Int ..]] :: Stream SE +-- +-- Next, define a function that sums the first four elements of the stream: +-- +-- \[ +-- s \mapsto s_0 + s_1 + s_2 + s_3 +-- \] +-- +-- >>> take4Sum = NH.sum . take 4 :: Additive a => Stream a -> a +-- >>> simplify $ take4Sum s :: SE +-- s_0+(s_1+(s_2+s_3)) +-- +-- The gradient of this function can be defined as: +-- +-- >>> :{ +-- take4Sum' :: (Distributive a, Distributive (CT a)) => +-- Stream a -> FiniteSupportStream (CT a) +-- take4Sum' = scalarValDerivative take4Sum +-- :} +-- +-- >>> simplify $ take4Sum' s +-- [1,1,1,1,0,0,0,... +-- +-- The result is a finite support stream of the form: +-- +-- \[ +-- 1, 1, 1, 1, 0, 0, 0, \ldots +-- \] +-- +-- as expected. +-- +-- ==== Gradinenet over Nested Structured Types +-- +-- The `scalarValDerivative` operator can also handle more complex input types. +-- For example, consider a function @g@ that takes both a 3-vector and a stream: +-- +-- >>> :{ +-- g :: (IntegerPower a, Distributive a) => +-- (BoxedVector 3 a, Stream a) -> a +-- g (v, s) = eNorm2 v + take4Sum s +-- :} +-- +-- Its gradient can be computed as: +-- +-- >>> :{ +-- g' :: (IntegerPower a, MultiplicativeAction Integer a, Distributive a, CT a ~ a) => +-- (BoxedVector 3 a, Stream a) -> (BoxedVector 3 a, FiniteSupportStream a) +-- g' = scalarValDerivative g +-- :} +-- +-- Evaluating the gradient at @(r, s)@ gives: +-- +-- >>> simplify $ fst $ g' (r, s) :: BoxedVector 3 SE +-- Vector [2*x,2*y,2*z] +-- +-- >>> simplify $ snd $ g' (r, s) :: FiniteSupportStream SE +-- [1,1,1,1,0,0,0,... +-- +-- as expected. + +-- $differentiation-for-structured-types-structured-argument-type-custom-gradient +-- +-- The `scalarValDerivative` operator from the previous section is polymorphic over +-- the argument type, but it works only for scalar-valued functions. +-- +-- In this section, we consider how to /fix the argument type/ while keeping the +-- value type polymorphic. This is especially useful when computing second or higher-order +-- derivatives. +-- +-- ==== Derivatives over a Tuple of Scalars +-- We begin with a function over a tuple of two scalars, which is equivalent +-- to a function of two arguments. +-- +-- As an example, consider the product of symbolic functions @f@ and @g@ applied +-- to separate arguments: +-- +-- >>> :{ +-- x = variable "x" +-- y = variable "y" +-- f :: SymbolicFunc a => a -> a +-- f = unarySymbolicFunc "f" +-- g :: SymbolicFunc a => a -> a +-- g = unarySymbolicFunc "g" +-- h :: (SymbolicFunc a, Multiplicative a) => (a, a) -> a +-- h (x, y) = f x * g y +-- :} +-- +-- Evaluating @h@ at @(x, y)@ gives: +-- +-- >>> h (x, y) :: SE +-- f(x)*g(y) +-- +-- First, consider the derivative operator: +-- +-- >>> tupleScalarDerivative = customArgValDerivative tupleArg scalarVal +-- +-- It can be applied as follows: +-- +-- >>> h' = simplify . tupleScalarDerivative h :: (SE, SE) -> (SE, SE) +-- >>> h' (x, y) +-- (f'(x)*g(y),g'(y)*f(x)) +-- +-- However, we cannot use @tupleScalarDerivative@ to compute the second derivative of @h@, +-- because it is restricted to scalar-valued functions. It is not polymorphic in the +-- value type, unlike `tupleArgDerivative`. +-- +-- To define a version suitable for higher-order derivatives, we define: +-- +-- > tupleArgDerivative = customArgValDerivative tupleArg autoVal +-- +-- This operator is practically equivalent to `twoArgsDerivative` from the section +-- [Gradient over a Two-Argument Function](#g:quick-45-start-45-function-45-of-45-two-45-argument-45-functions), +-- except that it works on uncurried arguments. +-- +-- We can now compute the derivative of @h@ as: +-- +-- >>> :{ +-- h' :: (SE, SE) -> (SE, SE) +-- h' = simplify . tupleArgDerivative h +-- :} +-- +-- >>> h' (x, y) +-- (f'(x)*g(y),g'(y)*f(x)) +-- +-- Thanks to the polymorphism of `tupleArgDerivative`, we can compute higher-order +-- derivatives of @h@: +-- +-- Second derivative: +-- +-- >>> :{ +-- h'' :: (SE, SE) -> ((SE, SE), (SE, SE)) +-- h'' = simplify . tupleArgDerivative (tupleArgDerivative h) +-- :} +-- +-- >>> h'' (x, y) +-- ((f''(x)*g(y),g'(y)*f'(x)),(f'(x)*g'(y),g''(y)*f(x))) +-- +-- Third derivative: +-- +-- >>> :{ +-- h''' :: (SE, SE) -> (((SE, SE), (SE, SE)), ((SE, SE), (SE, SE))) +-- h''' = simplify . tupleArgDerivative (tupleArgDerivative (tupleArgDerivative h)) +-- :} +-- +-- >>> h''' (x, y) +-- (((f'''(x)*g(y),g'(y)*f''(x)),(f''(x)*g'(y),g''(y)*f'(x))),((f''(x)*g'(y),g''(y)*f'(x)),(f'(x)*g''(y),g'''(y)*f(x)))) +-- +-- ==== Derivatives over Boxed Vectors +-- The next example demonstrates derivatives over boxed vectors. +-- +-- > boxedVectorArgDerivative = customArgValDerivative boxedVectorArg autoVal +-- +-- Recall the function @eNorm2@, which computes the squared Euclidean norm +-- of a 3-dimensional vector: +-- +-- >>> import Numeric.InfBackprop.Utils.SizedVector (BoxedVector) +-- +-- >>> :{ +-- eNorm2 :: Distributive a => BoxedVector 3 a -> a +-- eNorm2 x = foldl' (+) zero (x * x) +-- :} +-- +-- We apply `boxedVectorArgDerivative` as follows: +-- +-- >>> v = DVGS.fromTuple (1, 2, 3) :: BoxedVector 3 Float +-- >>> boxedVectorArgDerivative eNorm2 v :: BoxedVector 3 Float +-- Vector [2.0,4.0,6.0] +-- +-- The second derivative gives the Hessian matrix represented here +-- as a boxed Vector of boxed Vectors: +-- +-- >>> boxedVectorArgDerivative (boxedVectorArgDerivative eNorm2) v :: BoxedVector 3 (BoxedVector 3 Float) +-- Vector [Vector [2.0,0.0,0.0],Vector [0.0,2.0,0.0],Vector [0.0,0.0,2.0]] +-- +-- The third derivative is a rank-3 tensor filled with zeros: +-- +-- >>> boxedVectorArgDerivative (boxedVectorArgDerivative (boxedVectorArgDerivative eNorm2)) v :: BoxedVector 3 (BoxedVector 3 (BoxedVector 3 Float)) +-- Vector [Vector [Vector [0.0,0.0,0.0],Vector [0.0,0.0,0.0],Vector [0.0,0.0,0.0]],Vector [Vector [0.0,0.0,0.0],Vector [0.0,0.0,0.0],Vector [0.0,0.0,0.0]],Vector [Vector [0.0,0.0,0.0],Vector [0.0,0.0,0.0],Vector [0.0,0.0,0.0]]] + +-- $differentiation-for-structured-types-structured-argument-type-how-it-works +-- +-- In order to compute a derivative, we need a function with the following signature: +-- +-- > f :: RevDiff a a -> RevDiff a b +-- +-- (See section +-- [Core type: RevDiff](#g:how-45-it-45-works-45-core-45-type-45-RevDiff).) +-- +-- Suppose we want to differentiate a scalar-valued function of a tuple @(a, b)@: +-- +-- > f :: (a, b) -> c +-- +-- Our strategy is to exploit the polymorphism of @f@ +-- with respect to the types @a@ and @b@. +-- This means that @f@ must also support the type: +-- +-- > f :: (RevDiff t a, RevDiff t b) -> RevDiff t c +-- +-- To differentiate such a function, we need a way to transform a single input of type +-- @RevDiff a (b0, b1)@ into a pair of inputs @(RevDiff a b0, RevDiff a b1)@. +-- +-- This is exactly the role of the /argument structure derscriptor/: +-- +-- > tupleArg :: (Additive (CT b0), Additive (CT b1)) => +-- > RevDiff a (b0, b1) -> (RevDiff a b0, RevDiff a b1) +-- +-- Using this, we can define a new function: +-- +-- > tupleArg . f :: RevDiff a (b0, b1) -> RevDiff a c +-- +-- and apply `simpleDerivative`: +-- +-- > simpleDerivative (tupleArg . f) :: (b0, b1) -> (CT b0, CT b1) +-- +-- More generally, the expression: +-- +-- > customArgValDerivative arg scalarVal f +-- +-- is equivalent to: +-- +-- > simpleDerivative (arg . f) +-- +-- Similarly, we can define argument structure descriptor for Vectors and streams: +-- +-- > boxedVectorArg :: (Additive (CT b), KnownNat n) => +-- > RevDiff a (BoxedVector n b) -> BoxedVector n (RevDiff a b) +-- +-- > streamArg :: Additive (CT b) => +-- > RevDiff a (Stream b) -> Stream (RevDiff a b) +-- +-- We can also combine them for more complex structured arguments. +-- For example: +-- +-- >>> import Numeric.InfBackprop.Utils.SizedVector (BoxedVector) +-- +-- >>> :{ +-- tupleBoxedVectorStreamArg :: (Additive b, Additive c, KnownNat n) => +-- RevDiff a (BoxedVector n b, FiniteSupportStream c) (BoxedVector n d, Stream e) -> (BoxedVector n (RevDiff a b d), Stream (RevDiff a c e)) +-- tupleBoxedVectorStreamArg = cross boxedVectorArg streamArg . tupleArg +-- :} +-- +-- This allows us to differentiate functions whose arguments have a nested structure, +-- such as @(BoxedVector n a, Stream a)@. +-- +-- Alternatively, we can construct argument structure terms using the same style as for +-- value structure terms (see +-- [How it Works: Structured Value Types](#g:differentiation-45-for-45-structured-45-types-45-structured-45-value-45-how-45-it-45-works)): +-- +-- >>> :{ +-- tupleBoxedVectorStreamArgV2 :: (Additive b, Additive c, KnownNat n) => +-- RevDiff a (BoxedVector n b, FiniteSupportStream c) (BoxedVector n d, Stream e) -> (BoxedVector n (RevDiff a b d), Stream (RevDiff a c e)) +-- tupleBoxedVectorStreamArgV2 = mkTupleArg (mkBoxedVectorArg id) (mkStreamArg id) +-- :} +-- +-- Note that: +-- +-- > tupleArg = mkTupleArg id +-- > boxedVectorArg = mkBoxedVectorArg id +-- > streamArg = mkStreamArg id +-- +-- where `id` is used for scalar arguments. + +-- $differentiation-for-structured-types-structured-argument-type-defining-custom-type +-- +-- To support differentiation with respect to a custom scalar type @a@, +-- it is sufficient to define the associated type families: +-- +-- - `Tangent`@ a@ +-- - `Dual`@(@`Tangent`@a)@ (we denote this as `CT`@a@) +-- +-- (See +-- [Tangent and Cotangent Spaces](#g:how-45-it-45-works-45-tangent-45-space) +-- for more details.) +-- +-- Of course, you must also implement some differentiable function, +-- which is to be differentiated, for example: +-- +-- > func :: RevDiff a a -> RevDiff a b +-- +-- If @b@ is a scalar type, +-- the derivative will have the type: +-- +-- > func' :: a -> CT a +-- +-- For structured types like @f :: Type -> Type@, we recommend the following: +-- +-- 1. Define the type families: +-- +-- - `Tangent`@(f a)@ +-- +-- - `Dual`@ (@'Tangent`@ (f a))@ +-- +-- 2. Define the argument type descriptor, which is practically a permutation function: +-- +-- > fArg :: Additive (CT b) => +-- > RevDiff a (f b) -> f (RevDiff a b) +-- +-- 3. Define the argument type descriptor constructor: +-- +-- > mkFArg :: Additive (CT b) => +-- > (RevDiff a b -> c) -> RevDiff a (f b) -> f c +-- +-- 4. Provide an instance: +-- +-- > instance (AutoDifferentiableArgument a b c, Additive (CT b)) => +-- > AutoDifferentiableArgument a (f b) (f c) where +-- > autoArg = mkFArg autoArg +-- +-- For bifunctor types @g :: Type -> Type -> Type@: +-- +-- 1. Define type families: +-- +-- - `Tangent`@(g a0 a1)@ +-- +-- - `Dual`@(@`Tangent`@(g a0 a1))@ +-- +-- 2. Define the argument type descriptor: +-- +-- > gArg :: (Additive (CT b0), Additive (CT b1)) => +-- > RevDiff a (g b0 b1) -> g (RevDiff a b0) (RevDiff a b1) +-- +-- 3. Define the argument type descriptor constructor: +-- +-- > mkGArg :: (Additive (CT b0), Additive (CT b1)) => +-- > (RevDiff a b0 -> c0) -> +-- > (RevDiff a b1 -> c1) -> +-- > RevDiff a (g b0 b1) -> +-- > g c0 c1 +-- +-- 4. Provide an instance: +-- +-- > instance ( +-- > AutoDifferentiableArgument a b0 c0, +-- > AutoDifferentiableArgument a b1 c1, +-- > Additive (CT b0), +-- > Additive (CT b1) +-- > ) => +-- > AutoDifferentiableArgument a (g b0 b1) (g c0 c1) where +-- > autoArg = mkGArg autoArg autoArg + +-- $performance-remarks +-- +-- This section discusses performance considerations when using the library. + +-- $performance-remarks-subexpression-elimination +-- +-- Some intermediate results computed during the forward pass +-- (see +-- [The Backpropagation Derivative](#g:how-45-it-45-works-45-backpropagation)) +-- can be reused during the backward pass. +-- For deep neural networks, this reuse can result in significant computational savings. +-- This optimization can be viewed as a form of /subexpression elimination/— +-- a problem that Haskell’s evaluation model doesn't always handle automatically. +-- +-- Consider the following example: +-- +-- >>> :{ +-- f, g, h :: SymbolicFunc a => a -> a +-- f = unarySymbolicFunc "f" +-- g = unarySymbolicFunc "g" +-- h = unarySymbolicFunc "h" +-- k :: BinarySymbolicFunc a => a -> a -> a +-- k = binarySymbolicFunc "k" +-- forwardV1 :: (SymbolicFunc a, BinarySymbolicFunc a, Additive a) => a -> a +-- forwardV1 x_ = k (g y) (h y) where y = f x_ +-- :} +-- +-- Here we define a function @forwardV1@ as a composition +-- of functions. The intermediate result @f x@ is bound to a variable @y@, +-- which is then passed to both @g@ and @h@. +-- +-- To trace the evaluation of functions @f@, @g@, @h@, and @k@, +-- we use the `trace` function from @Debug.Trace@. +-- To facilitate this, we define a traced version @Traced@ +-- of the symbolic expression type @SE@: +-- +-- >>> x = MkTraced $ variable "x" :: Traced SE +-- +-- For example: +-- +-- >>> f x :: Traced SE +-- <<< TRACING: Calculating f of x >>> +-- f(x) +-- +-- The output: +-- +-- > <<< TRACING: Calculating f of x >>> +-- +-- is produced by the `trace` mechanism. +-- +-- Now consider the more complex function: +-- +-- > >>> simplify $ forwardV1 x :: Traced SimpleExpr +-- > <<< TRACING: Calculating f of x >>> +-- > <<< TRACING: Calculating g of f(x) >>> +-- > <<< TRACING: Calculating h of f(x) >>> +-- > <<< TRACING: Calculating k of g(f(x)) and h(f(x)) >>> +-- > k(g(f(x)),h(f(x))) +-- +-- The output may vary in order, depending on GHC's optimizations, but importantly, +-- note that @f x@ is only computed once and its result is reused, +-- thanks to the local binding. +-- +-- By contrast, if we define @forwardV2@ +-- without explicitly factoring out the shared subexpression: +-- +-- >>> :{ +-- forwardV2 :: (SymbolicFunc a, BinarySymbolicFunc a, Additive a) => a -> a +-- forwardV2 x_ = k (g (f x_)) (h (f x_)) +-- :} +-- +-- the tracing output will show redundant evaluations: +-- +-- > >>> simplify $ forwardV2 x :: Traced SimpleExpr +-- > <<< TRACING: Calculating f of x >>> +-- > <<< TRACING: Calculating g of f(x) >>> +-- > <<< TRACING: Calculating f of x >>> +-- > <<< TRACING: Calculating h of f(x) >>> +-- > <<< TRACING: Calculating k of g(f(x)) and h(f(x)) >>> +-- > k(g(f(x)),h(f(x))) +-- +-- Here, @f x@ is computed twice. +-- This illustrates that /GHC does not always automatically eliminate subexpressions/. +-- +-- Now consider tracing the derivative of @forwardV1@. +-- In the long output below, observe that @f'@ +-- is /not/ computed twice during the backward pass: +-- +-- > >>> simplify $ simpleDerivative forwardV1 x :: Traced SimpleExpr +-- > <<< TRACING: Calculating f' of x >>> +-- > <<< TRACING: Calculating f of x >>> +-- > <<< TRACING: Calculating g' of f(x) >>> +-- > <<< TRACING: Calculating g of f(x) >>> +-- > <<< TRACING: Calculating h of f(x) >>> +-- > <<< TRACING: Calculating k'_1 of g(f(x)) and h(f(x)) >>> +-- > <<< TRACING: Calculating (*) of k'_1(g(f(x)),h(f(x))) and 1 >>> +-- > <<< TRACING: Calculating (*) of g'(f(x)) and k'_1(g(f(x)),h(f(x)))*1 >>> +-- > <<< TRACING: Calculating (*) of f'(x) and g'(f(x))*(k'_1(g(f(x)),h(f(x)))*1) >>> +-- > <<< TRACING: Calculating h' of f(x) >>> +-- > <<< TRACING: Calculating k'_2 of g(f(x)) and h(f(x)) >>> +-- > <<< TRACING: Calculating (*) of k'_2(g(f(x)),h(f(x))) and 1 >>> +-- > <<< TRACING: Calculating (*) of h'(f(x)) and k'_2(g(f(x)),h(f(x)))*1 >>> +-- > <<< TRACING: Calculating (*) of f'(x) and h'(f(x))*(k'_2(g(f(x)),h(f(x)))*1) >>> +-- > <<< TRACING: Calculating (+) of f'(x)*(g'(f(x))*(k'_1(g(f(x)),h(f(x)))*1)) and f'(x)*(h'(f(x))*(k'_2(g(f(x)),h(f(x)))*1)) >>> +-- > (f'(x)*(g'(f(x))*k'_1(g(f(x)),h(f(x)))))+(f'(x)*(h'(f(x))*k'_2(g(f(x)),h(f(x))))) +-- +-- The possible duplication of becomes more severe as function composition grows deeper— +-- a major performance issue in neural network applications. +-- +-- For further illustration, consider the first and second derivatives +-- of the composition @(g . f)@: +-- +-- > >>> simpleDerivative (g . f) x :: Traced SimpleExpr +-- > <<< TRACING: Calculating f' of x >>> +-- > <<< TRACING: Calculating f of x >>> +-- > <<< TRACING: Calculating g' of f(x) >>> +-- > <<< TRACING: Calculating (*) of g'(f(x)) and 1 >>> +-- > <<< TRACING: Calculating (*) of f'(x) and g'(f(x))*1 >>> +-- > f'(x)*(g'(f(x))*1) +-- +-- > >>> simpleDerivative (simpleDerivative (g . f)) x :: Traced SimpleExpr +-- > <<< TRACING: Calculating f'' of x >>> +-- > <<< TRACING: Calculating f of x >>> +-- > <<< TRACING: Calculating g' of f(x) >>> +-- > <<< TRACING: Calculating (*) of g'(f(x)) and 1 >>> +-- > <<< TRACING: Calculating (*) of g'(f(x))*1 and 1 >>> +-- > <<< TRACING: Calculating (*) of f''(x) and (g'(f(x))*1)*1 >>> +-- > <<< TRACING: Calculating f' of x >>> +-- > <<< TRACING: Calculating g'' of f(x) >>> +-- > <<< TRACING: Calculating f' of x >>> +-- > <<< TRACING: Calculating (*) of f'(x) and 1 >>> +-- > <<< TRACING: Calculating (*) of 1 and f'(x)*1 >>> +-- > <<< TRACING: Calculating (*) of g''(f(x)) and 1*(f'(x)*1) >>> +-- > <<< TRACING: Calculating (*) of f'(x) and g''(f(x))*(1*(f'(x)*1)) >>> +-- > <<< TRACING: Calculating (+) of f'(x)*(g''(f(x))*(1*(f'(x)*1))) and 0 >>> +-- > <<< TRACING: Calculating (+) of f''(x)*((g'(f(x))*1)*1) and (f'(x)*(g''(f(x))*(1*(f'(x)*1))))+0 >>> +-- > (f''(x)*((g'(f(x))*1)*1))+((f'(x)*(g''(f(x))*(1*(f'(x)*1))))+0) +-- +-- Here we observe that @f'(x)@ is computed /twice/ in the second derivative. +-- This occurs because it appears in two different branches of the expression tree: +-- once as the outer derivative, and once via the inner term @g'(f(x))@. +-- +-- Unfortunately, the current implementation of `simplify` is /not able/ to eliminate +-- this redundancy, as it lacks full common subexpression elimination. +-- +-- Nevertheless, for typical neural network applications, +-- the current backpropagation implementation for the first derivative +-- is performant enough in practice. + +-- $performance-remarks-forward-step-results-reusage +-- +-- Some results from the forward pass can be reused during the backward pass, +-- leading to significant computational savings. Let's explore this optimization +-- through a concrete example. +-- +-- Consider differentiating the hyperbolic functions: +-- +-- \[ +-- \cosh x = \sinh' x = \frac{e^x + e^{-x}}{2} +-- \] +-- and +-- \[ +-- \sinh x = \cosh' x = \frac{e^x - e^{-x}}{2} +-- \] +-- +-- Notice that both functions require computing the same exponentials: +-- \(e^x\) and \(e^{-x}\). +-- During the forward pass, we calculate these exponentials to compute the function value. +-- Then, during the backward pass for derivative computation, we need exactly the same +-- exponentials again. Rather than recomputing them, we can reuse the forward pass results. +-- +-- This optimization becomes particularly valuable when dealing with computationally +-- expensive operations, such as matrix exponentials, where avoiding redundant +-- calculations can dramatically improve performance. +-- +-- While automatic subexpression elimination techniques exist, we'll explore a different +-- approach: manual subexpression elimination implemented directly in the backpropagation +-- definition. This gives us explicit control over which intermediate results to preserve +-- and reuse. +-- +-- Here's how we implement this optimization: +-- +-- We define an @ExpFieldV2@ typeclass that produces the same function values as +-- `ExpField` +-- but differs in how it handles intermediate computations, specifically designed to +-- enable result reuse: +-- +-- >>> :{ +-- class ExpFieldV2 a where +-- expV2 :: a -> a +-- sinhV2 :: a -> a +-- coshV2 :: a -> a +-- instance ExpFieldV2 SE where +-- expV2 = exp +-- sinhV2 x_ = (exp x_ - exp (negate x_)) / number 2 +-- coshV2 x_ = (exp x_ + exp (negate x_)) / number 2 +-- instance (ExpFieldV2 a, Distributive a, Subtractive a, Divisive a, FromInteger a) => +-- ExpFieldV2 (RevDiff t a a) where +-- expV2 = simpleDifferentiableFunc expV2 expV2 +-- sinhV2 (MkRevDiff x bpc) = +-- MkRevDiff ((expP - expM) NH./ fromInteger 2) (bpc . ((expP + expM) *)) where +-- expP = expV2 x +-- expM = expV2 (negate x) +-- coshV2 (MkRevDiff x bpc) = +-- MkRevDiff ((expP + expM) NH./ fromInteger 2) (bpc . ((expP - expM) *)) where +-- expP = expV2 x +-- expM = expV2 (negate x) +-- instance (ExpFieldV2 a, ExpField a, FromInteger a, Show a) => +-- ExpFieldV2 (Traced a) where +-- expV2 = addTraceUnary "exp" expV2 +-- sinhV2 x_ = (expV2 x_ - expV2 (negate x_)) / fromInteger 2 +-- coshV2 x_ = (expV2 x_ + expV2 (negate x_)) / fromInteger 2 +-- :} +-- +-- The key insight is in the RevDiff instance: we manually store the exponentials +-- @expP@ (for \(e^x\)) and @expM@ (for \(e^{-x}\)) as local bindings. +-- This ensures they're +-- computed only once and then reused both for the forward value calculation and +-- the backward pass derivative computation. +-- +-- Let's verify this optimization works as expected by tracing the computations: +-- +-- >>> x = MkTraced $ variable "x" :: Traced SE +-- +-- > >>> coshV2 x +-- > <<< TRACING: Calculating exp of x >>> +-- > <<< TRACING: Calculating negate of x >>> +-- > <<< TRACING: Calculating exp of -(x) >>> +-- > <<< TRACING: Calculating (+) of exp(x) and exp(-(x)) >>> +-- > <<< TRACING: Calculating (/) of exp(x)+exp(-(x)) and 2 >>> +-- > (exp(x)+exp(-(x)))/2 +-- +-- Now let's examine what happens when we compute both the value and derivative. +-- To this end, we use a function `simpleValueAndDerivative` +-- that computes both the value and derivative: +-- +-- > >>> simpleValueAndDerivative coshV2 x :: (Traced SE, Traced SE) +-- > ( <<< TRACING: Calculating exp of x >>> +-- > <<< TRACING: Calculating negate of x >>> +-- > <<< TRACING: Calculating exp of -(x) >>> +-- > <<< TRACING: Calculating (+) of exp(x) and exp(-(x)) >>> +-- > <<< TRACING: Calculating (/) of exp(x)+exp(-(x)) and 2 >>> +-- > (exp(x)+exp(-(x)))/2, <<< TRACING: Calculating (-) of exp(x) and exp(-(x)) >>> +-- > <<< TRACING: Calculating (*) of exp(x)-exp(-(x)) and 1 >>> +-- > (exp(x)-exp(-(x)))*1) +-- +-- Notice how the exponential calculations (exp of x and exp of -(x)) appear only +-- once in the trace, even though they're used in both the forward and backward passes. +-- This demonstrates that our manual subexpression elimination successfully avoids +-- redundant computations, reusing the exponential results as intended. +-- +-- Moreover, we can compute the second derivative without recomputing the exponentials: +-- +-- > >>> simpleDerivative (simpleDerivative coshV2) x :: Traced SE +-- > <<< TRACING: Calculating exp of x >>> +-- > <<< TRACING: Calculating (*) of 1 and 1 >>> +-- > <<< TRACING: Calculating (*) of exp(x) and 1*1 >>> +-- > <<< TRACING: Calculating negate of x >>> +-- > <<< TRACING: Calculating exp of -(x) >>> +-- > <<< TRACING: Calculating negate of 1*1 >>> +-- > <<< TRACING: Calculating (*) of exp(-(x)) and -(1*1) >>> +-- > <<< TRACING: Calculating negate of exp(-(x))*-(1*1) >>> +-- > <<< TRACING: Calculating (+) of exp(x)*(1*1) and -(exp(-(x))*-(1*1)) >>> +-- > <<< TRACING: Calculating (+) of (exp(x)*(1*1))+-(exp(-(x))*-(1*1)) and 0 >>> +-- > ((exp(x)*(1*1))+-(exp(-(x))*-(1*1)))+0 + +-- $what-is-next +-- +-- Unboxed vectors and tensors are not currently supported in the library. diff --git a/src/Numeric/InfBackprop/Utils/SizedVector.hs b/src/Numeric/InfBackprop/Utils/SizedVector.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/InfBackprop/Utils/SizedVector.hs @@ -0,0 +1,63 @@ +-- | +-- Module : Numeric.InfBackprop.Utils.CachedIso +-- Copyright : (C) 2025 Alexey Tochin +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Alexey Tochin +-- +-- Utility functions for working with sized vector. +module Numeric.InfBackprop.Utils.SizedVector + ( BoxedVector, + boxedVectorBasis, + boxedVectorSum, + ) +where + +import Data.Finite (Finite) +import qualified Data.Vector as DV +import qualified Data.Vector.Generic as DVG +import qualified Data.Vector.Generic.Sized as DVGS +import GHC.Base (($), (==)) +import GHC.TypeLits (Nat) +import GHC.TypeNats (KnownNat) +import NumHask (Additive, zero, (+)) + +-- | Type alias for boxed sized vectors. +type BoxedVector (n :: Nat) a = DVGS.Vector DV.Vector n a + +-- | Creates a sized vector of size n with all elements set to @x :: a@ +-- except for the one at index @k@, which is set to @y :: a@. +-- +-- ==== __Examples__ +-- +-- >>> import GHC.Base (Int, String) +-- >>> import qualified Data.Vector as DV +-- >>> import qualified Data.Vector.Generic.Sized as DVGS +-- +-- >>> boxedVectorBasis 2 0 1 :: DVGS.Vector DV.Vector 4 Int +-- Vector [0,0,1,0] +-- +-- >>> boxedVectorBasis 1 "zero" "one" :: DVGS.Vector DV.Vector 5 String +-- Vector ["zero","one","zero","zero","zero"] +boxedVectorBasis :: + (DVG.Vector v a, KnownNat n) => + Finite n -> + a -> + a -> + DVGS.Vector v n a +boxedVectorBasis k zero' one' = DVGS.generate $ \l -> + if k == l + then one' + else zero' + +-- | Sums all elements of a sized array. +-- +-- ==== __Examples__ +-- +-- >>> import GHC.Base (Int) +-- >>> import qualified Data.Vector as DV +-- >>> import qualified Data.Vector.Generic.Sized as DVGS +-- +-- >>> boxedVectorSum (DVGS.fromTuple (1, 2, 3) :: DVGS.Vector DV.Vector 3 Int) +-- 6 +boxedVectorSum :: (Additive a) => DVGS.Vector DV.Vector n a -> a +boxedVectorSum = DVGS.foldl' (+) zero diff --git a/src/Numeric/InfBackprop/Utils/Tuple.hs b/src/Numeric/InfBackprop/Utils/Tuple.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/InfBackprop/Utils/Tuple.hs @@ -0,0 +1,121 @@ +-- | Module : Numeric.InfBackprop.Instances.NumHask +-- Copyright : (C) 2025 Alexey Tochin +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Alexey Tochin +-- +-- Utility functions for working with tuples. +module Numeric.InfBackprop.Utils.Tuple + ( cross, + cross3, + fork, + fork3, + curry3, + uncurry3, + biCross, + biCross3, + ) +where + +-- | Applies two functions to the components of a tuple. + +--- ==== __Examples__ +-- +-- >>> cross (+1) (*2) (3, 4) +-- (4,8) +cross :: (a -> b) -> (c -> d) -> (a, c) -> (b, d) +{-# INLINE cross #-} +cross f g (x, y) = (f x, g y) + +-- | Applies three functions to the components of a triple. +-- +-- ==== __Examples__ +-- +-- >>> import GHC.Num ((+), (-), (*)) +-- +-- >>> cross3 (+1) (*2) (\x -> x - 3) (3, 4, 10) +-- (4,8,7) +cross3 :: (a0 -> b0) -> (a1 -> b1) -> (a2 -> b2) -> (a0, a1, a2) -> (b0, b1, b2) +{-# INLINE cross3 #-} +cross3 f g h (x, y, z) = (f x, g y, h z) + +-- | Applies two functions to the same argument and returns a tuple of results. +-- +-- ==== __Examples__ +-- +-- >>> import GHC.Num ((+), (*)) +-- +-- >>> fork (+1) (*2) 3 +-- (4,6) +fork :: (t -> a) -> (t -> b) -> t -> (a, b) +{-# INLINE fork #-} +fork f g x = (f x, g x) + +-- | Applies three functions to the same argument and returns a triple of results. +-- +-- >>> import GHC.Num ((+), (-), (*)) +-- +-- ==== __Examples__ +-- +-- >>> fork3 (+1) (*2) (\x -> x - 3) 5 +-- (6,10,2) +fork3 :: (t -> a0) -> (t -> a1) -> (t -> a2) -> t -> (a0, a1, a2) +{-# INLINE fork3 #-} +fork3 f0 f1 f2 x = (f0 x, f1 x, f2 x) + +-- | Curries a function on triples. +-- +-- ==== __Examples__ +-- +-- >>> import GHC.Num ((+)) +-- +-- >>> f (x, y, z) = x + y + z +-- >>> g = curry3 f +-- >>> g 1 2 3 +-- 6 +curry3 :: ((a, b, c) -> d) -> a -> b -> c -> d +{-# INLINE curry3 #-} +curry3 f x y z = f (x, y, z) + +-- | Uncurries a function on triples. +-- +-- ==== __Examples__ +-- +-- >>> import GHC.Num ((+)) +-- +-- >>> f x y z = x + y + z +-- >>> g = uncurry3 f +-- >>> g (1, 2, 3) +-- 6 +uncurry3 :: (a -> b -> c -> d) -> ((a, b, c) -> d) +{-# INLINE uncurry3 #-} +uncurry3 f (x, y, z) = f x y z + +-- | Applies two binary functions to the components of two tuples. +-- +-- ==== __Examples__ +-- +-- >>> import GHC.Num ((+), (*)) +-- +-- >>> biCross (+) (*) (1, 2) (3, 4) +-- (4,8) +biCross :: (a -> b -> c) -> (d -> e -> f) -> (a, d) -> (b, e) -> (c, f) +{-# INLINE biCross #-} +biCross f g (x0, x1) (y0, y1) = (f x0 y0, g x1 y1) + +-- | Applies three binary functions to the components of two triples. +-- +-- ==== __Examples__ +-- +-- >>> import GHC.Num ((+), (*), (-)) +-- +-- >>> biCross3 (+) (*) (-) (1, 2, 10) (3, 4, 5) +-- (4,8,5) +biCross3 :: + (a -> b -> c) -> + (d -> e -> f) -> + (g -> h -> l) -> + (a, d, g) -> + (b, e, h) -> + (c, f, l) +{-# INLINE biCross3 #-} +biCross3 f g h (x0, x1, x2) (y0, y1, y2) = (f x0 y0, g x1 y1, h x2 y2) diff --git a/src/Numeric/InfBackprop/Utils/Vector.hs b/src/Numeric/InfBackprop/Utils/Vector.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/InfBackprop/Utils/Vector.hs @@ -0,0 +1,164 @@ +-- | Module : Numeric.InfBackprop.Instances.NumHask +-- Copyright : (C) 2025 Alexey Tochin +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Alexey Tochin +-- +-- Utility functions for working with vectors. +module Numeric.InfBackprop.Utils.Vector + ( fromTuple, + safeHead, + safeLast, + trimArrayHead, + trimArrayTail, + zipWith, + ) +where + +import Control.Monad (MonadPlus, mzero) +import Data.Bool (otherwise) +import Data.Eq (Eq, (==)) +import Data.Function (($)) +import qualified Data.IndexedListLiterals as DILL +import Data.Maybe (Maybe (Just, Nothing)) +import Data.Ord (Ordering (EQ, GT, LT), compare) +import qualified Data.Vector.Generic as DVG +import GHC.Base (pure, (.)) + +-- | Converts a tuple into a Vector (`Data.Vector.Vector`). +-- +-- === __Examples__ +-- +-- >>> import GHC.Int (Int) +-- >>> import qualified Data.Vector as DV +-- +-- >>> fromTuple (1 :: Int, 2 :: Int, 3 :: Int) :: DV.Vector Int +-- [1,2,3] +fromTuple :: + (DVG.Vector v a) => + (DILL.IndexedListLiterals input length a) => + input -> + v a +fromTuple = DVG.fromList . DILL.toList + +-- | Returns the first element of a vector safely. +-- If the vector is empty, it returns 'Nothing'. +-- +-- ==== __Examples__ +-- +-- >>> import GHC.Int (Int) +-- >>> import Data.Vector (fromList) +-- +-- >>> safeHead (fromList [1, 2, 3]) :: Maybe Int +-- Just 1 +-- +-- >>> safeHead (fromList []) :: Maybe Int +-- Nothing +safeHead :: (DVG.Vector v a, MonadPlus m) => v a -> m a +safeHead vec + | DVG.null vec = mzero + | otherwise = pure $ DVG.unsafeHead vec + +-- | Returns the last element of a vector safely. +-- If the vector is empty, it returns 'Nothing'. +-- +-- ==== __Examples__ +-- +-- >>> import GHC.Int (Int) +-- >>> import Data.Vector (fromList, empty) +-- +-- >>> safeLast (fromList [1, 2, 3]) :: Maybe Int +-- Just 3 +-- +-- >>> safeLast empty :: Maybe Int +-- Nothing +safeLast :: (DVG.Vector v a, MonadPlus m) => v a -> m a +safeLast vec + | DVG.null vec = mzero + | otherwise = pure $ DVG.unsafeLast vec + +-- | Removes elements from the beginning of the vector until the first element +-- is not equal to the given value. +-- +-- ==== __Examples__ +-- +-- >>> import Data.Vector (fromList, empty) +-- +-- >>> trimArrayHead 1 (fromList [1, 1, 1, 2, 3]) +-- [2,3] +-- +-- >>> trimArrayHead 1 empty +-- [] +trimArrayHead :: (DVG.Vector v a, Eq a) => a -> v a -> v a +trimArrayHead x vec = case safeHead vec of + Nothing -> DVG.empty + Just firstVal -> + if firstVal == x + then trimArrayHead x (DVG.tail vec) + else vec + +-- | Removes elements from the end of the vector until the last element +-- is not equal to the given value. +-- +-- ==== __Examples__ +-- +-- >>> import Data.Vector (fromList, empty) +-- +-- >>> trimArrayTail 3 (fromList [1, 2, 3, 3, 3]) +-- [1,2] +-- +-- >>> trimArrayTail 3 empty +-- [] +trimArrayTail :: (DVG.Vector v a, Eq a) => a -> v a -> v a +trimArrayTail x array = case safeLast array of + Nothing -> DVG.empty + Just lastVal -> + if lastVal == x + then trimArrayTail x (DVG.init array) + else array + +-- | Combines two arrays of different lengths using a custom function. +-- The resulting array has a length equal to the maximum of the two input vectors. +-- The shorter array is padded with values generated by the provided functions. +-- +-- ==== __Examples__ +-- +-- >>> import Prelude (id, negate, (-), Int) +-- >>> import qualified Data.Vector as DV +-- +-- The following example demonstrates subtracting two arrays of different lengths. +-- The shorter array is padded with zeros, and the remaining elements are processed +-- using the provided functions. +-- +-- >>>:{ +-- zipWith +-- (-) -- Subtract corresponding elements from the two arrays +-- id -- Keep the remaining elements of the first array unchanged +-- negate -- Negate the remaining elements of the second array +-- (DV.fromList [10, 20, 30]) -- First array +-- (DV.fromList [1, 2]) -- Second array +-- :} +-- [9,18,30] +-- +-- >>> import Prelude (id, negate, (-), Int) +-- >>> import Data.Vector (fromList) +-- +-- >>> let v0 :: DV.Vector Int = DV.fromList [10, 20, 30] +-- >>> let v1 :: DV.Vector Int = DV.fromList [1, 2] +-- >>> zipWith (-) id negate v0 v1 +-- [9,18,30] +zipWith :: + (DVG.Vector v a, DVG.Vector v b, DVG.Vector v c) => + (a -> b -> c) -> + (a -> c) -> + (b -> c) -> + v a -> + v b -> + v c +zipWith f g h a0 a1 = case compare l0 l1 of + EQ -> base + GT -> base DVG.++ DVG.map g (DVG.drop l1 a0) + LT -> base DVG.++ DVG.map h (DVG.drop l0 a1) + where + l0 = DVG.length a0 + l1 = DVG.length a1 + base = DVG.zipWith f a0 a1 diff --git a/src/Prelude/InfBackprop.hs b/src/Prelude/InfBackprop.hs deleted file mode 100644 --- a/src/Prelude/InfBackprop.hs +++ /dev/null @@ -1,623 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS_HADDOCK show-extensions #-} - --- | Module : Prelude.InfBackprop --- Copyright : (C) 2023 Alexey Tochin --- License : BSD3 (see the file LICENSE) --- Maintainer : Alexey Tochin --- --- Backpropagation differentiable versions of basic functions. -module Prelude.InfBackprop - ( -- * Elementary functions - linear, - (+), - (-), - negate, - (*), - (/), - - -- * Tuple manipulations - dup, - setFirst, - setSecond, - forget, - forgetFirst, - forgetSecond, - - -- * Exponential family functions - log, - logBase, - exp, - (**), - pow, - - -- * Trigonometric functions - cos, - sin, - tan, - asin, - acos, - atan, - atan2, - sinh, - cosh, - tanh, - asinh, - acosh, - atanh, - - -- * Tools - simpleDifferentiable, - ) -where - -import Control.CatBifunctor (first, second, (***)) -import Control.Category ((<<<), (>>>)) -import InfBackprop.Common (Backprop (MkBackprop), BackpropFunc, const) -import IsomorphismClass.Isomorphism (iso) -import NumHask (Additive, Distributive, Divisive, ExpField, Subtractive, TrigField, fromInteger, zero) -import qualified NumHask as NH -import NumHask.Prelude (one) -import qualified NumHask.Prelude as NHP -import Prelude (flip, uncurry, ($), (==)) -import qualified Prelude as P - --- | Returns a differentiable morphism given forward function and backpropagation derivative differential morphism. --- --- ==== __Examples of usage__ --- --- >>> import qualified NumHask as NH --- >>> cos = simpleDifferentiable NH.cos (sin >>> negate) -simpleDifferentiable :: forall x. Distributive x => (x -> x) -> BackpropFunc x x -> BackpropFunc x x -simpleDifferentiable f df = MkBackprop call' forward' backward' - where - call' :: x -> x - call' = f - - forward' :: BackpropFunc x (x, x) - forward' = dup >>> first (simpleDifferentiable f df) - - backward' :: BackpropFunc (x, x) x - backward' = second df >>> (*) - --- Tuple manipulations - --- | Duplication differentiable operation. --- --- ==== __Examples of usage__ --- --- >>> import Prelude (Float) --- >>> import InfBackprop (call, derivative) --- >>> call dup (42.0 :: Float) --- (42.0,42.0) --- --- >>> import Debug.SimpleExpr.Expr (variable) --- >>> x = variable "x" --- >>> derivative (dup >>> (*)) x --- (1·x)+(1·x) -dup :: - forall x. - Additive x => - BackpropFunc x (x, x) -dup = MkBackprop call' forward' backward' - where - call' :: x -> (x, x) - call' x = (x, x) - forward' :: BackpropFunc x ((x, x), ()) - forward' = dup >>> (iso :: BackpropFunc y (y, ())) - backward' :: BackpropFunc ((x, x), ()) x - backward' = (iso :: BackpropFunc (y, ()) y) >>> (+) - --- | Transforms any function to unit @()@. --- It is not differentiable until @StartBackprop@ is defined for @()@. --- However 'forget' is useful if need to remove some data in the differentiable pipeline. --- --- ==== __Examples of usage__ --- --- >>> import InfBackprop (call, derivative) --- --- >>> f = first forget >>> (iso :: BackpropFunc ((), a) a) :: Additive a => BackpropFunc (a, a) a --- --- >>> call f (24, 42) --- 42 --- --- >>> derivative f (24, 42) --- (0,1) -forget :: - forall x. - Additive x => - BackpropFunc x () -forget = const () - --- | Remove the first element of a tuple. --- --- ==== __Examples of usage__ --- --- >>> import InfBackprop (call, derivative) --- --- >>> call forgetFirst (24, 42) --- 42 --- --- >>> derivative forgetFirst (24, 42) --- (0,1) -forgetFirst :: - forall x y. - Additive x => - BackpropFunc (x, y) y -forgetFirst = iso <<< first forget - --- | Remove the second element of a tuple. --- --- ==== __Examples of usage__ --- --- >>> import InfBackprop (call, derivative) --- --- >>> call forgetSecond (24, 42) --- 24 --- --- >>> derivative forgetSecond (24, 42) --- (1,0) -forgetSecond :: - forall x y. - Additive y => - BackpropFunc (x, y) x -forgetSecond = iso <<< second forget - --- | Transforms a 2-argument differentiable function into a single argument function by fixing its first argument. --- --- >>> import Prelude (Float) --- >>> import InfBackprop (call, derivative) --- >>> call (setFirst 8 (/)) 4 :: Float --- 2.0 --- --- >>> import Debug.SimpleExpr.Expr (variable) --- >>> x = variable "x" --- >>> y = variable "y" --- >>> derivative (setFirst x (*)) y --- 1·x -setFirst :: - forall x y c. - Additive c => - c -> - BackpropFunc (c, x) y -> - BackpropFunc x y -setFirst c f = (iso :: BackpropFunc x ((), x)) >>> first (const c) >>> f - --- | Transforms a 2-argument differentiable function into a single argument function by fixing its second argument. --- --- >>> import Prelude (Float) --- >>> import InfBackprop (call, derivative) --- >>> call (setSecond 4 (/)) 8 :: Float --- 2.0 --- --- >>> import Debug.SimpleExpr.Expr (variable) --- >>> x = variable "x" --- >>> y = variable "y" --- >>> derivative (setSecond y (*)) x --- 1·y -setSecond :: - forall x y c. - Additive c => - c -> - BackpropFunc (x, c) y -> - BackpropFunc x y -setSecond c f = (iso :: BackpropFunc x (x, ())) >>> second (const c) >>> f - --- Elementary functions - --- | Linear differentiable function. --- --- ==== __Examples of usage__ --- --- >>> import Prelude (fmap, Float) --- >>> import InfBackprop (pow, call, derivative) --- >>> myFunc = linear 2 :: BackpropFunc Float Float --- --- >>> f = call myFunc :: Float -> Float --- >>> fmap f [-3, -2, -1, 0, 1, 2, 3] --- [-6.0,-4.0,-2.0,0.0,2.0,4.0,6.0] --- --- >>> df = derivative myFunc :: Float -> Float --- >>> fmap df [-3, -2, -1, 0, 1, 2, 3] --- [2.0,2.0,2.0,2.0,2.0,2.0,2.0] -linear :: - forall x. - NH.Distributive x => - x -> - BackpropFunc x x -linear c = MkBackprop call' forward' backward' - where - call' :: x -> x - call' = f c - where - f = (NH.*) - forward' :: BackpropFunc x (x, ()) - forward' = linear c >>> (iso :: BackpropFunc y (y, ())) - backward' :: BackpropFunc (x, ()) x - backward' = (iso :: BackpropFunc (x, ()) x) >>> linear c - --- | Summation differentiable binary operation. --- --- ==== __Examples of usage__ --- --- >>> import Prelude (Float) --- >>> import InfBackprop (call, derivative) --- --- >>> call (+) (2, 3) :: Float --- 5.0 --- --- >>> import Debug.SimpleExpr.Expr (variable) --- >>> x = variable "x" --- >>> y = variable "y" --- >>> derivative (+) (x, y) --- (1,1) -(+) :: - forall x. - Additive x => - BackpropFunc (x, x) x -(+) = MkBackprop call' forward' backward' - where - call' :: (x, x) -> x - call' = uncurry (NH.+) - forward' :: BackpropFunc (x, x) (x, ()) - forward' = (+) >>> (iso :: BackpropFunc y (y, ())) - backward' :: BackpropFunc (x, ()) (x, x) - backward' = (iso :: BackpropFunc (x, ()) x) >>> dup - --- | Negate differentiable function. --- --- ==== __Examples of usage__ --- --- >>> import Prelude (Float, ($)) --- >>> import InfBackprop (call, derivative) --- --- >>> call negate 42 :: Float --- -42.0 --- --- >>> derivative negate 42 :: Float --- -1.0 -negate :: - forall x. - Subtractive x => - BackpropFunc x x -negate = MkBackprop call' forward' backward' - where - call' :: x -> x - call' = NH.negate - forward' :: BackpropFunc x (x, ()) - forward' = negate >>> (iso :: BackpropFunc y (y, ())) - backward' :: BackpropFunc (x, ()) x - backward' = (iso :: BackpropFunc (y, ()) y) >>> negate - --- | Subtraction differentiable binary operation. --- --- ==== __Examples of usage__ --- --- >>> import Prelude (Float) --- >>> import InfBackprop (call, derivative) --- --- >>> call (-) (5, 3) :: Float --- 2.0 --- --- >>> import Debug.SimpleExpr.Expr (variable) --- >>> x = variable "x" --- >>> y = variable "y" --- >>> derivative (-) (x, y) --- (1,-(1)) -(-) :: forall x. (Subtractive x) => BackpropFunc (x, x) x -(-) = MkBackprop call' forward' backward' - where - call' :: (x, x) -> x - call' = uncurry (NH.-) - forward' :: BackpropFunc (x, x) (x, ()) - forward' = (-) >>> (iso :: BackpropFunc y (y, ())) - backward' :: BackpropFunc (x, ()) (x, x) - backward' = (iso :: BackpropFunc (x, ()) x) >>> dup >>> second negate - --- | Product binnary operation --- --- ==== __Examples of usage__ --- --- >>> import Prelude (Float) --- >>> import InfBackprop (call, derivative) --- >>> call (*) (2, 3) :: Float --- 6.0 --- --- >>> import Debug.SimpleExpr.Expr (variable) --- >>> x = variable "x" --- >>> y = variable "y" --- >>> derivative (*) (x, y) --- (1·y,1·x) -(*) :: Distributive x => BackpropFunc (x, x) x -(*) = MkBackprop call' forward' backward' - where - call' :: Distributive x => (x, x) -> x - call' = uncurry (NH.*) - forward' :: Distributive x => BackpropFunc (x, x) (x, (x, x)) - forward' = dup >>> first (*) - backward' :: Distributive x => BackpropFunc (x, (x, x)) (x, x) - backward' = - first dup - >>> (iso :: BackpropFunc ((dy, dy), (x1, x2)) ((dy, x1), (dy, x2))) - >>> (iso :: BackpropFunc (a, b) (b, a)) - >>> (*) *** (*) - --- | Square differentiable operation --- --- ==== __Examples of usage__ --- --- >>> import Prelude (Float) --- >>> import InfBackprop (call, derivative) --- >>> call square 3 :: Float --- 9.0 --- --- >>> derivative square 3 :: Float --- 6.0 -square :: Distributive x => BackpropFunc x x -square = dup >>> (*) - --- | Division binary differentiable operation --- --- ==== __Examples of usage__ --- --- >>> import Prelude (Float) --- >>> import InfBackprop (call, derivative) --- >>> call (/) (6, 3) :: Float --- 2.0 --- --- >>> import Debug.SimpleExpr.Expr (variable) --- >>> x = variable "x" --- >>> y = variable "y" --- >>> derivative (/) (x, y) --- (1·(1/y),1·(-(x)·(1/(y·y)))) -(/) :: - forall x. - (Divisive x, Distributive x, Subtractive x) => - BackpropFunc (x, x) x -(/) = MkBackprop call' forward' backward' - where - call' :: (x, x) -> x - call' = uncurry (NH./) - forward' :: BackpropFunc (x, x) (x, (x, x)) - forward' = dup >>> first (/) - backward' :: BackpropFunc (x, (x, x)) (x, x) - backward' = - dup *** dup - >>> second (d1 *** d2) -- ((dy, dy), ((x1, x2), (x1, x2))) - >>> (iso :: BackpropFunc ((dy, dy), (x1, x2)) ((dy, x1), (dy, x2))) -- ((dy, dy), (1 / x2, - x1 * x2^(-2) )) - >>> (*) *** (*) - where - d1 = (forget *** recip) >>> (iso :: BackpropFunc ((), x) x) -- (x1, x2) -> 1 / x2 - d2 = (negate *** (square >>> recip)) >>> (*) -- (x1, x2) -> - x1 * x2^(-2) - --- | The recip differentiable operation --- --- ==== __Examples of usage__ --- --- >>> import Prelude (Float) --- >>> import InfBackprop (call, derivative) --- >>> call recip 2 :: Float --- 0.5 --- --- >>> derivative recip 2 :: Float --- -0.25 -recip :: - forall x. - (Divisive x, Distributive x, Subtractive x) => - BackpropFunc x x -recip = setFirst NH.one (/) - --- | Integer power differentiable operation --- --- ==== __Examples of usage__ --- --- >>> import Prelude (Float) --- >>> import InfBackprop (call, derivative) --- >>> call (pow 3) 2 :: Float --- 8.0 --- --- >>> derivative (pow 3) 2 :: Float --- 12.0 -pow :: - forall x. - ( Divisive x, - Distributive x, - Subtractive x, - NH.FromIntegral x NHP.Integer - ) => - NHP.Integer -> - BackpropFunc x x -pow n = MkBackprop call' forward' backward' - where - call' :: x -> x - call' = flip (NH.^) (fromInteger n) - forward' :: BackpropFunc x (x, x) - forward' = dup >>> first (pow n :: BackpropFunc x x) - backward' :: BackpropFunc (x, x) x - backward' = second der >>> (*) - where - der = - if n == 0 - then const zero - else pow (n P.- 1) >>> linear (NH.fromIntegral n) - --- | Square root differentiable function. --- --- ==== __Examples of usage__ --- --- >>> import Prelude (Float) --- >>> import InfBackprop (call, derivative) --- >>> call sqrt 16 :: Float --- 4.0 --- --- >>> derivative sqrt 16 :: Float --- 0.125 -sqrt :: - forall x. - ExpField x => - BackpropFunc x x -sqrt = MkBackprop call' forward' backward' - where - call' :: x -> x - call' = NH.sqrt - forward' :: BackpropFunc x (x, x) - forward' = (sqrt :: BackpropFunc x x) >>> dup - backward' :: BackpropFunc (x, x) x - backward' = second (recip >>> linear NH.half) >>> (*) - --- | Power binary differentiable operation. --- --- ==== __Examples of usage__ --- --- >>> import Prelude (Float) --- >>> import NumHask (half) --- >>> import InfBackprop (call, derivative) --- >>> call (**) (0.5, 9) :: Float --- 3.0 --- --- >>> import Debug.SimpleExpr.Expr (variable) --- >>> x = variable "x" --- >>> n = variable "n" --- >>> derivative (**) (n, x) --- (1·(n·(x^(n-1))),1·((x^n)·log(x))) -(**) :: - forall a. - ( ExpField a, - NH.FromIntegral a P.Integer - ) => - BackpropFunc (a, a) a -(**) = MkBackprop call' forward' backward' - where - call' :: (a, a) -> a - call' = uncurry $ flip (NH.**) - forward' :: BackpropFunc (a, a) (a, (a, (a, a))) - forward' = - dup -- ((n, x), (n, x)) - >>> first ((**) >>> dup) -- ((x^n, x^n), (n, x)) - >>> (iso :: BackpropFunc ((a, b), c) (a, (b, c))) -- (x^n, (x^n, (n, x))) - backward' :: BackpropFunc (a, (a, (a, a))) (a, a) - backward' = - dup *** (dup >>> (dn *** dx)) -- ((dy, dy), (dn, dx)) - >>> (iso :: BackpropFunc ((a, b), (c, d)) ((a, c), (b, d))) -- ((dy, dn), (dy, dx)) - >>> (*) *** (*) - where - -- (x^n, (n, x)) -> n * x^(n-1) - dn :: BackpropFunc (a, (a, a)) a - dn = - forgetFirst -- (n, x) - >>> first dup -- ((n, n), x) - >>> (iso :: BackpropFunc ((a, b), c) (a, (b, c))) -- (n, (n, x)) - >>> second (first (setSecond (NH.fromIntegral (1 :: P.Integer)) (-))) -- (n, (n-1, x)) - >>> second (**) -- (n, x^(n-1)) - >>> (*) -- (n * x^(n-1)) - -- (x^n, (n, x)) -> log x * x^n - dx :: BackpropFunc (a, (a, a)) a - dx = second forgetFirst >>> second log >>> (*) - --- | Natural logarithm differentiable function. --- --- ==== __Examples of usage__ --- --- >>> import Prelude (Float) --- >>> import InfBackprop (call, derivative) --- >>> call log 10 :: Float --- 2.3025851 --- --- >>> derivative log 10 :: Float --- 0.1 -log :: ExpField x => BackpropFunc x x -log = simpleDifferentiable NH.log recip - --- | Natural logarithm differentiable function. --- --- ==== __Examples of usage__ --- --- >>> import Prelude (Float) --- >>> import InfBackprop (call, derivative) --- >>> call logBase (2, 8) :: Float --- 3.0 --- --- >>> import Debug.SimpleExpr.Expr (variable) --- >>> x = variable "x" --- >>> n = variable "n" --- >>> derivative logBase (n, x) --- ((1·(-(log(x))·(1/(log(n)·log(n)))))·(1/n),(1·(1/log(n)))·(1/x)) -logBase :: ExpField a => BackpropFunc (a, a) a -logBase = (iso :: BackpropFunc (c, d) (d, c)) >>> log *** log >>> (/) - --- | Natural logarithm differentiable function. --- --- ==== __Examples of usage__ --- --- >>> import Prelude (Float) --- >>> import InfBackprop (call, derivative) --- >>> call exp 2 --- 7.38905609893065 --- --- >>> import Debug.SimpleExpr.Expr (variable) --- >>> x = variable "x" --- >>> derivative exp x --- 1·exp(x) -exp :: forall x. ExpField x => BackpropFunc x x -exp = MkBackprop call' forward' backward' - where - call' :: x -> x - call' = NH.exp - forward' :: BackpropFunc x (x, x) - forward' = (exp :: BackpropFunc x x) >>> dup - backward' :: BackpropFunc (x, x) x - backward' = (*) - --- Trigonometric - --- | Sine differentiable function -sin :: TrigField x => BackpropFunc x x -sin = simpleDifferentiable NH.sin cos - --- | Cosine differentiable function. -cos :: TrigField x => BackpropFunc x x -cos = simpleDifferentiable NH.cos (sin >>> negate) - --- | Tangent differentiable function. -tan :: TrigField x => BackpropFunc x x -tan = simpleDifferentiable NH.tan (cos >>> square >>> recip) - --- | Arcsine differentiable function. -asin :: (TrigField x, ExpField x) => BackpropFunc x x -asin = simpleDifferentiable NH.tan (square >>> setFirst one (-) >>> sqrt >>> recip) - --- | Arccosine differentiable function. -acos :: (TrigField x, ExpField x) => BackpropFunc x x -acos = simpleDifferentiable NH.tan (square >>> setFirst one (-) >>> sqrt >>> recip >>> negate) - --- | Arctangent differentiable function. -atan :: TrigField x => BackpropFunc x x -atan = simpleDifferentiable NH.atan (square >>> setFirst one (+) >>> recip) - --- | 2-argument arctangent differentiable function. -atan2 :: TrigField a => BackpropFunc (a, a) a -atan2 = (/) >>> atan - --- | Hyperbolic sine differentiable function. -sinh :: TrigField x => BackpropFunc x x -sinh = simpleDifferentiable NH.sinh cosh - --- | Hyperbolic cosine differentiable function. -cosh :: TrigField x => BackpropFunc x x -cosh = simpleDifferentiable NH.cosh sinh - --- | Hyperbolic tanget differentiable function. -tanh :: TrigField x => BackpropFunc x x -tanh = simpleDifferentiable NH.tanh (cosh >>> square >>> recip) - --- | Hyperbolic arcsine differentiable function. -asinh :: (TrigField x, ExpField x) => BackpropFunc x x -asinh = simpleDifferentiable NH.asinh (square >>> setFirst one (+) >>> sqrt >>> recip) - --- | Hyperbolic arccosine differentiable function. -acosh :: (TrigField x, ExpField x) => BackpropFunc x x -acosh = simpleDifferentiable NH.tan (square >>> setSecond one (-) >>> sqrt >>> recip) - --- | Hyperbolic arctangent differentiable function. -atanh :: TrigField x => BackpropFunc x x -atanh = simpleDifferentiable NH.tan (square >>> setFirst one (-) >>> recip)