diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,10 +1,23 @@ Changelog ========= +Version 0.1.5.2 +--------------- + +*Apr 26, 2018* + + + +* 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* diff --git a/backprop.cabal b/backprop.cabal --- a/backprop.cabal +++ b/backprop.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 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 diff --git a/bench/MNISTBench.hs b/bench/MNISTBench.hs deleted file mode 100644 --- a/bench/MNISTBench.hs +++ /dev/null @@ -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 - diff --git a/bench/bench.hs b/bench/bench.hs new file mode 100644 --- /dev/null +++ b/bench/bench.hs @@ -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 + diff --git a/src/Data/Type/Util.hs b/src/Data/Type/Util.hs --- a/src/Data/Type/Util.hs +++ b/src/Data/Type/Util.hs @@ -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 diff --git a/src/Numeric/Backprop.hs b/src/Numeric/Backprop.hs --- a/src/Numeric/Backprop.hs +++ b/src/Numeric/Backprop.hs @@ -56,7 +56,7 @@ , backprop2, evalBP2, gradBP2 , backpropN, evalBPN, gradBPN, Every -- * Manipulating 'BVar' - , constVar + , constVar, coerceVar , (^^.), (.~~), (^^?), (^^..) , viewVar, setVar , sequenceVar, collectVar diff --git a/src/Numeric/Backprop/Internal.hs b/src/Numeric/Backprop/Internal.hs --- a/src/Numeric/Backprop/Internal.hs +++ b/src/Numeric/Backprop/Internal.hs @@ -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 #-} + diff --git a/src/Numeric/Backprop/Tuple.hs b/src/Numeric/Backprop/Tuple.hs --- a/src/Numeric/Backprop/Tuple.hs +++ b/src/Numeric/Backprop/Tuple.hs @@ -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 --