backprop 0.1.5.1 → 0.1.5.2

raw patch · 8 files changed

+420/−351 lines, 8 filesdep +randomPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

Dependencies added: random

API changes (from Hackage documentation)

Files

• CHANGELOG.md +14/−1
• backprop.cabal +4/−3
• bench/MNISTBench.hs +0/−334
• bench/bench.hs +334/−0
• src/Data/Type/Util.hs +0/−11
• src/Numeric/Backprop.hs +1/−1
• src/Numeric/Backprop/Internal.hs +12/−0
• src/Numeric/Backprop/Tuple.hs +55/−1

@@ -1,10 +1,23 @@ Changelog ========= +Version 0.1.5.2+---------------++*Apr 26, 2018*++<https://github.com/mstksg/backprop/releases/tag/v0.1.5.2>++*   Added `coerceVar` to *Numeric.Backprop*+*   Added `Random` instaces for all tuple types.  Same as for `Binary`, this+    does incur a *random* and *time* dependency only from the tuple types.+    Again, because these packages are a part of GHC's boot libraries, this+    is hopefully not too bad.+ Version 0.1.5.1 --------------- -*Apr 8, 2018*+*Apr 9, 2018*  <https://github.com/mstksg/backprop/releases/tag/v0.1.5.1> 

@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 27ad120cc4fb815335e1be622df84ce63c95b38332af173a6898e59a80a7c0ad+-- hash: 1a3823df38b9b0fe0ecb1481bea9f4b591e24a0abe5f96c21bf88c2b6055851b  name:           backprop-version:        0.1.5.1+version:        0.1.5.2 synopsis:       Heterogeneous automatic differentation (backpropagation) description:    Write your functions to compute your result, and the library will                 automatically generate functions to compute your gradient.@@ -51,6 +51,7 @@     , deepseq     , microlens     , primitive+    , random     , reflection     , transformers     , type-combinators@@ -67,7 +68,7 @@  benchmark backprop-mnist-bench   type: exitcode-stdio-1.0-  main-is: MNISTBench.hs+  main-is: bench.hs   hs-source-dirs:       bench   ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wredundant-constraints -fprint-explicit-kinds -threaded -rtsopts -with-rtsopts=-N -O2

