diff --git a/hasktorch-zoo.cabal b/hasktorch-zoo.cabal new file mode 100644 --- /dev/null +++ b/hasktorch-zoo.cabal @@ -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 , Austin Huang - 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 + diff --git a/src/Torch/Data/Loaders/Cifar10.hs b/src/Torch/Data/Loaders/Cifar10.hs new file mode 100644 --- /dev/null +++ b/src/Torch/Data/Loaders/Cifar10.hs @@ -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]) + + diff --git a/src/Torch/Data/Loaders/Internal.hs b/src/Torch/Data/Loaders/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Torch/Data/Loaders/Internal.hs @@ -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 + diff --git a/src/Torch/Data/Loaders/Logging.hs b/src/Torch/Data/Loaders/Logging.hs new file mode 100644 --- /dev/null +++ b/src/Torch/Data/Loaders/Logging.hs @@ -0,0 +1,7 @@ +module Torch.Data.Loaders.Logging where + +mkLog level hdr msg = "["++level++"][" ++ hdr ++ "] " ++ msg +mkError = mkLog "ERROR" +mkInfo = mkLog "INFO" + + diff --git a/src/Torch/Data/Loaders/RGBVector.hs b/src/Torch/Data/Loaders/RGBVector.hs new file mode 100644 --- /dev/null +++ b/src/Torch/Data/Loaders/RGBVector.hs @@ -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))) + + diff --git a/src/Torch/Data/Metrics.hs b/src/Torch/Data/Metrics.hs new file mode 100644 --- /dev/null +++ b/src/Torch/Data/Metrics.hs @@ -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 + + diff --git a/src/Torch/Data/OneHot.hs b/src/Torch/Data/OneHot.hs new file mode 100644 --- /dev/null +++ b/src/Torch/Data/OneHot.hs @@ -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)) + + diff --git a/src/Torch/Initialization.hs b/src/Torch/Initialization.hs new file mode 100644 --- /dev/null +++ b/src/Torch/Initialization.hs @@ -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 + diff --git a/src/Torch/Models/Vision/LeNet.hs b/src/Torch/Models/Vision/LeNet.hs new file mode 100644 --- /dev/null +++ b/src/Torch/Models/Vision/LeNet.hs @@ -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) +-- +-- +