hasktorch-zoo (empty) → 0.0.1.0
raw patch · 9 files changed
+1252/−0 lines, 9 filesdep +JuicyPixelsdep +backpropdep +base
Dependencies added: JuicyPixels, backprop, base, deepseq, dimensions, directory, filepath, gd, generic-lens, ghc-typelits-natnormalise, hashable, hasktorch, microlens, mtl, mwc-random, primitive, safe-exceptions, singletons, transformers, vector
Files
- hasktorch-zoo.cabal +83/−0
- src/Torch/Data/Loaders/Cifar10.hs +117/−0
- src/Torch/Data/Loaders/Internal.hs +91/−0
- src/Torch/Data/Loaders/Logging.hs +7/−0
- src/Torch/Data/Loaders/RGBVector.hs +180/−0
- src/Torch/Data/Metrics.hs +27/−0
- src/Torch/Data/OneHot.hs +55/−0
- src/Torch/Initialization.hs +334/−0
- src/Torch/Models/Vision/LeNet.hs +358/−0
+ hasktorch-zoo.cabal view
@@ -0,0 +1,83 @@+cabal-version: 2.2+-- * * * * * * * * * * * * WARNING * * * * * * * * * * * *+-- This file has been AUTO-GENERATED by dhall-to-cabal.+--+-- Do not edit it by hand, because your changes will be over-written!+--+-- Instead, edit the source Dhall file, namely+-- 'zoo/hasktorch-zoo.dhall', and re-generate this file by running+-- 'dhall-to-cabal -- zoo/hasktorch-zoo.dhall > hasktorch-zoo.cabal'.+-- * * * * * * * * * * * * WARNING * * * * * * * * * * * *+name: hasktorch-zoo+version: 0.0.1.0+license: BSD-3-Clause+maintainer: Sam Stites <fnz@fgvgrf.vb>, Austin Huang <nhfgvau@nyhz.zvg.rqh> - cipher:ROT13+author: Hasktorch dev team+homepage: https://github.com/hasktorch/hasktorch#readme+bug-reports: https://github.com/hasktorch/hasktorch/issues+synopsis: Neural architectures in hasktorch+description:+ Neural architectures, data loading packages, initializations, and common tensor abstractions in hasktorch.+category: Tensors, Machine Learning, AI+build-type: Simple++source-repository head+ type: git+ location: https://github.com/hasktorch/hasktorch++flag cuda+ description:+ build with THC support+ default: False++flag gd+ description:+ use gd graphics library for loading images+ default: False++library+ exposed-modules:+ Torch.Data.Loaders.Internal+ Torch.Data.Loaders.RGBVector+ Torch.Data.Loaders.Cifar10+ Torch.Data.Loaders.Logging+ Torch.Data.Metrics+ Torch.Data.OneHot+ Torch.Models.Vision.LeNet+ Torch.Initialization+ hs-source-dirs: src+ default-language: Haskell2010+ default-extensions: LambdaCase DataKinds TypeFamilies+ TypeSynonymInstances ScopedTypeVariables FlexibleContexts CPP+ build-depends:+ base (==4.7 || >4.7) && <5,+ backprop ==0.2.5 || >0.2.5,+ dimensions ==1.0 || >1.0,+ hashable ==1.2.7 || >1.2.7,+ hasktorch (==0.0.1 || >0.0.1) && <0.0.2,+ microlens ==0.4.8 || >0.4.8,+ singletons ==2.2 || >2.2,+ generic-lens -any,+ ghc-typelits-natnormalise -any,+ vector ==0.12.0 || >0.12.0,+ directory ==1.3.0 || >1.3.0,+ filepath ==1.4.1 || >1.4.1,+ deepseq ==1.3.0 || >1.3.0,+ mwc-random ==0.14.0 || >0.14.0,+ primitive ==0.6.3 || >0.6.3,+ safe-exceptions ==0.1.0 || >0.1.0,+ mtl ==2.2.2 || >2.2.2,+ transformers ==0.5.5 || >0.5.5+ + if flag(gd)+ cpp-options: -DUSE_GD+ build-depends:+ gd -any+ else+ build-depends:+ JuicyPixels ==3.3 || >3.3+ + if flag(cuda)+ cpp-options: -DCUDA+ else+
+ src/Torch/Data/Loaders/Cifar10.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+module Torch.Data.Loaders.Cifar10+ ( default_cifar_path+ , Mode(..)+ , mode_path+ , testLength+ , trainLength+ , Category(..)+ , I.rgb2torch+ , cifar10set+ , defaultCifar10set+ ) where++import System.FilePath ((</>))+import Data.Proxy (Proxy(..))+import GHC.Generics (Generic)+import Text.Read (readMaybe)+import Control.DeepSeq (NFData)+import Data.Vector (Vector)+import System.Random.MWC (GenIO, createSystemRandom)+import Data.Hashable++#ifdef CUDA+import Torch.Cuda.Double+#else+import Torch.Double+#endif++import qualified Data.Char as Char+import qualified Torch.Data.Loaders.Internal as I++-- This should be replaced with a download-aware cache.+default_cifar_path :: FilePath+default_cifar_path = "/mnt/lake/datasets/cifar-10"++data Mode = Test | Train+ deriving (Eq, Enum, Ord, Show, Bounded)++testLength :: Proxy 'Test -> Proxy 1000+testLength _ = Proxy++trainLength :: Proxy 'Train -> Proxy 5000+trainLength _ = Proxy++data Category+ = Airplane -- 0+ | Automobile -- 2+ | Bird -- 3+ | Cat -- 4+ | Deer -- 5+ | Dog -- 6+ | Frog -- 7+ | Horse -- 8+ | Ship -- 9+ | Truck -- 10+ deriving (Eq, Enum, Ord, Show, Bounded, Generic, NFData, Read, Hashable)++mode_path :: FilePath -> Mode -> FilePath+mode_path cifarpath m = cifarpath </> (Char.toLower <$> show m)++cifar10set :: GenIO -> FilePath -> Mode -> IO (Vector (Category, FilePath))+cifar10set g p m = I.shuffleCatFolders g cast (mode_path p m)+ where+ cast :: FilePath -> Maybe Category+ cast fp =+ case filter (not . (`elem` ("/\\"::String))) fp of+ h:tl -> readMaybe (Char.toUpper h : map Char.toLower tl)+ _ -> Nothing++defaultCifar10set :: Mode -> IO (Vector (Category, FilePath))+defaultCifar10set m =+ createSystemRandom >>= \g -> cifar10set g default_cifar_path m++-- test :: Tensor '[1]+-- test+-- = evalBP+-- (classNLLCriterion (Long.unsafeVector [2] :: Long.Tensor '[1]))+-- (unsqueeze1d (dim :: Dim 0) $ unsafeVector [1,0,0] :: Tensor '[1, 3])+--+-- test2 :: Tensor '[1]+-- test2+-- = evalBP+-- ( _classNLLCriterion'+-- (-100) False True+-- -- (Long.unsafeMatrix [[0,1,0]] :: Long.Tensor '[1,3])+-- -- (Long.unsafeVector [0,1,0] :: Long.Tensor '[3])+-- (Long.unsafeVector [0,1,2] :: Long.Tensor '[3])+-- )+-- -- (unsafeVector [1,0,0] :: Tensor '[3])+-- -- (unsafeMatrix [[0,0,1]] :: Tensor '[1,3])+-- (unsafeMatrix+-- [ [1,0,0]+-- , [0,1,0]+-- , [0.5,0.5,0.5]+-- ] :: Tensor '[3,3])++-- test3 :: CPU.Tensor '[1]+-- test3+-- = evalBP+-- ( CPU._classNLLCriterion'+-- (-100) False True+-- -- (CPULong.unsafeMatrix [[0,1,0]] :: CPULong.Tensor '[1,3])+-- (CPULong.unsafeVector [0,8] :: CPULong.Tensor '[2])+-- -- (CPULong.unsafeVector [0,1,0] :: CPULong.Tensor '[3])+-- -- (CPULong.unsafeVector [0,1,2] :: CPULong.Tensor '[3])+-- )+-- -- (CPU.unsafeVector [1,0,0] :: CPU.Tensor '[3])+-- -- (CPU.unsafeMatrix [[0,0,1]] :: CPU.Tensor '[1,3])+-- (CPU.unsafeMatrix+-- [ [1,0,0]+-- -- , [0,1,0]+-- , [0.5,0.5,0.5]+-- ] :: CPU.Tensor '[2,3])++
+ src/Torch/Data/Loaders/Internal.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+module Torch.Data.Loaders.Internal where++-- import Prelude hiding (print, putStrLn)+-- import qualified Prelude as P (print, putStrLn)+-- import GHC.Int+import Data.Proxy+import Data.Vector (Vector)+-- import qualified Data.List as List ((!!))+-- import Control.Concurrent (threadDelay)+import Control.Monad (filterM)+-- import Control.Monad.Trans.Class+import Control.Monad.Trans.Except+-- import Control.Exception.Safe+-- import Control.DeepSeq+-- import GHC.Conc (getNumProcessors)+import GHC.TypeLits (KnownNat)+-- import Numeric.Dimensions+import System.Random.MWC (GenIO)+import System.Random.MWC.Distributions (uniformShuffle)+import System.Directory (listDirectory, doesDirectoryExist)+import System.FilePath ((</>), takeExtension)+-- import Control.Concurrent+--+-- import Control.Monad.Primitive+import qualified Data.Vector as V+-- import Data.Vector.Mutable (MVector)+-- import qualified Data.Vector.Mutable as M+--+#ifdef CUDA+import Torch.Cuda.Double+import qualified Torch.Cuda.Long as Long+import qualified Torch.Cuda.Double.Dynamic as Dynamic+import qualified Torch.Double.Dynamic as CPU+#else+import Torch.Double+import qualified Torch.Long as Long+import qualified Torch.Double.Storage as Storage+import qualified Torch.Double.Dynamic as Dynamic+#endif++import Torch.Data.Loaders.RGBVector+import Data.List++-- -- | asyncronously map across a pool with a maximum level of concurrency+-- mapPool :: Traversable t => Int -> (a -> IO b) -> t a -> IO (t b)+-- mapPool mx fn xs = do+-- sem <- MSem.new mx+-- Async.mapConcurrently (MSem.with sem . fn) xs++-- | load an RGB PNG image into a Torch tensor+rgb2torch+ :: forall h w . (All KnownDim '[h, w], All KnownNat '[h, w])+ => Normalize+ -> FilePath+ -> ExceptT String IO (Tensor '[3, h, w])+rgb2torch n f = rgb2list (Proxy @ '(h, w)) n f >>= cuboid++-- | Given a folder with subfolders of category images, return a uniform-randomly+-- shuffled list of absolute filepaths with the corresponding category.+shuffleCatFolders+ :: forall c+ . GenIO -- ^ generator for shuffle+ -> (FilePath -> Maybe c) -- ^ how to convert a subfolder into a category+ -> FilePath -- ^ absolute path of the dataset+ -> IO (Vector (c, FilePath)) -- ^ shuffled list+shuffleCatFolders g cast path = do+ cats <- filterM (doesDirectoryExist . (path </>)) =<< listDirectory path+ imgfiles <- sequence $ catContents <$> cats+ uniformShuffle (V.concat imgfiles) g+ where+ catContents :: FilePath -> IO (Vector (c, FilePath))+ catContents catFP =+ case cast catFP of+ Nothing -> pure mempty+ Just c ->+ let+ fdr = path </> catFP+ asPair img = (c, fdr </> img)+ in+ V.fromList . fmap asPair . filter isImage+ <$> listDirectory fdr++-- | verifies that an absolute filepath is an image+isImage :: FilePath -> Bool+isImage = (== ".png") . takeExtension+
+ src/Torch/Data/Loaders/Logging.hs view
@@ -0,0 +1,7 @@+module Torch.Data.Loaders.Logging where++mkLog level hdr msg = "["++level++"][" ++ hdr ++ "] " ++ msg+mkError = mkLog "ERROR"+mkInfo = mkLog "INFO"++
+ src/Torch/Data/Loaders/RGBVector.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+module Torch.Data.Loaders.RGBVector+ ( Normalize(..)+ , file2rgb+ , rgb2list+ , assertList+ ) where++import Data.Proxy+import Data.Vector (Vector)+import Control.Concurrent (threadDelay)+import Control.Monad -- (forM_, filterM)+import Control.Monad.Trans.Class+import Control.Monad.Trans.Except+import Control.Exception.Safe+-- import Control.DeepSeq+import GHC.Conc (getNumProcessors)+import GHC.TypeLits (KnownNat)+import Numeric.Dimensions+import System.Random.MWC (GenIO)+import System.Random.MWC.Distributions (uniformShuffle)+import System.Directory (listDirectory, doesDirectoryExist)+import System.FilePath ((</>), takeExtension)+import Control.Concurrent++import Control.Monad.Primitive+import qualified Data.Vector as V+import Data.Vector.Mutable (MVector)+import qualified Data.Vector.Mutable as M++#ifdef USE_GD+import qualified Graphics.GD as GD+#else+import qualified Codec.Picture as JP+#endif++import Torch.Data.Loaders.Logging++type HsReal = Double+type MRGBVector s = MVector s (MVector s (MVector s HsReal))+type RGBVector = Vector (Vector (Vector HsReal))++modulename = "Torch.Data.Loaders.RGBVector"++data Normalize+ = ZeroToOne+ | NegOneToOne+ | NoNormalize+ deriving (Eq, Ord, Show, Enum, Bounded)++-- | load an RGB PNG image into a Torch tensor+rgb2list+ :: forall h w . (All KnownDim '[h, w], All KnownNat '[h, w])+ => Proxy '(h, w)+ -> Normalize+ -> FilePath+ -> ExceptT String IO [[[HsReal]]]+rgb2list hwp donorm fp = do+ pxs <- file2rgb hwp fp+ -- lift $ assertPixels pxs+ ExceptT $ do+ vec <- mkRGBVec+ -- threadDelay 1000+ fillFrom pxs $ \chw px -> do+ let pxfin = prep px+ writePx vec chw pxfin++ lst <- freezeList vec+ -- assertList modulename (concat (concat lst))+ pure $ Right lst+ where+ prep w =+ case donorm of+ NoNormalize -> w+ ZeroToOne -> w / 255+ NegOneToOne -> (w / 255) * 2 - 1++ (height, width) = reifyHW hwp++ mkRGBVec :: PrimMonad m => m (MRGBVector (PrimState m))+ mkRGBVec = M.replicateM 3 (M.replicateM height (M.unsafeNew width))++ writePx+ :: PrimMonad m+ => MRGBVector (PrimState m)+ -> (Int, Int, Int)+ -> HsReal+ -> m ()+ writePx channels (c, h, w) px+ = M.unsafeRead channels c+ >>= \rows -> M.unsafeRead rows h+ >>= \cols -> M.unsafeWrite cols w px++ readPx+ :: PrimMonad m+ => MRGBVector (PrimState m)+ -> (Int, Int, Int)+ -> m HsReal+ readPx channels (c, h, w)+ = M.unsafeRead channels c+ >>= \rows -> M.unsafeRead rows h+ >>= \cols -> M.unsafeRead cols w++ freezeList+ :: PrimMonad m => MRGBVector (PrimState m) -> m [[[HsReal]]]+ freezeList mvecs = do+ readN mvecs 3 $ \mframe ->+ readN mframe height $ \mrow ->+ readN mrow width pure++++readNfreeze :: PrimMonad m => MVector (PrimState m) a -> Int -> (a -> m b) -> m (Vector b)+readNfreeze mvec n op =+ V.fromListN n <$> readN mvec n op++readN :: PrimMonad m => MVector (PrimState m) a -> Int -> (a -> m b) -> m [b]+readN mvec n op = mapM (M.read mvec >=> op) [0..n-1]++++fillFrom :: (Num y, PrimMonad m) => [((Int, Int), (Int, Int, Int))] -> ((Int, Int, Int) -> y -> m ()) -> m ()+fillFrom pxs filler =+ forM_ pxs $ \((h, w), (r, g, b)) ->+ forM_ (zip [0..] [r,g,b]) $ \(c, px) ->+ filler (c, h, w) (fromIntegral px)++file2rgb+ :: forall h w hw rgb+ . (All KnownDim '[h, w], All KnownNat '[h, w])+ => hw ~ (Int, Int)+ => rgb ~ (Int, Int, Int)+ => Proxy '(h, w)+ -> FilePath+ -> ExceptT String IO [(hw, rgb)]+file2rgb hwp fp = do+#ifdef USE_GD+ im <- lift $ GD.loadPngFile fp+ forM [(h, w) | h <- [0.. height - 1], w <- [0.. width - 1]] $ \(h, w) -> do+ (r,g,b,_) <- lift $ GD.toRGBA <$> GD.getPixel (h,w) im+#else+ im <- JP.convertRGB8 <$> ExceptT (JP.readPng fp)+ forM [(h, w) | h <- [0.. height - 1], w <- [0.. width - 1]] $ \(h, w) -> do+ let JP.PixelRGB8 r g b = JP.pixelAt im h w+#endif+ -- lift $ print (r, g, b)+ pure ((h, w), (fromIntegral r, fromIntegral g, fromIntegral b))+ where+ (height, width) = reifyHW hwp++assertPixels :: [((Int, Int), (Int, Int, Int))] -> IO ()+assertPixels pxs = do+ if all ((\(r, g, b) -> all (==0) [r, g, b]). snd) pxs+ then throwString $ mkError modulename "IMAGE ALL ZEROS!"+ else+ if all ((\(r, g, b) -> any (\x -> x < 0 || x > 255) [r, g, b]). snd) pxs+ then throwString $ mkError modulename "IMAGE OUT OF PIXEL BOUNDS!"+ else pure ()++assertList :: String -> [HsReal] -> IO ()+assertList hdr rs = do+ let+ oob = filter (\x -> x < -0.1 || x > 255.1) rs+ if not (null oob)+ then throwString $ show ({-oob,-} length oob, length rs, mkError hdr "OOB found!")+ else+ if all (== 0) rs+ then throwString $ mkError hdr "all-zeros found!"+ else pure ()+++reifyHW+ :: forall h w+ . (All KnownDim '[h, w], All KnownNat '[h, w])+ => Proxy '(h, w)+ -> (Int, Int)+reifyHW _ = (fromIntegral (dimVal (dim :: Dim h)), fromIntegral (dimVal (dim :: Dim w)))++
+ src/Torch/Data/Metrics.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Torch.Data.Metrics where++import Data.List (genericLength)+import Data.Function (on)+++#ifdef CUDA+import Torch.Cuda.Double+import qualified Torch.Cuda.Long as Long+#else+import Torch.Double+import qualified Torch.Long as Long+#endif+++catAccuracy+ :: forall c sz+ . (Eq c, Enum c) -- , sz ~ FromEnum (MaxBound c), KnownDim sz, KnownNat sz)+ => [(Int, c)] -- [(Tensor '[FromEnum (MaxBound c)], c)]+ -> Double+catAccuracy xs = filter issame xs // xs+ where+ (//) = (/) `on` genericLength+ issame (p, y) = toEnum p == y++
+ src/Torch/Data/OneHot.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Torch.Data.OneHot where++import qualified Data.Vector as V++#ifdef CUDA+import Torch.Cuda.Double+import qualified Torch.Cuda.Long as Long+#else+import Torch.Double+import qualified Torch.Long as Long+#endif++-- onehotL+-- :: forall c sz+-- . (Ord c, Bounded c, Enum c) -- , sz ~ FromEnum (MaxBound c), KnownDim sz, KnownNat sz)+-- => c+-- -> LongTensor '[10] -- '[FromEnum (MaxBound c)]+-- onehotL c+-- = Long.unsafeVector+-- $ onehot c++-- onehotT+-- :: forall c sz+-- . (Ord c, Bounded c, Enum c) -- , sz ~ FromEnum (MaxBound c), KnownDim sz, KnownNat sz)+-- => c+-- -> Tensor '[10] -- '[FromEnum (MaxBound c)]+-- onehotT c+-- = unsafeVector+-- $ fmap fromIntegral+-- $ onehot c++onehot+ :: forall i c+ . (Integral i, Ord c, Bounded c, Enum c)+ => c+ -> [i]+onehot c+ = V.toList+ $ V.generate+ (fromEnum (maxBound :: c) + 1)+ (fromIntegral . fromEnum . (== fromEnum c))++onehotf+ :: forall i c+ . (Fractional i, Ord c, Bounded c, Enum c)+ => c+ -> [i]+onehotf c+ = V.toList+ $ V.generate+ (fromEnum (maxBound :: c) + 1)+ (realToFrac . fromIntegral . fromEnum . (== fromEnum c))++
+ src/Torch/Initialization.hs view
@@ -0,0 +1,334 @@+-------------------------------------------------------------------------------+-- |+-- Module : Torch.Models.Internal+-- Copyright : (c) Sam Stites 2017+-- License : BSD3+-- Maintainer: sam@stites.io+-- Stability : experimental+-- Portability: non-portable+--+-- Helper functions which might end up migrating to the -indef codebase+-------------------------------------------------------------------------------+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE CPP #-}++#if MIN_VERSION_base(4,12,0)+{-# LANGUAGE NoStarIsType #-}+#endif++module Torch.Initialization+ ( newLinear+ , newConv2d+ , xavierUniformWith_+ , xavierUniform_+ , xavierNormalWith_+ , xavierNormal_++ , Activation(..)+ , FanMode(..)+ , kaimingUniformWith_+ , kaimingUniform_+ , kaimingNormalWith_+ , kaimingNormal_+ ) where++import Data.Maybe (fromMaybe)+import Data.Function ((&))+import GHC.Generics+import Prelude as P+import Data.Singletons.Prelude hiding (type (*), All)+import Data.Singletons.Prelude.List hiding (All)+import Numeric.Dimensions+import Control.Exception.Safe (throwString)++import Torch.Double+import qualified Torch.Double as Torch+import Torch.Double.NN.Linear (Linear(..))+import qualified Torch.Double.NN.Conv2d as NN+++-- Layer initialization: These depend on random functions which are not unified and, thus,+-- it's a little trickier to fold these back into their respective NN modules.++-- | initialize a new linear layer+newLinear :: forall o i . All KnownDim '[i,o] => Generator -> IO (Linear i o)+newLinear g = fmap Linear $ do+ let w = new+ kaimingUniformWith_ (LeakyReluFn (Just $ P.sqrt 5)) FanIn g w++ let+ fanin = calculateCorrectFan w FanIn+ bound = 1 / P.sqrt fanin+ bias = new+ Just pair = ord2Tuple (-bound, bound)+ _uniform bias g pair+ pure (w, bias)+++-- | initialize a new conv2d layer+newConv2d :: forall o i kH kW . All KnownDim '[i,o,kH,kW,kH*kW] => Generator -> IO (Conv2d i o '(kH,kW))+newConv2d g = fmap Conv2d $ do+ let w = new+ kaimingUniformWith_ (LeakyReluFn (Just $ P.sqrt 5)) FanIn g w++ let+ fanin = calculateCorrectFan w FanIn+ bound = 1 / P.sqrt fanin+ bias = new+ Just pair = ord2Tuple (-bound, bound)+ _uniform bias g pair+ pure (w, bias)+++data Activation+ -- linear functions+ = LinearFn -- ^ Linear activation+ | Conv1dFn -- ^ Conv1d activation+ | Conv2dFn -- ^ Conv2d activation+ | Conv3dFn -- ^ Conv3d activation+ | Conv1dTFn -- ^ Conv1d transpose activation+ | Conv2dTFn -- ^ Conv2d transpose activation+ | Conv3dTFn -- ^ Conv3d transpose activation++ -- non-linear+ | SigmoidFn+ | TanhFn+ | ReluFn+ | LeakyReluFn (Maybe Double)+ deriving (Eq, Show)++isLinear :: Activation -> Bool+isLinear = \case+ LinearFn -> True+ Conv1dFn -> True+ Conv2dFn -> True+ Conv3dFn -> True+ Conv1dTFn -> True+ Conv2dTFn -> True+ Conv3dTFn -> True+ otherwise -> False++++-- |+-- Return the recommended gain value for the given nonlinearity function.+-- The values are as follows:+-- ================= ====================================================+-- nonlinearity gain+-- ================= ====================================================+-- Linear / Identity :math:`1`+-- Conv{1,2,3}D :math:`1`+-- Sigmoid :math:`1`+-- Tanh :math:`\frac{5}{3}`+-- ReLU :math:`\sqrt{2}`+-- Leaky Relu :math:`\sqrt{\frac{2}{1 + \text{negative\_slope}^2}}`+-- ================= ====================================================+-- Args:+-- param: optional parameter for the non-linear function+-- Examples:+-- >>> gain = nn.init.calculate_gain('leaky_relu')+calculateGain+ :: Activation -- ^ the non-linear function (`nn.functional` name)+ -- param=None+ -> Double+calculateGain f+ | isLinear f = 1+ | otherwise =+ case f of+ SigmoidFn -> 1+ TanhFn -> 5 / 3+ ReluFn -> P.sqrt 2+ LeakyReluFn mslope -> P.sqrt $ 2 / (1 + fromMaybe 0.001 mslope ** 2)++fanInAndFanOut+ :: forall outs i o+ . (Dimensions outs, All KnownDim '[i, o, Product outs])+ => Tensor (i:+o:+outs)+ -> (Double, Double)+fanInAndFanOut = const (fan_in, fan_out)+ where+ fan_in = fromIntegral (dimVal (dim :: Dim o)) * rest+ fan_out = fromIntegral (dimVal (dim :: Dim i)) * rest+ rest = fromIntegral (dimVal (dim :: Dim (Product outs)))++-- |+-- Fills the input `Tensor` with values according to the method+-- described in "Understanding the difficulty of training deep feedforward+-- neural networks" - Glorot, X. & Bengio, Y. (2010), using a uniform+-- distribution. The resulting tensor will have values sampled from+-- :math:`\mathcal{U}(-a, a)` where+-- .. math::+-- a = \text{gain} \times \sqrt{\frac{6}{\text{fan\_in} + \text{fan\_out}}}+-- Also known as Glorot initialization.+-- Examples:+-- -set -XScopedTypeVariables+-- w :: Tensor '[3, 5] <- torch.new+-- xavierUniformWith_ w (calculate_gain Relu)+xavierUniformWith_+ :: (Dimensions outs, All KnownDim '[i, o, Product outs])+ => HsReal -- ^ gain: an optional scaling factor+ -> Generator+ -> Tensor (i:+o:+outs) -- ^ tensor: an n-dimensional `torch.Tensor` (minimum length 2)+ -> IO ()+xavierUniformWith_ = xavierDistributedWith_ $ \g pstd t -> do+ let std = positiveValue pstd+ a = P.sqrt 3 * std -- Calculate uniform bounds from standard deviation+ Just pair = ord2Tuple (-a, a)+ _uniform t g pair++-- | xavierUniformWith_ with default of gain = 1+xavierUniform_+ :: (Dimensions outs, All KnownDim '[i, o, Product outs])+ => Generator+ -> Tensor (i:+o:+outs) -- ^ tensor: an n-dimensional `torch.Tensor` (minimum length 2)+ -> IO ()+xavierUniform_ = xavierUniformWith_ 1++xavierNormalWith_+ :: (Dimensions outs, All KnownDim '[i, o, Product outs])+ => HsReal -- ^ gain: an optional scaling factor+ -> Generator+ -> Tensor (i:+o:+outs) -- ^ tensor: an n-dimensional `torch.Tensor` (minimum length 2)+ -> IO ()+xavierNormalWith_ = xavierDistributedWith_ $ \g std t -> _normal t g 0 std++-- | 'xavierNormalWith_' with default of gain = 1+xavierNormal_+ :: (Dimensions outs, All KnownDim '[i, o, Product outs])+ => Generator+ -> Tensor (i:+o:+outs) -- ^ tensor: an n-dimensional `torch.Tensor` (minimum length 2)+ -> IO ()+xavierNormal_ = xavierNormalWith_ 1+++xavierDistributedWith_+ :: (Dimensions outs, All KnownDim '[i, o, Product outs])+ => (Generator -> Positive HsReal -> Tensor (i:+o:+outs) -> IO ())+ -> HsReal -- ^ gain: an optional scaling factor+ -> Generator+ -> Tensor (i:+o:+outs) -- ^ tensor: an n-dimensional `torch.Tensor` (minimum length 2)+ -> IO ()+xavierDistributedWith_ distribution gain g tensor = do+ let+ (fan_in, fan_out) = fanInAndFanOut tensor+ mstd = gain * P.sqrt(2 / (fan_in + fan_out))+ case positive mstd of+ Just std -> distribution g std tensor+ Nothing -> throwString $+ "standard deviation is not positive. Found: " ++ show mstd ++ ", most likely the gain is negative, which is incorrect: " ++ show gain++++data FanMode = FanIn | FanOut+ deriving (Eq, Ord, Show)+++calculateCorrectFan+ :: (Dimensions outs, All KnownDim '[i, o, Product outs])+ => Tensor (i:+o:+outs) -> FanMode -> Double+calculateCorrectFan t = \case+ FanIn -> fan_in+ FanOut -> fan_out+ where+ (fan_in, fan_out) = fanInAndFanOut t+++-- |+-- Fills the input `Tensor` with values according to the method+-- described in "Delving deep into rectifiers: Surpassing human-level+-- performance on ImageNet classification" - He, K. et al. (2015), using a+-- uniform distribution. The resulting tensor will have values sampled from+-- :math:`\mathcal{U}(-\text{bound}, \text{bound})` where+-- .. math::+-- \text{bound} = \sqrt{\frac{6}{(1 + a^2) \times \text{fan\_in}}}+-- Also known as He initialization.+-- Args:+-- tensor: an n-dimensional `torch.Tensor`+-- a: the negative slope of the rectifier used after this layer (0 for ReLU+-- by default)+-- mode: either 'fan_in' (default) or 'fan_out'. Choosing `fan_in`+-- preserves the magnitude of the variance of the weights in the+-- forward pass. Choosing `fan_out` preserves the magnitudes in the+-- backwards pass.+-- nonlinearity: the non-linear function (`nn.functional` name),+-- recommended to use only with 'relu' or 'leaky_relu' (default).+-- Examples:+-- >>> w = torch.empty(3, 5)+-- >>> nn.init.kaiming_uniform_(w, mode='fan_in', nonlinearity='relu')+kaimingUniformWith_+ :: (Dimensions outs, All KnownDim '[i, o, Product outs])+ => Activation+ -> FanMode+ -> Generator+ -> Tensor (i:+o:+outs) -- ^ tensor: an n-dimensional `torch.Tensor` (minimum length 2)+ -> IO ()+kaimingUniformWith_ = kaimingDisributedWith_ $ \g pstd t -> do+ let a = P.sqrt 3 * (positiveValue pstd) -- Calculate uniform bounds from standard deviation+ Just pair = ord2Tuple (-a, a)+ _uniform t g pair++kaimingUniform_+ :: (Dimensions outs, All KnownDim '[i, o, Product outs])+ => Generator+ -> Tensor (i:+o:+outs) -- ^ tensor: an n-dimensional `torch.Tensor` (minimum length 2)+ -> IO ()+kaimingUniform_ = kaimingUniformWith_ (LeakyReluFn (Just 0)) FanIn++-- |+-- Fills the input `Tensor` with values according to the method+-- described in "Delving deep into rectifiers: Surpassing human-level+-- performance on ImageNet classification" - He, K. et al. (2015), using a+-- normal distribution. The resulting tensor will have values sampled from+-- :math:`\mathcal{N}(0, \text{std})` where+-- .. math::+-- \text{std} = \sqrt{\frac{2}{(1 + a^2) \times \text{fan\_in}}}+-- Also known as He initialization.+-- Args:+-- tensor: an n-dimensional `torch.Tensor`+-- a: the negative slope of the rectifier used after this layer (0 for ReLU+-- by default)+-- mode: either 'fan_in' (default) or 'fan_out'. Choosing `fan_in`+-- preserves the magnitude of the variance of the weights in the+-- forward pass. Choosing `fan_out` preserves the magnitudes in the+-- backwards pass.+-- nonlinearity: the non-linear function (`nn.functional` name),+-- recommended to use only with 'relu' or 'leaky_relu' (default).+-- Examples:+-- >>> w = torch.empty(3, 5)+-- >>> nn.init.kaiming_normal_(w, mode='fan_out', nonlinearity='relu')+kaimingNormalWith_+ :: (Dimensions outs, All KnownDim '[i, o, Product outs])+ => Activation+ -> FanMode+ -> Generator+ -> Tensor (i:+o:+outs) -- ^ tensor: an n-dimensional `torch.Tensor` (minimum length 2)+ -> IO ()+kaimingNormalWith_ = kaimingDisributedWith_ $ \g std t -> _normal t g 0 std++kaimingNormal_+ :: (Dimensions outs, All KnownDim '[i, o, Product outs])+ => Generator+ -> Tensor (i:+o:+outs) -- ^ tensor: an n-dimensional `torch.Tensor` (minimum length 2)+ -> IO ()+kaimingNormal_ = kaimingNormalWith_ (LeakyReluFn (Just 0)) FanIn+++kaimingDisributedWith_+ :: (Dimensions outs, All KnownDim '[i, o, Product outs])+ => (Generator -> Positive HsReal -> Tensor (i:+o:+outs) -> IO ()) -- ^ randomizing fill which takes a standard of deviation+ -> Activation+ -> FanMode+ -> Generator+ -> Tensor (i:+o:+outs) -- ^ tensor: an n-dimensional `torch.Tensor` (minimum length 2)+ -> IO ()+kaimingDisributedWith_ distribution activation mode g t =+ case positive std of+ Just std -> distribution g std t+ Nothing -> throwString $+ "standard deviation is not positive. Found: " ++ show std ++ ", most likely the gain is negative, which is incorrect: " ++ show gain+ where+ fan = calculateCorrectFan t mode+ gain = calculateGain activation+ std = gain / P.sqrt fan+
+ src/Torch/Models/Vision/LeNet.hs view
@@ -0,0 +1,358 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}++#if MIN_VERSION_base(4,12,0)+{-# LANGUAGE NoStarIsType #-}+#endif++{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-}+module Torch.Models.Vision.LeNet where++import Data.Function ((&))+import Data.Generics.Product.Fields (field)+import Data.Generics.Product.Typed (typed)+import Data.List (intercalate)+import Data.Singletons.Prelude (SBool, sing)+import GHC.Generics (Generic)+import Lens.Micro (Lens', (^.))+import Numeric.Backprop (Backprop, BVar, Reifies, W, (^^.))+import GHC.TypeLits (KnownNat)+import qualified Numeric.Backprop as Bp+import qualified GHC.TypeLits++#ifdef CUDA+import Numeric.Dimensions+import Torch.Cuda.Double as Torch+import Torch.Cuda.Double.NN.Linear -- (Linear(..), linear)+import qualified Torch.Cuda.Double.NN.Conv2d as Conv2d+import qualified Torch.Cuda.Double.NN.Linear as Linear+#else+import Torch.Double as Torch+import Torch.Double.NN.Linear -- (Linear(..), linear)+import qualified Torch.Double.NN.Conv2d as Conv2d+import qualified Torch.Double.NN.Linear as Linear+#endif++import Torch.Initialization++type Flattened ker = (16*ker*ker)+data LeNet ch ker = LeNet+ { _conv1 :: !(Conv2d ch 6 '(ker, ker))+ , _conv2 :: !(Conv2d 6 16 '(ker,ker))++ , _fc1 :: !(Linear (Flattened ker) 120)+ , _fc2 :: !(Linear 120 84)+ , _fc3 :: !(Linear 84 10)+ } deriving (Generic)++conv1 :: Lens' (LeNet ch ker) (Conv2d ch 6 '(ker, ker))+conv1 = field @"_conv1"++conv2 :: Lens' (LeNet ch ker) (Conv2d 6 16 '(ker,ker))+conv2 = field @"_conv2"++fc1 :: forall ch ker . Lens' (LeNet ch ker) (Linear (Flattened ker) 120)+fc1 = typed @(Linear (Flattened ker) 120)++fc2 :: Lens' (LeNet ch ker) (Linear 120 84)+fc2 = field @"_fc2"++fc3 :: Lens' (LeNet ch ker) (Linear 84 10)+fc3 = field @"_fc3"++instance (KnownDim (Flattened ker), KnownDim ch, KnownDim ker) => Show (LeNet ch ker) where+ show (LeNet c1 c2 f1 f2 f3) = intercalate "\n"+#ifdef CUDA+ [ "CudaLeNet {"+#else+ [ "LeNet {"+#endif+ , " conv1 :: " ++ show c1+ , " conv2 :: " ++ show c2+ , " fc1 :: " ++ show f1+ , " fc2 :: " ++ show f2+ , " fc3 :: " ++ show f3+ , "}"+ ]++instance (KnownDim (Flattened ker), KnownDim ch, KnownDim ker) => Backprop (LeNet ch ker) where+ add a b = LeNet+ (Bp.add (_conv1 a) (_conv1 b))+ (Bp.add (_conv2 a) (_conv2 b))+ (Bp.add (_fc1 a) (_fc1 b))+ (Bp.add (_fc2 a) (_fc2 b))+ (Bp.add (_fc3 a) (_fc3 b))++ one net = LeNet+ (Bp.one (net^.conv1))+ (Bp.one (net^.conv2))+ (Bp.one (net^.fc1) )+ (Bp.one (net^.fc2) )+ (Bp.one (net^.fc3) )++ zero net = LeNet+ (Bp.zero (net^.conv1))+ (Bp.zero (net^.conv2))+ (Bp.zero (net^.fc1) )+ (Bp.zero (net^.fc2) )+ (Bp.zero (net^.fc3) )+++++-------------------------------------------------------------------------------++newLeNet :: All KnownDim '[ch,ker,Flattened ker, ker*ker] => Generator -> IO (LeNet ch ker)+newLeNet g = LeNet+ <$> newConv2d g+ <*> newConv2d g+ <*> newLinear g+ <*> newLinear g+ <*> newLinear g++-- | update a LeNet network+update net lr grad = LeNet+ (Conv2d.update (net^.conv1) lr (grad^.conv1))+ (Conv2d.update (net^.conv2) lr (grad^.conv2))+ (Linear.update (net^.fc1) lr (grad^.fc1))+ (Linear.update (net^.fc2) lr (grad^.fc2))+ (Linear.update (net^.fc3) lr (grad^.fc3))++-- | update a LeNet network inplace+update_ net lr grad = do+ (Conv2d.update_ (net^.conv1) lr (grad^.conv1))+ (Conv2d.update_ (net^.conv2) lr (grad^.conv2))+ (Linear.update_ (net^.fc1) lr (grad^.fc1))+ (Linear.update_ (net^.fc2) lr (grad^.fc2))+ (Linear.update_ (net^.fc3) lr (grad^.fc3))+++-- lenet+-- :: forall s ch h w o step pad -- ker moh mow+-- . Reifies s W+-- => All KnownNat '[ch,h,w,o,step]+-- => All KnownDim '[ch,h,w,o,ch*step*step] -- , (16*step*step)]+-- => o ~ 10+-- => h ~ 32+-- => w ~ 32+-- => pad ~ 0+-- -- => SpatialConvolutionC ch h w ker ker step step pad pad (16*step*step) mow+-- -- => SpatialConvolutionC ch moh mow ker ker step step pad pad moh mow+--+-- => Double+--+-- -> BVar s (LeNet ch step) -- ^ lenet architecture+-- -> BVar s (Tensor '[ch,h,w]) -- ^ input+-- -> BVar s (Tensor '[o]) -- ^ output+lenet lr arch inp+ = lenetLayer lr (arch ^^. conv1) inp+ & lenetLayer lr (arch ^^. conv2)++ & flattenBP++ -- start fully connected network+ & relu . linear (arch ^^. fc1)+ & relu . linear (arch ^^. fc2)+ & linear (arch ^^. fc3)+ -- & logSoftMax+ & softmax++-- Optionally, we can remove the explicit type and everything would be fine.+-- Including it is quite a bit of work and requires pulling in the correct+-- constraints+lenetLayer+ :: forall inp h w ker ow oh s out mow moh step pad++ -- backprop constraint to hold the wengert tape+ . Reifies s W++ -- leave input, output and square kernel size variable so that we+ -- can reuse the layer...+ => All KnownDim '[inp,out,ker,(ker*ker)*inp]++ -- FIXME: derive these from the signature (maybe assign them as args)+ => pad ~ 0 -- default padding size+ => step ~ 1 -- default step size for Conv2d++ -- ...this means we need the constraints for conv2d and maxPooling2d+ -- Note that oh and ow are then used as input to the maxPooling2d constraint.+ => SpatialConvolutionC inp h w ker ker step step pad pad oh ow+ => SpatialDilationC oh ow 2 2 2 2 pad pad mow moh 1 1 'True++ -- Start withe parameters+ => Double -- ^ learning rate for convolution layer+ -> BVar s (Conv2d inp out '(ker,ker)) -- ^ convolutional layer+ -> BVar s (Tensor '[inp, h, w]) -- ^ input+ -> BVar s (Tensor '[out, moh, mow]) -- ^ output+lenetLayer lr conv inp+ = Conv2d.conv2d+ (Step2d :: Step2d '(1,1))+ (Padding2d :: Padding2d '(0,0))+ lr conv inp+ & relu+ & maxPooling2d+ (Kernel2d :: Kernel2d '(2,2))+ (Step2d :: Step2d '(2,2))+ (Padding2d :: Padding2d '(0,0))+ (sing :: SBool 'True)++{- Here is what each layer's intermediate type would like (unused)+lenetLayer1+ :: Reifies s W+ => Double -- ^ learning rate+ -> BVar s (Conv2d 1 6 '(5,5) ) -- ^ convolutional layer+ -> BVar s (Tensor '[1, 32, 32]) -- ^ input+ -> BVar s (Tensor '[6, 14, 14]) -- ^ output+lenetLayer1 = lenetLayer++lenetLayer2+ :: Reifies s W+ => Double -- ^ learning rate+ -> BVar s (Conv2d 6 16 '(5,5) ) -- ^ convolutional layer+ -> BVar s (Tensor '[ 6, 14, 14]) -- ^ input+ -> BVar s (Tensor '[16, 5, 5]) -- ^ output+lenetLayer2 = lenetLayer+-}++lenetBatch lr arch inp+ = lenetLayerBatch lr (arch ^^. conv1) inp+ & lenetLayerBatch lr (arch ^^. conv2)++ & flattenBPBatch++ -- start fully connected network+ & relu . linearBatch (arch ^^. fc1)+ & relu . linearBatch (arch ^^. fc2)+ & linearBatch (arch ^^. fc3)+ -- & logSoftMax+ & softmaxN (dim :: Dim 1)+++lenetLayerBatch+ :: forall inp h w ker ow oh s out mow moh step pad batch++ -- backprop constraint to hold the wengert tape+ . Reifies s W++ -- leave input, output and square kernel size variable so that we+ -- can reuse the layer...+ => All KnownDim '[batch,inp,out,ker,(ker*ker)*inp]++ -- FIXME: derive these from the signature (maybe assign them as args)+ => pad ~ 0 -- default padding size+ => step ~ 1 -- default step size for Conv2d++ -- ...this means we need the constraints for conv2d and maxPooling2d+ -- Note that oh and ow are then used as input to the maxPooling2d constraint.+ => SpatialConvolutionC inp h w ker ker step step pad pad oh ow+ => SpatialDilationC oh ow 2 2 2 2 pad pad mow moh 1 1 'True++ -- Start withe parameters+ => Double -- ^ learning rate for convolution layer+ -> BVar s (Conv2d inp out '(ker,ker)) -- ^ convolutional layer+ -> BVar s (Tensor '[batch, inp, h, w]) -- ^ input+ -> BVar s (Tensor '[batch, out, moh, mow]) -- ^ output+lenetLayerBatch lr conv inp+ = Conv2d.conv2dBatch+ (Step2d :: Step2d '(1,1))+ (Padding2d :: Padding2d '(0,0))+ lr conv inp+ & relu+ & maxPooling2dBatch+ (Kernel2d :: Kernel2d '(2,2))+ (Step2d :: Step2d '(2,2))+ (Padding2d :: Padding2d '(0,0))+ (sing :: SBool 'True)+++-- -- lenet+-- -- :: forall s ch h w o step pad -- ker moh mow+-- -- . Reifies s W+-- -- => All KnownNat '[ch,h,w,o,step]+-- -- => All KnownDim '[ch,h,w,o,ch*step*step] -- , (16*step*step)]+-- -- => o ~ 10+-- -- => h ~ 32+-- -- => w ~ 32+-- -- => pad ~ 0+-- -- -- => SpatialConvolutionC ch h w ker ker step step pad pad (16*step*step) mow+-- -- -- => SpatialConvolutionC ch moh mow ker ker step step pad pad moh mow+-- --+-- -- => Double+-- --+-- -- -> BVar s (LeNet ch step) -- ^ lenet architecture+-- -- -> BVar s (Tensor '[ch,h,w]) -- ^ input+-- -- -> BVar s (Tensor '[o]) -- ^ output+-- lenet lr arch inp+-- = lenetLayer lr (arch ^^. conv1) inp+-- & lenetLayer lr (arch ^^. conv2)+--+-- & flattenBP+--+-- -- start fully connected network+-- & relu . linear lr (arch ^^. fc1)+-- & relu . linear lr (arch ^^. fc2)+-- & linear lr (arch ^^. fc3)+-- -- & logSoftMax+-- & softmax++-- lenetBatch lr arch inp+-- = lenetLayerBatch lr (arch ^^. conv1) inp+-- & lenetLayerBatch lr (arch ^^. conv2)+--+-- & flattenBPBatch+--+-- -- start fully connected network+-- & relu . linearBatch lr (arch ^^. fc1)+-- & relu . linearBatch lr (arch ^^. fc2)+-- & linearBatch lr (arch ^^. fc3)+-- -- & logSoftMax+-- & softmaxN (dim :: Dim 1)+++-- -- FIXME: Move this to ST+-- lenetLayerBatch_+-- :: forall inp h w ker ow oh s out mow moh step pad batch+--+-- -- backprop constraint to hold the wengert tape+-- . Reifies s W+--+-- -- leave input, output and square kernel size variable so that we+-- -- can reuse the layer...+-- => All KnownDim '[batch,inp,out,ker]+--+-- -- FIXME: derive these from the signature (maybe assign them as args)+-- => pad ~ 0 -- default padding size+-- => step ~ 1 -- default step size for Conv2d+--+-- -- ...this means we need the constraints for conv2d and maxPooling2d+-- -- Note that oh and ow are then used as input to the maxPooling2d constraint.+-- => SpatialConvolutionC inp h w ker ker step step pad pad oh ow+-- => SpatialDilationC oh ow 2 2 2 2 pad pad mow moh 1 1 'True+--+-- -- Start withe parameters+-- => Tensor '[batch, out, moh, mow] -- ^ output to mutate+-- -> Double -- ^ learning rate for convolution layer+-- -> Conv2d inp out '(ker,ker) -- ^ convolutional layer+-- -> Tensor '[batch, inp, h, w] -- ^ input+-- -> IO () -- ^ output+-- lenetLayerBatch_ lr conv inp = do+-- Conv2d.conv2dBatch+-- (Step2d :: Step2d '(1,1))+-- (Padding2d :: Padding2d '(0,0))+-- lr conv inp+-- & relu+-- & maxPooling2dBatch+-- (Kernel2d :: Kernel2d '(2,2))+-- (Step2d :: Step2d '(2,2))+-- (Padding2d :: Padding2d '(0,0))+-- (sing :: SBool 'True)+--+--+