@@ -1,334 +0,0 @@-{-# LANGUAGE BangPatterns         #-}-{-# LANGUAGE DataKinds            #-}-{-# LANGUAGE DeriveGeneric        #-}-{-# LANGUAGE FlexibleContexts     #-}-{-# LANGUAGE GADTs                #-}-{-# LANGUAGE LambdaCase           #-}-{-# LANGUAGE ScopedTypeVariables  #-}-{-# LANGUAGE TemplateHaskell      #-}-{-# LANGUAGE TypeApplications     #-}-{-# LANGUAGE ViewPatterns         #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--import           Control.DeepSeq-import           Control.Exception-import           Control.Lens hiding          ((:<), (<.>))-import           Control.Monad.IO.Class-import           Control.Monad.Trans.Maybe-import           Criterion.Main-import           Criterion.Types-import           Data.Bitraversable-import           Data.IDX-import           Data.Time-import           Data.Traversable-import           Data.Tuple-import           GHC.Generics                 (Generic)-import           GHC.TypeLits-import           Numeric.Backprop-import           Numeric.LinearAlgebra.Static-import           System.Directory-import qualified Data.Vector.Generic          as VG-import qualified Data.Vector.Unboxed          as VU-import qualified Numeric.LinearAlgebra        as HM-import qualified System.Random.MWC            as MWC--data Layer i o =-    Layer { _lWeights :: !(L o i)-          , _lBiases  :: !(R o)-          }-  deriving (Show, Generic)--instance NFData (Layer i o)--makeLenses ''Layer--data Network i h1 h2 o =-    Net { _nLayer1 :: !(Layer i  h1)-        , _nLayer2 :: !(Layer h1 h2)-        , _nLayer3 :: !(Layer h2 o)-        }-  deriving (Show, Generic)--instance NFData (Network i h1 h2 o)--makeLenses ''Network--infixr 8 #>!-(#>!)-    :: (KnownNat m, KnownNat n, Reifies s W)-    => BVar s (L m n)-    -> BVar s (R n)-    -> BVar s (R m)-(#>!) = liftOp2 . op2 $ \m v ->-  ( m #> v, \g -> (g `outer` v, tr m #> g) )---infixr 8 <.>!-(<.>!)-    :: (KnownNat n, Reifies s W)-    => BVar s (R n)-    -> BVar s (R n)-    -> BVar s Double-(<.>!) = liftOp2 . op2 $ \x y ->-  ( x <.> y, \g -> (konst g * y, x * konst g)-  )--konst'-    :: (KnownNat n, Reifies s W)-    => BVar s Double-    -> BVar s (R n)-konst' = liftOp1 . op1 $ \c -> (konst c, HM.sumElements . extract)--sumElements :: KnownNat n => R n -> Double-sumElements = HM.sumElements . extract--sumElements'-    :: (KnownNat n, Reifies s W)-    => BVar s (R n)-    -> BVar s Double-sumElements' = liftOp1 . op1 $ \x -> (sumElements x, konst)--logistic :: Floating a => a -> a-logistic x = 1 / (1 + exp (-x))-{-# INLINE logistic #-}--runLayer-    :: (KnownNat i, KnownNat o, Reifies s W)-    => BVar s (Layer i o)-    -> BVar s (R i)-    -> BVar s (R o)-runLayer l x = (l ^^. lWeights) #>! x + (l ^^. lBiases)-{-# INLINE runLayer #-}--softMax :: (KnownNat n, Reifies s W) => BVar s (R n) -> BVar s (R n)-softMax x = konst' (1 / sumElements' expx) * expx-  where-    expx = exp x-{-# INLINE softMax #-}--runNetwork-    :: (KnownNat i, KnownNat h1, KnownNat h2, KnownNat o, Reifies s W)-    => BVar s (Network i h1 h2 o)-    -> R i-    -> BVar s (R o)-runNetwork n = softMax-             . runLayer (n ^^. nLayer3)-             . logistic-             . runLayer (n ^^. nLayer2)-             . logistic-             . runLayer (n ^^. nLayer1)-             . constVar-{-# INLINE runNetwork #-}--crossEntropy :: (KnownNat n, Reifies s W) => R n -> BVar s (R n) -> BVar s Double-crossEntropy t r = negate $ log r <.>! constVar t-{-# INLINE crossEntropy #-}--netErr-    :: (KnownNat i, KnownNat h1, KnownNat h2, KnownNat o, Reifies s W)-    => R i-    -> R o-    -> BVar s (Network i h1 h2 o)-    -> BVar s Double-netErr x t n = crossEntropy t (runNetwork n x)-{-# INLINE netErr #-}--trainStep-    :: forall i h1 h2 o. (KnownNat i, KnownNat h1, KnownNat h2, KnownNat o)-    => Double-    -> R i-    -> R o-    -> Network i h1 h2 o-    -> Network i h1 h2 o-trainStep r !x !t !n = n - realToFrac r * gradBP (netErr x t) n-{-# INLINE trainStep #-}--runLayerManual-    :: (KnownNat i, KnownNat o)-    => Layer i o-    -> R i-    -> R o-runLayerManual l x = (l ^. lWeights) #> x + (l ^. lBiases)-{-# INLINE runLayerManual #-}--softMaxManual :: KnownNat n => R n -> R n-softMaxManual x = konst (1 / sumElements expx) * expx-  where-    expx = exp x-{-# INLINE softMaxManual #-}--runNetManual-    :: (KnownNat i, KnownNat h1, KnownNat h2, KnownNat o)-    => Network i h1 h2 o-    -> R i-    -> R o-runNetManual n = softMaxManual-               . runLayerManual (n ^. nLayer3)-               . logistic-               . runLayerManual (n ^. nLayer2)-               . logistic-               . runLayerManual (n ^. nLayer1)-{-# INLINE runNetManual #-}--gradNetManual-    :: forall i h1 h2 o. (KnownNat i, KnownNat h1, KnownNat h2, KnownNat o)-    => R i-    -> R o-    -> Network i h1 h2 o-    -> Network i h1 h2 o-gradNetManual x t (Net (Layer w1 b1) (Layer w2 b2) (Layer w3 b3)) =-    let y1 = w1 #> x-        z1 = y1 + b1-        x2 = logistic z1-        y2 = w2 #> x2-        z2 = y2 + b2-        x3 = logistic z2-        y3 = w3 #> x3-        z3 = y3 + b3-        o0 = exp z3-        o1 = HM.sumElements (extract o0)-        o2 = o0 / konst o1-        -- o3 = - (log o2 <.> t)-        dEdO3 = 1-        dEdO2 = dEdO3 * (- t / o2)-        dEdO1 = - (dEdO2 <.> o0) / (o1 ** 2)-        dEdO0 = konst dEdO1 + dEdO2 / konst o1-        dEdZ3 = dEdO0 * o0-        dEdY3 = dEdZ3-        dEdX3 = tr w3 #> dEdY3-        dEdZ2 = dEdX3 * (x3 * (1 - x3))-        dEdY2 = dEdZ2-        dEdX2 = tr w2 #> dEdY2-        dEdZ1 = dEdX2 * (x2 * (1 - x2))-        dEdY1 = dEdZ1-        dEdB3 = dEdZ3-        dEdW3 = dEdY3 `outer` x3-        dEdB2 = dEdZ2-        dEdW2 = dEdY2 `outer` x2-        dEdB1 = dEdZ1-        dEdW1 = dEdY1 `outer` x-    in  Net (Layer dEdW1 dEdB1) (Layer dEdW2 dEdB2) (Layer dEdW3 dEdB3)-{-# INLINE gradNetManual #-}--trainStepManual-    :: forall i h1 h2 o. (KnownNat i, KnownNat h1, KnownNat h2, KnownNat o)-    => Double-    -> R i-    -> R o-    -> Network i h1 h2 o-    -> Network i h1 h2 o-trainStepManual r !x !t !n =-    let gN = gradNetManual x t n-    in  n - (realToFrac r * gN)--main :: IO ()-main = MWC.withSystemRandom $ \g -> do-    Just test  <- loadMNIST "data/t10k-images-idx3-ubyte"  "data/t10k-labels-idx1-ubyte"-    putStrLn "Loaded data."-    net0 <- MWC.uniformR @(Network 784 300 100 9) (-0.5, 0.5) g-    createDirectoryIfMissing True "bench-results"-    t <- getZonedTime-    let test0   = head test-        tstr    = formatTime defaultTimeLocale "%Y%m%d-%H%M%S" t-    defaultMainWith defaultConfig-          { reportFile = Just $ "bench-results/mnist-bench_" ++ tstr ++ ".html"-          , timeLimit  = 10-          } [-        bgroup "gradient" [-            let testManual x y = gradNetManual x y net0-            in  bench "manual" $ nf (uncurry testManual) test0-          , let testBP     x y = gradBP (netErr x y) net0-            in  bench "bp"     $ nf (uncurry testBP) test0-          ]-      , bgroup "descent" [-            let testManual x y = trainStepManual 0.02 x y net0-            in  bench "manual" $ nf (uncurry testManual) test0-          , let testBP     x y = trainStep 0.02 x y net0-            in  bench "bp"     $ nf (uncurry testBP) test0-          ]-      , bgroup "run" [-            let testManual     = runNetManual net0-            in  bench "manual" $ nf testManual (fst test0)-          , let testBP     x   = evalBP (`runNetwork` x) net0-            in  bench "bp"     $ nf testBP (fst test0)-          ]-      ]--loadMNIST-    :: FilePath-    -> FilePath-    -> IO (Maybe [(R 784, R 9)])-loadMNIST fpI fpL = runMaybeT $ do-    i <- MaybeT          $ decodeIDXFile       fpI-    l <- MaybeT          $ decodeIDXLabelsFile fpL-    d <- MaybeT . return $ labeledIntData l i-    r <- MaybeT . return $ for d (bitraverse mkImage mkLabel . swap)-    liftIO . evaluate $ force r-  where-    mkImage :: VU.Vector Int -> Maybe (R 784)-    mkImage = create . VG.convert . VG.map (\i -> fromIntegral i / 255)-    mkLabel :: Int -> Maybe (R 9)-    mkLabel n = create $ HM.build 9 (\i -> if round i == n then 1 else 0)--instance (KnownNat i, KnownNat o) => Num (Layer i o) where-    Layer w1 b1 + Layer w2 b2 = Layer (w1 + w2) (b1 + b2)-    Layer w1 b1 - Layer w2 b2 = Layer (w1 - w2) (b1 - b2)-    Layer w1 b1 * Layer w2 b2 = Layer (w1 * w2) (b1 * b2)-    abs    (Layer w b)        = Layer (abs    w) (abs    b)-    signum (Layer w b)        = Layer (signum w) (signum b)-    negate (Layer w b)        = Layer (negate w) (negate b)-    fromInteger x             = Layer (fromInteger x) (fromInteger x)--instance (KnownNat i, KnownNat h1, KnownNat h2, KnownNat o) => Num (Network i h1 h2 o) where-    Net a b c + Net d e f = Net (a + d) (b + e) (c + f)-    Net a b c - Net d e f = Net (a - d) (b - e) (c - f)-    Net a b c * Net d e f = Net (a * d) (b * e) (c * f)-    abs    (Net a b c)    = Net (abs    a) (abs    b) (abs    c)-    signum (Net a b c)    = Net (signum a) (signum b) (signum c)-    negate (Net a b c)    = Net (negate a) (negate b) (negate c)-    fromInteger x         = Net (fromInteger x) (fromInteger x) (fromInteger x)--instance (KnownNat i, KnownNat o) => Fractional (Layer i o) where-    Layer w1 b1 / Layer w2 b2 = Layer (w1 / w2) (b1 / b2)-    recip (Layer w b)         = Layer (recip w) (recip b)-    fromRational x            = Layer (fromRational x) (fromRational x)--instance (KnownNat i, KnownNat h1, KnownNat h2, KnownNat o) => Fractional (Network i h1 h2 o) where-    Net a b c / Net d e f = Net (a / d) (b / e) (c / f)-    recip (Net a b c)     = Net (recip a) (recip b) (recip c)-    fromRational x        = Net (fromRational x) (fromRational x) (fromRational x)--instance KnownNat n => MWC.Variate (R n) where-    uniform g = randomVector <$> MWC.uniform g <*> pure Uniform-    uniformR (l, h) g = (\x -> x * (h - l) + l) <$> MWC.uniform g--instance (KnownNat m, KnownNat n) => MWC.Variate (L m n) where-    uniform g = uniformSample <$> MWC.uniform g <*> pure 0 <*> pure 1-    uniformR (l, h) g = (\x -> x * (h - l) + l) <$> MWC.uniform g--instance (KnownNat i, KnownNat o) => MWC.Variate (Layer i o) where-    uniform g = Layer <$> MWC.uniform g <*> MWC.uniform g-    uniformR (l, h) g = (\x -> x * (h - l) + l) <$> MWC.uniform g--instance (KnownNat i, KnownNat h1, KnownNat h2, KnownNat o) => MWC.Variate (Network i h1 h2 o) where-    uniform g = Net <$> MWC.uniform g <*> MWC.uniform g <*> MWC.uniform g-    uniformR (l, h) g = (\x -> x * (h - l) + l) <$> MWC.uniform g--instance (Num a, Num b) => Num (a, b) where-    (x1,y1) + (x2,y2) = (x1 + x2, y1 + y2)-    (x1,y1) * (x2,y2) = (x1 * x2, y1 * y2)-    (x1,y1) - (x2,y2) = (x1 - x2, y1 - y2)-    abs (x, y)        = (abs x, abs y)-    signum (x, y)     = (signum x, signum y)-    fromInteger x     = (fromInteger x, fromInteger x)---- softMaxCrossEntropy---     :: KnownNat n---     => R n---     -> BPOpI s '[ R n ] Double--- softMaxCrossEntropy targ (r :< Ø) =  realToFrac tsum * log (vsum .$ (r :< Ø))---                                        - (dot .$ (r :< t :< Ø))---   where---     tsum = HM.sumElements . extract $ targ---     t    = constVar targ-

@@ -0,0 +1,334 @@+{-# LANGUAGE BangPatterns         #-}+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE DeriveGeneric        #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE GADTs                #-}+{-# LANGUAGE LambdaCase           #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TemplateHaskell      #-}+{-# LANGUAGE TypeApplications     #-}+{-# LANGUAGE ViewPatterns         #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++import           Control.DeepSeq+import           Control.Exception+import           Control.Lens hiding          ((:<), (<.>))+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Maybe+import           Criterion.Main+import           Criterion.Types+import           Data.Bitraversable+import           Data.IDX+import           Data.Time+import           Data.Traversable+import           Data.Tuple+import           GHC.Generics                 (Generic)+import           GHC.TypeLits+import           Numeric.Backprop+import           Numeric.LinearAlgebra.Static+import           System.Directory+import qualified Data.Vector.Generic          as VG+import qualified Data.Vector.Unboxed          as VU+import qualified Numeric.LinearAlgebra        as HM+import qualified System.Random.MWC            as MWC++data Layer i o =+    Layer { _lWeights :: !(L o i)+          , _lBiases  :: !(R o)+          }+  deriving (Show, Generic)++instance NFData (Layer i o)++makeLenses ''Layer++data Network i h1 h2 o =+    Net { _nLayer1 :: !(Layer i  h1)+        , _nLayer2 :: !(Layer h1 h2)+        , _nLayer3 :: !(Layer h2 o)+        }+  deriving (Show, Generic)++instance NFData (Network i h1 h2 o)++makeLenses ''Network++infixr 8 #>!+(#>!)+    :: (KnownNat m, KnownNat n, Reifies s W)+    => BVar s (L m n)+    -> BVar s (R n)+    -> BVar s (R m)+(#>!) = liftOp2 . op2 $ \m v ->+  ( m #> v, \g -> (g `outer` v, tr m #> g) )+++infixr 8 <.>!+(<.>!)+    :: (KnownNat n, Reifies s W)+    => BVar s (R n)+    -> BVar s (R n)+    -> BVar s Double+(<.>!) = liftOp2 . op2 $ \x y ->+  ( x <.> y, \g -> (konst g * y, x * konst g)+  )++konst'+    :: (KnownNat n, Reifies s W)+    => BVar s Double+    -> BVar s (R n)+konst' = liftOp1 . op1 $ \c -> (konst c, HM.sumElements . extract)++sumElements :: KnownNat n => R n -> Double+sumElements = HM.sumElements . extract++sumElements'+    :: (KnownNat n, Reifies s W)+    => BVar s (R n)+    -> BVar s Double+sumElements' = liftOp1 . op1 $ \x -> (sumElements x, konst)++logistic :: Floating a => a -> a+logistic x = 1 / (1 + exp (-x))+{-# INLINE logistic #-}++runLayer+    :: (KnownNat i, KnownNat o, Reifies s W)+    => BVar s (Layer i o)+    -> BVar s (R i)+    -> BVar s (R o)+runLayer l x = (l ^^. lWeights) #>! x + (l ^^. lBiases)+{-# INLINE runLayer #-}++softMax :: (KnownNat n, Reifies s W) => BVar s (R n) -> BVar s (R n)+softMax x = konst' (1 / sumElements' expx) * expx+  where+    expx = exp x+{-# INLINE softMax #-}++runNetwork+    :: (KnownNat i, KnownNat h1, KnownNat h2, KnownNat o, Reifies s W)+    => BVar s (Network i h1 h2 o)+    -> R i+    -> BVar s (R o)+runNetwork n = softMax+             . runLayer (n ^^. nLayer3)+             . logistic+             . runLayer (n ^^. nLayer2)+             . logistic+             . runLayer (n ^^. nLayer1)+             . constVar+{-# INLINE runNetwork #-}++crossEntropy :: (KnownNat n, Reifies s W) => R n -> BVar s (R n) -> BVar s Double+crossEntropy t r = negate $ log r <.>! constVar t+{-# INLINE crossEntropy #-}++netErr+    :: (KnownNat i, KnownNat h1, KnownNat h2, KnownNat o, Reifies s W)+    => R i+    -> R o+    -> BVar s (Network i h1 h2 o)+    -> BVar s Double+netErr x t n = crossEntropy t (runNetwork n x)+{-# INLINE netErr #-}++trainStep+    :: forall i h1 h2 o. (KnownNat i, KnownNat h1, KnownNat h2, KnownNat o)+    => Double+    -> R i+    -> R o+    -> Network i h1 h2 o+    -> Network i h1 h2 o+trainStep r !x !t !n = n - realToFrac r * gradBP (netErr x t) n+{-# INLINE trainStep #-}++runLayerManual+    :: (KnownNat i, KnownNat o)+    => Layer i o+    -> R i+    -> R o+runLayerManual l x = (l ^. lWeights) #> x + (l ^. lBiases)+{-# INLINE runLayerManual #-}++softMaxManual :: KnownNat n => R n -> R n+softMaxManual x = konst (1 / sumElements expx) * expx+  where+    expx = exp x+{-# INLINE softMaxManual #-}++runNetManual+    :: (KnownNat i, KnownNat h1, KnownNat h2, KnownNat o)+    => Network i h1 h2 o+    -> R i+    -> R o+runNetManual n = softMaxManual+               . runLayerManual (n ^. nLayer3)+               . logistic+               . runLayerManual (n ^. nLayer2)+               . logistic+               . runLayerManual (n ^. nLayer1)+{-# INLINE runNetManual #-}++gradNetManual+    :: forall i h1 h2 o. (KnownNat i, KnownNat h1, KnownNat h2, KnownNat o)+    => R i+    -> R o+    -> Network i h1 h2 o+    -> Network i h1 h2 o+gradNetManual x t (Net (Layer w1 b1) (Layer w2 b2) (Layer w3 b3)) =+    let y1 = w1 #> x+        z1 = y1 + b1+        x2 = logistic z1+        y2 = w2 #> x2+        z2 = y2 + b2+        x3 = logistic z2+        y3 = w3 #> x3+        z3 = y3 + b3+        o0 = exp z3+        o1 = HM.sumElements (extract o0)+        o2 = o0 / konst o1+        -- o3 = - (log o2 <.> t)+        dEdO3 = 1+        dEdO2 = dEdO3 * (- t / o2)+        dEdO1 = - (dEdO2 <.> o0) / (o1 ** 2)+        dEdO0 = konst dEdO1 + dEdO2 / konst o1+        dEdZ3 = dEdO0 * o0+        dEdY3 = dEdZ3+        dEdX3 = tr w3 #> dEdY3+        dEdZ2 = dEdX3 * (x3 * (1 - x3))+        dEdY2 = dEdZ2+        dEdX2 = tr w2 #> dEdY2+        dEdZ1 = dEdX2 * (x2 * (1 - x2))+        dEdY1 = dEdZ1+        dEdB3 = dEdZ3+        dEdW3 = dEdY3 `outer` x3+        dEdB2 = dEdZ2+        dEdW2 = dEdY2 `outer` x2+        dEdB1 = dEdZ1+        dEdW1 = dEdY1 `outer` x+    in  Net (Layer dEdW1 dEdB1) (Layer dEdW2 dEdB2) (Layer dEdW3 dEdB3)+{-# INLINE gradNetManual #-}++trainStepManual+    :: forall i h1 h2 o. (KnownNat i, KnownNat h1, KnownNat h2, KnownNat o)+    => Double+    -> R i+    -> R o+    -> Network i h1 h2 o+    -> Network i h1 h2 o+trainStepManual r !x !t !n =+    let gN = gradNetManual x t n+    in  n - (realToFrac r * gN)++main :: IO ()+main = MWC.withSystemRandom $ \g -> do+    Just test  <- loadMNIST "data/t10k-images-idx3-ubyte"  "data/t10k-labels-idx1-ubyte"+    putStrLn "Loaded data."+    net0 <- MWC.uniformR @(Network 784 300 100 9) (-0.5, 0.5) g+    createDirectoryIfMissing True "bench-results"+    t <- getZonedTime+    let test0   = head test+        tstr    = formatTime defaultTimeLocale "%Y%m%d-%H%M%S" t+    defaultMainWith defaultConfig+          { reportFile = Just $ "bench-results/mnist-bench_" ++ tstr ++ ".html"+          , timeLimit  = 10+          } [+        bgroup "gradient" [+            let testManual x y = gradNetManual x y net0+            in  bench "manual" $ nf (uncurry testManual) test0+          , let testBP     x y = gradBP (netErr x y) net0+            in  bench "bp"     $ nf (uncurry testBP) test0+          ]+      , bgroup "descent" [+            let testManual x y = trainStepManual 0.02 x y net0+            in  bench "manual" $ nf (uncurry testManual) test0+          , let testBP     x y = trainStep 0.02 x y net0+            in  bench "bp"     $ nf (uncurry testBP) test0+          ]+      , bgroup "run" [+            let testManual     = runNetManual net0+            in  bench "manual" $ nf testManual (fst test0)+          , let testBP     x   = evalBP (`runNetwork` x) net0+            in  bench "bp"     $ nf testBP (fst test0)+          ]+      ]++loadMNIST+    :: FilePath+    -> FilePath+    -> IO (Maybe [(R 784, R 9)])+loadMNIST fpI fpL = runMaybeT $ do+    i <- MaybeT          $ decodeIDXFile       fpI+    l <- MaybeT          $ decodeIDXLabelsFile fpL+    d <- MaybeT . return $ labeledIntData l i+    r <- MaybeT . return $ for d (bitraverse mkImage mkLabel . swap)+    liftIO . evaluate $ force r+  where+    mkImage :: VU.Vector Int -> Maybe (R 784)+    mkImage = create . VG.convert . VG.map (\i -> fromIntegral i / 255)+    mkLabel :: Int -> Maybe (R 9)+    mkLabel n = create $ HM.build 9 (\i -> if round i == n then 1 else 0)++instance (KnownNat i, KnownNat o) => Num (Layer i o) where+    Layer w1 b1 + Layer w2 b2 = Layer (w1 + w2) (b1 + b2)+    Layer w1 b1 - Layer w2 b2 = Layer (w1 - w2) (b1 - b2)+    Layer w1 b1 * Layer w2 b2 = Layer (w1 * w2) (b1 * b2)+    abs    (Layer w b)        = Layer (abs    w) (abs    b)+    signum (Layer w b)        = Layer (signum w) (signum b)+    negate (Layer w b)        = Layer (negate w) (negate b)+    fromInteger x             = Layer (fromInteger x) (fromInteger x)++instance (KnownNat i, KnownNat h1, KnownNat h2, KnownNat o) => Num (Network i h1 h2 o) where+    Net a b c + Net d e f = Net (a + d) (b + e) (c + f)+    Net a b c - Net d e f = Net (a - d) (b - e) (c - f)+    Net a b c * Net d e f = Net (a * d) (b * e) (c * f)+    abs    (Net a b c)    = Net (abs    a) (abs    b) (abs    c)+    signum (Net a b c)    = Net (signum a) (signum b) (signum c)+    negate (Net a b c)    = Net (negate a) (negate b) (negate c)+    fromInteger x         = Net (fromInteger x) (fromInteger x) (fromInteger x)++instance (KnownNat i, KnownNat o) => Fractional (Layer i o) where+    Layer w1 b1 / Layer w2 b2 = Layer (w1 / w2) (b1 / b2)+    recip (Layer w b)         = Layer (recip w) (recip b)+    fromRational x            = Layer (fromRational x) (fromRational x)++instance (KnownNat i, KnownNat h1, KnownNat h2, KnownNat o) => Fractional (Network i h1 h2 o) where+    Net a b c / Net d e f = Net (a / d) (b / e) (c / f)+    recip (Net a b c)     = Net (recip a) (recip b) (recip c)+    fromRational x        = Net (fromRational x) (fromRational x) (fromRational x)++instance KnownNat n => MWC.Variate (R n) where+    uniform g = randomVector <$> MWC.uniform g <*> pure Uniform+    uniformR (l, h) g = (\x -> x * (h - l) + l) <$> MWC.uniform g++instance (KnownNat m, KnownNat n) => MWC.Variate (L m n) where+    uniform g = uniformSample <$> MWC.uniform g <*> pure 0 <*> pure 1+    uniformR (l, h) g = (\x -> x * (h - l) + l) <$> MWC.uniform g++instance (KnownNat i, KnownNat o) => MWC.Variate (Layer i o) where+    uniform g = Layer <$> MWC.uniform g <*> MWC.uniform g+    uniformR (l, h) g = (\x -> x * (h - l) + l) <$> MWC.uniform g++instance (KnownNat i, KnownNat h1, KnownNat h2, KnownNat o) => MWC.Variate (Network i h1 h2 o) where+    uniform g = Net <$> MWC.uniform g <*> MWC.uniform g <*> MWC.uniform g+    uniformR (l, h) g = (\x -> x * (h - l) + l) <$> MWC.uniform g++instance (Num a, Num b) => Num (a, b) where+    (x1,y1) + (x2,y2) = (x1 + x2, y1 + y2)+    (x1,y1) * (x2,y2) = (x1 * x2, y1 * y2)+    (x1,y1) - (x2,y2) = (x1 - x2, y1 - y2)+    abs (x, y)        = (abs x, abs y)+    signum (x, y)     = (signum x, signum y)+    fromInteger x     = (fromInteger x, fromInteger x)++-- softMaxCrossEntropy+--     :: KnownNat n+--     => R n+--     -> BPOpI s '[ R n ] Double+-- softMaxCrossEntropy targ (r :< Ø) =  realToFrac tsum * log (vsum .$ (r :< Ø))+--                                        - (dot .$ (r :< t :< Ø))+--   where+--     tsum = HM.sumElements . extract $ targ+--     t    = constVar targ+

@@ -13,7 +13,6 @@   , zipWithPM_   , vecToProd   , vecLen-  , prodToVec'   , lengthProd   , listToVecDef   , fillProd@@ -51,16 +50,6 @@ vecLen = \case     ØV      -> Z_     _ :* xs -> S_ (vecLen xs)--prodToVec'-    :: Nat n-    -> Prod f (Replicate n a)-    -> VecT n f a-prodToVec' = \case-    Z_   -> \case-      Ø       -> ØV-    S_ n -> \case-      x :< xs -> x :* prodToVec' n xs  zipWithPM_     :: forall h f g as. Applicative h

@@ -56,7 +56,7 @@   , backprop2, evalBP2, gradBP2   , backpropN, evalBPN, gradBPN, Every     -- * Manipulating 'BVar'-  , constVar+  , constVar, coerceVar   , (^^.), (.~~), (^^?), (^^..)   , viewVar, setVar   , sequenceVar, collectVar

@@ -31,6 +31,7 @@   , constVar   , liftOp, liftOp1, liftOp2, liftOp3   , viewVar, setVar, sequenceVar, collectVar, previewVar, toListOfVar+  , coerceVar   -- * Debug   , debugSTN   , debugIR@@ -43,6 +44,7 @@ import           Control.Monad.ST import           Control.Monad.Trans.State import           Data.Bifunctor+import           Data.Coerce import           Data.Foldable import           Data.Function import           Data.IORef@@ -483,6 +485,15 @@ toListOfVar t !v = unsafePerformIO $ traverseVar' (toListOf t) t v {-# INLINE toListOfVar #-} +-- | Coerce a 'BVar' contents.  Useful for things like newtype wrappers.+--+-- @since 0.1.5.2+coerceVar+    :: Coercible a b+    => BVar s a+    -> BVar s b+coerceVar v@(BV r x) = forceBVar v `seq` BV r (coerce x)+ data Runner s = R { _rDelta  :: !(MV.MVector s Any)                   , _rInputs :: !(MV.MVector s Any)                   }@@ -716,3 +727,4 @@         go []     = error "asList"         go (y:ys) = (y, ys) {-# INLINE ixt #-}+

@@ -12,6 +12,7 @@ {-# LANGUAGE RankNTypes            #-} {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TupleSections         #-} {-# LANGUAGE TypeApplications      #-} {-# LANGUAGE TypeInType            #-} {-# LANGUAGE TypeOperators         #-}@@ -102,6 +103,7 @@   ) where  import           Control.DeepSeq+import           Control.Monad.Trans.State import           Data.Bifunctor import           Data.Data import           Data.Kind@@ -112,6 +114,7 @@ import           GHC.Generics               (Generic) import           Lens.Micro import           Lens.Micro.Internal hiding (Index)+import           System.Random import           Type.Class.Known import           Type.Family.List import qualified Data.Binary                as Bi@@ -188,8 +191,35 @@       TNil    -> ()       x :& xs -> rnf x `seq` rnf xs --- TODO: optimize+-- | @since 0.1.5.2+instance Random T0 where+    randomR  _   = (T0,)+    random       = (T0,)+    randomRs _ _ = repeat T0+    randoms  _   = repeat T0+    randomIO     = pure T0 +-- | @since 0.1.5.2+instance (Random a, Random b) => Random (T2 a b) where+    randomR (T2 lx ly, T2 ux uy) = runState $+        T2 <$> state (randomR (lx, ux))+           <*> state (randomR (ly, uy))+    random = runState $+        T2 <$> state random <*> state random++-- | @since 0.1.5.2+instance (Random a, Random b, Random c) => Random (T3 a b c) where+    randomR (T3 lx ly lz, T3 ux uy uz) = runState $+        T3 <$> state (randomR (lx, ux))+           <*> state (randomR (ly, uy))+           <*> state (randomR (lz, uz))+    random = runState $+        T3 <$> state random <*> state random <*> state random++++-- TODO: optimize?+ -- | @since 0.1.5.1 instance Bi.Binary T0 -- | @since 0.1.5.1@@ -629,6 +659,30 @@       x  <- Bi.get       xs <- getT l       pure (x :& xs)++-- | @since 0.1.5.2+instance (Known Length as, ListC (Random <$> as)) => Random (T as) where+    randomR (l, u) = runState (randomRT l u)+    random         = runState (randomT known)++randomRT+    :: (ListC (Random <$> as), RandomGen g)+    => T as+    -> T as+    -> State g (T as)+randomRT = \case+    TNil -> \case+      TNil -> pure TNil+    lx :& lxs -> \case+      ux :& uxs -> (:&) <$> state (randomR (lx, ux)) <*> randomRT lxs uxs++randomT+    :: (ListC (Random <$> as), RandomGen g)+    => Length as+    -> State g (T as)+randomT = \case+    LZ   -> pure TNil+    LS l -> (:&) <$> state random <*> randomT l  -- $t2iso --