├── .gitignore ├── Setup.hs ├── README.md ├── Main.hs ├── DeepLearning ├── Util.hs ├── ConvNetTest.hs └── ConvNet.hs ├── LICENSE └── deeplearning-hs.cabal /.gitignore: -------------------------------------------------------------------------------- 1 | .cabal-sandbox 2 | dist 3 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main :: IO () 4 | main = defaultMain 5 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # DeepLearning.hs # 2 | 3 | A type-safe, efficient deep learning library for Haskell. Using Repa 4 | for efficient array-based computation, exploring running computations 5 | on the GPU with `accelerate-cuda`. -------------------------------------------------------------------------------- /Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | module Main where 3 | 4 | import Data.Array.Repa 5 | import DeepLearning.ConvNet 6 | import DeepLearning.Util 7 | 8 | -- |Main 9 | main :: IO () 10 | main = do 11 | (pvol, acts) <- withActivations (testNet testShape 2) (testInput testShape) 12 | print (computeS pvol :: Vol DIM1) 13 | print acts 14 | -------------------------------------------------------------------------------- /DeepLearning/Util.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | 3 | {-| 4 | Module : DeepLearning.Util 5 | Description : Deep Learning 6 | Copyright : (c) Andrew Tulloch, 2014 7 | License : GPL-3 8 | Maintainer : andrew+cabal@tullo.ch 9 | Stability : experimental 10 | Portability : POSIX 11 | -} 12 | module DeepLearning.Util where 13 | 14 | import Data.Array.Repa 15 | import Data.Array.Repa.Algorithms.Randomish 16 | import DeepLearning.ConvNet 17 | import Prelude as P 18 | 19 | -- |Sample 3x3 matrix used for demonstrations and tests 20 | testShape :: (Z :. Int) 21 | testShape = Z :. (3 :: Int) 22 | 23 | -- |Random 3x3 matrix 24 | testInput :: Shape sh => sh -> Array U sh Double 25 | testInput sh = randomishDoubleArray sh 0 1.0 1 26 | 27 | -- |Random single-layer network 28 | testNet :: (Monad m) => DIM1 -> Int -> Forward m 29 | testNet sh numFilters = net1 testFC testSM 30 | where 31 | testFC = newFC sh numFilters 32 | testSM = SoftMaxLayer 33 | -------------------------------------------------------------------------------- /DeepLearning/ConvNetTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | module Main where 3 | 4 | import Data.Array.Repa 5 | import Data.Array.Repa.Arbitrary 6 | import Data.Monoid 7 | import qualified Data.Vector.Unboxed as V 8 | import DeepLearning.ConvNet 9 | import DeepLearning.Util 10 | import Test.Framework 11 | import Test.Framework.Providers.QuickCheck2 12 | import Test.QuickCheck 13 | 14 | genOneLayer :: DIM1 -> Gen (Int, Vol DIM1) 15 | genOneLayer sh = do 16 | a <- choose (1, 10) 17 | b <- arbitraryUShaped sh 18 | return (a, b) 19 | 20 | testFilter :: (Int, Vol DIM1) -> Bool 21 | testFilter (numFilters, input) = and invariants 22 | where 23 | [(outAP, [innerA])] = withActivations (testNet sh numFilters) (testInput sh) 24 | outA = computeS outAP :: Vol DIM1 25 | sh = extent input 26 | invariants = [ 27 | (length . toList) outA == numFilters, 28 | V.length innerA == numFilters] 29 | 30 | prop_singleLayer :: Property 31 | prop_singleLayer = forAll (genOneLayer testShape) testFilter 32 | 33 | tests :: [Test] 34 | tests = [testProperty "singleLayer" prop_singleLayer] 35 | 36 | main :: IO () 37 | main = defaultMainWithOpts tests mempty 38 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License 2 | 3 | Author:: Andrew Tulloch 4 | Copyright:: Copyright (c) 2014, Andrew Tulloch 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining 7 | a copy of this software and associated documentation files (the 8 | "Software"), to deal in the Software without restriction, including 9 | without limitation the rights to use, copy, modify, merge, publish, 10 | distribute, sublicense, and/or sell copies of the Software, and to 11 | permit persons to whom the Software is furnished to do so, subject to 12 | the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be 15 | included in all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 19 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 21 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 22 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 23 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 24 | 25 | Except as contained in this notice, the name(s) of the above copyright 26 | holders shall not be used in advertising or otherwise to promote the 27 | sale, use or other dealings in this Software without prior written 28 | authorization. 29 | -------------------------------------------------------------------------------- /deeplearning-hs.cabal: -------------------------------------------------------------------------------- 1 | -- Initial deeplearning.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | 5 | name: deeplearning-hs 6 | version: 0.1.0.2 7 | description: Implements type-safe deep neural networks 8 | synopsis: Deep Learning in Haskell 9 | homepage: https://github.com/ajtulloch/deeplearning-hs 10 | license: MIT 11 | license-file: LICENSE 12 | author: Andrew Tulloch 13 | maintainer: Andrew Tulloch 14 | category: Math 15 | build-type: Simple 16 | cabal-version: >=1.10 17 | bug-reports: https://github.com/ajtulloch/deeplearning-hs/issues 18 | source-repository head 19 | type: git 20 | location: https://github.com/ajtulloch/deeplearning-hs.git 21 | 22 | Library 23 | exposed-modules: DeepLearning.ConvNet, DeepLearning.Util 24 | default-language: Haskell2010 25 | GHC-Options: -Wall 26 | build-depends: 27 | base >=4.6 && <4.7, 28 | accelerate, 29 | vector, 30 | repa, 31 | repa-algorithms, 32 | mtl 33 | 34 | Test-suite deeplearning_test 35 | Main-Is: DeepLearning/ConvNetTest.hs 36 | Type: exitcode-stdio-1.0 37 | x-uses-tf: true 38 | default-language: Haskell2010 39 | build-depends: 40 | deeplearning-hs, 41 | base >=4.6 && <4.7, 42 | accelerate, 43 | vector, 44 | repa, 45 | repa-algorithms, 46 | mtl, 47 | QuickCheck, 48 | test-framework-quickcheck2, 49 | test-framework 50 | Ghc-Options: -Wall 51 | 52 | executable deeplearning_demonstration 53 | main-is: Main.hs 54 | default-language: Haskell2010 55 | GHC-Options: -Wall 56 | build-depends: 57 | deeplearning-hs, 58 | base >=4.6 && <4.7, 59 | accelerate, 60 | vector, 61 | repa, 62 | repa-algorithms, 63 | mtl 64 | -------------------------------------------------------------------------------- /DeepLearning/ConvNet.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | 7 | {-| 8 | Module : DeepLearning.ConvNet 9 | Description : Deep Learning 10 | Copyright : (c) Andrew Tulloch, 2014 11 | License : GPL-3 12 | Maintainer : andrew+cabal@tullo.ch 13 | Stability : experimental 14 | Portability : POSIX 15 | -} 16 | module DeepLearning.ConvNet 17 | -- ( 18 | -- -- ** Main Types 19 | -- Vol, 20 | -- DVol, 21 | -- Label, 22 | -- -- ** Layers 23 | -- -- Layer, 24 | -- -- InnerLayer, 25 | -- -- TopLayer, 26 | -- -- SoftMaxLayer(..), 27 | -- -- FullyConnectedLayer(..), 28 | -- -- forward, 29 | -- -- ** Composing layers 30 | -- -- (>->), 31 | -- -- Forward, 32 | -- -- withActivations, 33 | 34 | -- -- ** Network building helpers 35 | -- -- flowNetwork, 36 | -- -- net1, 37 | -- -- net2, 38 | -- -- newFC, 39 | -- ) 40 | where 41 | 42 | import Data.Array.Repa hiding (toList) 43 | import qualified Data.Array.Repa as R 44 | import qualified Data.List as L 45 | import Prelude hiding (map, zipWith) 46 | import qualified Prelude as P 47 | 48 | data SGD = Vanilla { _learningRate :: Double } 49 | data Network a = Network { _innerLayers :: [a], _topLayer :: a } 50 | data Example = Example { _input :: DVol DIM1, _label :: Label } 51 | 52 | type DVol sh = Array D sh Double 53 | 54 | data Activations = Activations { 55 | _inputAct :: DVol DIM1, 56 | _outputAct :: DVol DIM1 57 | } 58 | 59 | data Gradients = Gradients { _layerGrads :: [(Layer, [DVol DIM1])]} 60 | data BackProp = BackProp { _paramGrad :: [DVol DIM1], _inputGrad :: DVol DIM1 } 61 | data InputProp = InputProp { 62 | _outputGrad :: DVol DIM1, 63 | _activations :: Activations 64 | } 65 | 66 | -- |Label for supervised learning 67 | type Label = Int 68 | 69 | -- |'Layer' reprsents a layer that can pass activations forward and backward 70 | data Layer = Layer { 71 | _forward :: DVol DIM1 -> DVol DIM1, 72 | _topBackward :: Label -> Activations -> BackProp, 73 | _innerBackward :: InputProp -> BackProp, 74 | _applyGradient :: SGD -> [BackProp] -> Layer 75 | } 76 | 77 | -- |'SoftMaxLayer' computes the softmax activation function. 78 | softMaxLayer :: Layer 79 | softMaxLayer = Layer { 80 | _forward = softMaxForward, 81 | _topBackward = softMaxBackward, 82 | _innerBackward = error "Should not be called on SoftMaxLayer", 83 | _applyGradient = \_ _ -> softMaxLayer 84 | } 85 | 86 | softMaxForward :: (Shape sh) => DVol sh -> DVol sh 87 | softMaxForward input = w where 88 | exponentials = exponentiate input 89 | sumE = foldAllS (+) 0.0 exponentials 90 | w = map (/ sumE) exponentials 91 | maxA = foldAllS max 0.0 92 | exponentiate acts = map (\a -> exp (a - maxAct)) acts 93 | where 94 | maxAct = maxA acts 95 | 96 | softMaxBackward :: Label -> Activations -> BackProp 97 | softMaxBackward label Activations{..} = BackProp undefined (R.traverse _outputAct id gradientAt) 98 | where 99 | gradientAt f s@(Z :. i) = gradient (f s) i 100 | gradient outA target = -(bool2Double indicator - outA) 101 | where 102 | indicator = label == target 103 | bool2Double x = if x then 1.0 else 0.0 104 | 105 | -- |'FullyConnectedLayer' represents a fully-connected input layer 106 | data FullyConnectedState = FullyConnectedState { 107 | _bias :: [Double], 108 | _weights :: [DVol DIM1] 109 | } 110 | 111 | fcLayer :: FullyConnectedState -> Layer 112 | fcLayer fcState = Layer { 113 | _forward = fcForward fcState, 114 | _innerBackward = fcBackward fcState, 115 | _topBackward = error "Should not be called", 116 | _applyGradient = fcApplyGradient fcState 117 | } 118 | 119 | fcApplyGradient :: FullyConnectedState -> SGD -> [BackProp] -> Layer 120 | fcApplyGradient fcState sgd (biasG:weightsG) = fcLayer newState 121 | where 122 | newState = undefined 123 | 124 | fcForward :: FullyConnectedState -> DVol DIM1 -> DVol DIM1 125 | fcForward FullyConnectedState{..} input = delay $ fromListUnboxed (Z :. numFilters) outputs 126 | where 127 | numFilters = length _bias 128 | output :: Double -> DVol DIM1 -> Double 129 | output b w = b + dotProduct input w 130 | outputs = P.zipWith output _bias _weights 131 | dotProduct a b = sumAllS $ zipWith (+) a b 132 | 133 | fcBackward :: FullyConnectedState -> InputProp -> BackProp 134 | fcBackward = undefined 135 | 136 | applyForward :: Network t -> a -> (a -> t -> a) -> Network (t, a) 137 | applyForward Network{..} input f = Network newInner newTop 138 | where 139 | innerActs = tail $ scanl f input _innerLayers 140 | newInner = zip _innerLayers innerActs 141 | topAct = f (last innerActs) _topLayer 142 | newTop = (_topLayer, topAct) 143 | 144 | activations 145 | :: Network Layer -> Activations -> Network (Layer, Activations) 146 | activations net input = applyForward net input layerActs where 147 | layerActs Activations{..} layer = Activations _outputAct (_forward layer _outputAct) 148 | 149 | instance Functor Network where 150 | fmap f Network{..} = Network (fmap f _innerLayers) (f _topLayer) 151 | 152 | -- instance Foldable t => Foldable (Network t) where 153 | -- foldMap 154 | 155 | netToList :: Network a -> [a] 156 | netToList Network{..} = _innerLayers P.++ [_topLayer] 157 | 158 | netFromList :: [a] -> Network a 159 | netFromList layers = Network (init layers) (last layers) 160 | 161 | applyBackward 162 | :: Network (t1, b) 163 | -> t 164 | -> (t -> (t1, b) -> t2) 165 | -> (t2 -> (t1, b) -> t2) 166 | -> Network (t1, t2) 167 | applyBackward Network{..} topInput topF innerF = Network newInner newTop 168 | where 169 | topBackward = topF topInput _topLayer 170 | newTop = (fst _topLayer, topBackward) 171 | innerBackward = scanl innerF topBackward (reverse _innerLayers) 172 | newInner = zip (P.fmap fst _innerLayers) (reverse innerBackward) 173 | 174 | backprop :: Network (Layer, Activations) -> Label -> Network (Layer, BackProp) 175 | backprop net label = applyBackward net label topBackward innerBackward 176 | where 177 | topBackward :: Label -> (Layer, Activations) -> BackProp 178 | topBackward label (layer, output) = _topBackward layer label output 179 | innerBackward :: BackProp -> (Layer, Activations) -> BackProp 180 | innerBackward BackProp{..} (layer, acts) = _innerBackward layer $ InputProp _inputGrad acts 181 | 182 | exampleGradients 183 | :: Network Layer -> (DVol DIM1, Label) -> Network (Layer, BackProp) 184 | exampleGradients net (input, label) = backprop activated label 185 | where 186 | -- FIXME - this isn't a great pattern... 187 | activated = activations net (Activations undefined input) 188 | 189 | batchGradients :: Network Layer -> [(DVol DIM1, Label)] -> Network (Layer, [BackProp]) 190 | batchGradients net examples = netFromList (zip (netToList net) mergedGrads) 191 | where 192 | gradients :: [[(Layer, BackProp)]] 193 | gradients = P.fmap (netToList . exampleGradients net) examples 194 | layerGrads = L.transpose gradients 195 | mergedGrads = P.fmap (P.fmap snd) layerGrads 196 | 197 | applyGradients :: Network (Layer, [BackProp]) -> SGD -> Network Layer 198 | applyGradients net sgd = P.fmap (\(layer, backprops) -> _applyGradient layer sgd backprops) net 199 | 200 | runBatch :: Network Layer -> SGD -> [(DVol DIM1, Label)] -> Network Layer 201 | runBatch net sgd examples = (`applyGradients` sgd) $ batchGradients net examples 202 | --------------------------------------------------------------------------------