diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,9 @@ +# Revision history for simple-expr + +## 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. +* Extra instancies for `Additive` typeclass from `numhask` package. +* Tutorial diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2023, Alexey Tochin + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Alexey Tochin nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/doctests/Main.hs b/doctests/Main.hs new file mode 100644 --- /dev/null +++ b/doctests/Main.hs @@ -0,0 +1,22 @@ +import Test.DocTest (doctest) +import Prelude (IO) + +-- This test suite exists only to add dependencies +main :: IO () +main = + doctest + [ "-XHaskell2010", + "-XNoImplicitPrelude", + "-XGADTs", + "-XTypeFamilies", + "-XMultiParamTypeClasses", + "-XFlexibleInstances", + "-XScopedTypeVariables", + "-XConstraintKinds", + "-XRankNTypes", + "-XInstanceSigs", + "-XTupleSections", + "-XFlexibleContexts", + "-XDeriveFunctor", + "src" + ] diff --git a/inf-backprop.cabal b/inf-backprop.cabal new file mode 100644 --- /dev/null +++ b/inf-backprop.cabal @@ -0,0 +1,88 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.35.1. +-- +-- see: https://github.com/sol/hpack + +name: inf-backprop +version: 0.1.0.0 +synopsis: Automatic differentiation and backpropagation. +description: ![Second order derivative of a composition](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. + . + The original purpose of the package is an automatic backpropagation differentiation component + for a functional type-dependent library for deep machine learning. + See [tutorial](InfBackprop-Tutorial.html) details. +category: Math +author: Alexey Tochin +maintainer: Alexey.Tochin@gmail.com +copyright: 2023 Alexey Tochin +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + CHANGELOG.md + +library + exposed-modules: + Control.CatBifunctor + Debug.LoggingBackprop + InfBackprop + InfBackprop.Common + InfBackprop.Tutorial + IsomorphismClass.Extra + IsomorphismClass.Isomorphism + NumHask.Extra + Prelude.InfBackprop + other-modules: + Paths_inf_backprop + hs-source-dirs: + src + default-extensions: + NoImplicitPrelude + GADTs + TypeFamilies + MultiParamTypeClasses + FlexibleInstances + ScopedTypeVariables + ConstraintKinds + RankNTypes + InstanceSigs + TupleSections + FlexibleContexts + DeriveFunctor + 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 + default-language: Haskell2010 + +test-suite doctests + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + 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 + build-depends: + base >=4.7 && <5 + , comonad + , doctest + , isomorphism-class + , monad-logger + , numhask + , simple-expr + , text + , transformers + default-language: Haskell2010 diff --git a/src/Control/CatBifunctor.hs b/src/Control/CatBifunctor.hs new file mode 100644 --- /dev/null +++ b/src/Control/CatBifunctor.hs @@ -0,0 +1,179 @@ +{-# 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/Debug/LoggingBackprop.hs b/src/Debug/LoggingBackprop.hs new file mode 100644 --- /dev/null +++ b/src/Debug/LoggingBackprop.hs @@ -0,0 +1,368 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/InfBackprop.hs @@ -0,0 +1,125 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/InfBackprop/Common.hs @@ -0,0 +1,340 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/InfBackprop/Tutorial.hs @@ -0,0 +1,474 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/IsomorphismClass/Extra.hs @@ -0,0 +1,113 @@ +{-# 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 + +import Control.Category (id) +import Data.Void (Void, absurd) +import IsomorphismClass (IsomorphicTo, to) +import Prelude (Either (Left, Right), fst, snd) + +instance {-# INCOHERENT #-} IsomorphicTo a a where + to = id + +-- 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 new file mode 100644 --- /dev/null +++ b/src/IsomorphismClass/Isomorphism.hs @@ -0,0 +1,79 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/NumHask/Extra.hs @@ -0,0 +1,39 @@ +{-# 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/Prelude/InfBackprop.hs b/src/Prelude/InfBackprop.hs new file mode 100644 --- /dev/null +++ b/src/Prelude/InfBackprop.hs @@ -0,0 +1,623 @@ +{-# 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)