├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── vortex.cabal └── vortex ├── ImageProcess.hs ├── Layer.hs ├── Loss.hs ├── Main.hs ├── Models.hs ├── Optimization.hs ├── Trainer.hs └── Utils.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | *.dyn_o 8 | *.dyn_hi 9 | .hpc 10 | .hsenv 11 | .cabal-sandbox/ 12 | cabal.sandbox.config 13 | *.prof 14 | *.aux 15 | *.hp 16 | .stack-work/ 17 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016 neutronest 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # vortex 2 | 3 | ## Introduction 4 | 5 | Vortex is designed to be a Haskell implementation of Deep Learning frameworks.However it still keep developing. We hope this tool support: 6 | 7 | * Common neural layer types, such as Sigmoid, Softmax, Relu, &etc. 8 | 9 | * Multiple optimazation algorithms. SGD and Aladelta is proposed. 10 | 11 | * Some real world deep learning models. For instance, CNN, RNN, LSTM are all necessery. Futher on We also hope the Neural Turning Machine(NTM) is not immature if possible. 12 | 13 | * Some interested DEMOS. Image Regresssion, Image Classification, Neural Art, language modeling, &etc. 14 | 15 | ## TODO List (recent) 16 | 17 | * Common layers implementation: sigmoid, linear, softmax, relu, dropout. 18 | 19 | * Optimazation algorithms. 20 | 21 | * Image regression. 22 | 23 | 24 | ## Install 25 | 26 | TODO 27 | 28 | ## Example 29 | 30 | TODO 31 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /vortex.cabal: -------------------------------------------------------------------------------- 1 | -- Initial vortex.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: vortex 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | license: MIT 9 | license-file: LICENSE 10 | author: neutronest 11 | maintainer: neutronest@gmail.com 12 | -- copyright: 13 | category: MachineLearning 14 | build-type: Simple 15 | extra-source-files: README.md 16 | cabal-version: >=1.10 17 | 18 | executable vortex 19 | main-is: Main.hs 20 | ghc-options: -Wall 21 | -- other-modules: 22 | -- other-extensions: 23 | build-depends: base >=4.8 && <4.9, 24 | hmatrix >= 0.17.0, 25 | normaldistribution >= 1.1.0, 26 | random >= 1.0.1, 27 | QuickCheck >= 2.8.2, 28 | JuicyPixels >= 3.2.7, 29 | friday >= 0.2.2.0, 30 | bytestring >= 0.10.6, 31 | vector >= 0.9 && <0.12, 32 | transformers 33 | hs-source-dirs: vortex 34 | default-language: Haskell2010 35 | extensions: GADTs, 36 | RankNTypes, 37 | TypeSynonymInstances, 38 | ExistentialQuantification, 39 | ScopedTypeVariables, 40 | AllowAmbiguousTypes -------------------------------------------------------------------------------- /vortex/ImageProcess.hs: -------------------------------------------------------------------------------- 1 | module ImageProcess where 2 | 3 | import Codec.Picture 4 | import Data.Vector.Storable (Vector, length, toList) 5 | import Numeric.LinearAlgebra 6 | --import Data.ByteString 7 | 8 | 9 | 10 | imagePath :: FilePath 11 | imagePath = "./test.jpg" 12 | 13 | 14 | getDynamicImage :: FilePath -> IO(Maybe DynamicImage) 15 | getDynamicImage filepath = do 16 | res <- readImage filepath 17 | case res of 18 | Left err -> print err >> return Nothing 19 | Right image -> return (Just image) 20 | 21 | readImageInfo :: DynamicImage -> Image PixelRGB8 22 | readImageInfo image = 23 | let imagePixel8@(Image w h rgbs) = convertRGB8 image in 24 | imagePixel8 25 | 26 | 27 | getImageInfo :: FilePath -> IO(Maybe (Image PixelRGB8)) 28 | getImageInfo filepath = do 29 | res <- readImage filepath 30 | case res of 31 | Left err -> print err >> return Nothing 32 | Right image -> return $ Just (readImageInfo image) 33 | 34 | getImageWidth :: Image PixelRGB8 -> Int 35 | getImageWidth image = 36 | let (Image w _ _) = image in 37 | w 38 | 39 | getImageHeight :: Image PixelRGB8 -> Int 40 | getImageHeight image = 41 | let (Image _ h _) = image in 42 | h 43 | 44 | getImageRGBs :: Image PixelRGB8 -> Data.Vector.Storable.Vector(PixelBaseComponent Pixel8) 45 | getImageRGBs image = 46 | let (Image _ _ rgbs) = image in 47 | rgbs 48 | 49 | 50 | printPixels :: Show a => [a] -> IO() 51 | printPixels [] = return() 52 | printPixels (xr:xg:xb:xs) = 53 | print [xr, xg, xb] >> 54 | printPixels xs 55 | 56 | 57 | genRGBList :: (Show a, Integral a, Fractional b) => [a] -> ([b], [b], [b]) 58 | genRGBList [] = ([], [], []) 59 | genRGBList l = 60 | let func [] rlist glist blist = ((reverse rlist), (reverse glist), (reverse blist)) 61 | func (xr:xg:xb:xs) rlist glist blist = func xs (((fromIntegral xr)/256.0):rlist) (((fromIntegral xg)/256.0):glist) (((fromIntegral xb)/256.0):blist) in 62 | func l [] [] [] 63 | 64 | genMatrixFromList :: [R] -> Int -> Int -> Maybe (Matrix R) 65 | genMatrixFromList [] _ _ = Nothing 66 | genMatrixFromList l w h = Just ((w >< h) l) 67 | 68 | 69 | testImageProcess :: FilePath -> IO() 70 | testImageProcess filepath = do 71 | imageM <- getImageInfo filepath 72 | case imageM of 73 | Nothing -> putStrLn "nothing.." 74 | Just imagePixel8 -> 75 | putStrLn "the width of image: " >> 76 | print (getImageWidth imagePixel8) >> 77 | putStrLn "the height ofimage: " >> 78 | print (getImageHeight imagePixel8) >> 79 | print (Data.Vector.Storable.length (getImageRGBs imagePixel8)) >> 80 | let rgbs = getImageRGBs imagePixel8 in 81 | let w = getImageWidth imagePixel8 in 82 | let h = getImageHeight imagePixel8 in 83 | let rgbsList = Data.Vector.Storable.toList rgbs in 84 | let (rlist, glist, blist) = genRGBList rgbsList in 85 | print (Prelude.length rlist) >> 86 | print (Prelude.length glist) >> 87 | print (Prelude.length blist) >> 88 | let Just rMat = genMatrixFromList rlist w h in 89 | let Just gMat = genMatrixFromList glist w h in 90 | let Just bMat = genMatrixFromList blist w h in 91 | print rMat 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 | {- 100 | 101 | 102 | decodeImageWidth :: IO(Maybe (Image PixelRGB8)) -> IO(Maybe Int)) 103 | decodeImageWidth imageM = do 104 | maybeImage <- imageM 105 | case maybeImage of 106 | Nothing -> return Nothing 107 | Just (Image w h rgbs) -> return (Just w) 108 | 109 | 110 | decodeImageHeight :: IO(Maybe(Image PixelRGB8)) -> IO(Maybe Int) 111 | decodeImageHeight imageM = do 112 | maybeImage <- imageM 113 | case maybeImage of 114 | Nothing -> return Nothing 115 | Just (Image w h rgbs) -> return (Just h) 116 | 117 | decodeImageRGBs :: IO(Maybe (Image PixelRGB8)) -> IO(Maybe (Vector(PixelBaseComponent Pixel8))) 118 | decodeImageRGBs imageM = do 119 | maybeImage <- imageM 120 | case maybeImage of 121 | Nothing -> return Nothing 122 | Just (Image w h rgbs) -> return (Just rgbs) 123 | 124 | 125 | readRGBsPixel8 :: Maybe DynamicImage -> IO(Maybe (Vector(PixelBaseComponent Pixel8))) 126 | readRGBsPixel8 Nothing = return Nothing 127 | readRGBsPixel8 (Just image) = 128 | let imagePixel8@(Image _ _ rgbs) = convertRGB8 image in return (Just rgbs) 129 | 130 | getRGBs :: FilePath -> IO(Maybe (Vector(PixelBaseComponent Pixel8))) 131 | getRGBs filepath = do 132 | dynamicImage <- getDynamicImage filepath 133 | rgbs <- readRGBsPixel8 dynamicImage 134 | return rgbs 135 | 136 | -} 137 | {-} 138 | readRGBsPixel8 :: DynamicImage -> Maybe (Vector (PixelBaseComponent Pixel8)) 139 | readRGBsPixel8 (ImageY8 image@(Image _ _ rgbs)) = Just rgbs 140 | readRGBsPixel8 _ = Nothing 141 | 142 | readRGBsPixel16 :: DynamicImage -> Maybe (Vector (PixelBaseComponent Pixel16)) 143 | readRGBsPixel16 :: (ImageY16 image@(Image _ _ rgbs)) = Just rgbs 144 | readRGBsPixel16 _ = Nothing 145 | 146 | readRGBsPixelYF :: DynamicImage -> Maybe (Vector (PixelBaseComponent PixelF)) 147 | readRGBsPixelYF :: (ImageF image@(Image _ _ rgbs)) = Just rgbs 148 | readRGBsPixelYF _ = Nothing 149 | 150 | readRGBsPixelYA8 :: DynamicImage -> Maybe (Vector (PixelBaseComponent PixelYA8)) 151 | readRGBsPixelYA8 :: (ImageYA8 image@(Image _ _ rgbs)) = Just rgbs 152 | readRGBsPixelYA8 _ = Nothing 153 | 154 | readRGBsPixelYA16 :: DynamicImage -> Maybe (Vector (PixelBaseComponent PixelYA16)) 155 | readRGBsPixelYA16 :: (ImageYA16 image@(Image _ _ rgbs)) = Just rgbs 156 | readRGBsPixelYA16 _ = Nothing 157 | 158 | 159 | 160 | getRGBsImage :: forall a. Pixel a => DynamicImage -> Vector (PixelBaseComponent a) 161 | getRGBsImage (ImageY8 image@(Image _ _ rgbs@(MVector (Word8 _)))) = rgbs 162 | getRGBsImage (ImageY16 image@(Image _ _ rgbs)) = rgbs 163 | getRGBsImage (ImageYF image@(Image _ _ rgbs)) = rgbs 164 | getRGBsImage (ImageYA8 image@(Image _ _ rgbs)) = rgbs 165 | getRGBsImage (ImageRGB8 image@(Image _ _ rgbs)) = rgbs 166 | getRGBsImage (ImageRGB16 image@(Image _ _ rgbs)) = rgbs 167 | getRGBsImage (ImageRGBF image@(Image _ _ rgbs)) = rgbs 168 | getRGBsImage (ImageRGBA8 image@(Image _ _ rgbs)) = rgbs 169 | getRGBsImage (ImageRGBA16 image@(Image _ _ rgbs)) = rgbs 170 | getRGBsImage (ImageYCbCr8 image@(Image _ _ rgbs)) = rgbs 171 | getRGBsImage (ImageCMYK8 image@(Image _ _ rgbs)) = rgbs 172 | getRGBsImage (ImageCMYK16 image@(Image _ _ rgbs)) = rgbs 173 | 174 | readRGBs :: forall a. Pixel a => FilePath -> IO(Maybe (Vector (PixelBaseComponent a))) 175 | readRGBs filepath = do 176 | res <- getDynamicImage filepath 177 | case res of 178 | Nothing -> print "we got nothing!" >> return Nothing 179 | Just image -> return (Just (getRGBsImage image)) 180 | 181 | -} 182 | {- 183 | getRGBs :: Image -> Vector(PixelBaseComponent Word8) 184 | getRGBs (Image _ _ rgbs) = rgbs 185 | -} 186 | 187 | justH :: Maybe Char 188 | justH = do 189 | (x:xs) <- Just "Hello" 190 | return x 191 | -------------------------------------------------------------------------------- /vortex/Layer.hs: -------------------------------------------------------------------------------- 1 | module Layer where 2 | import Numeric.LinearAlgebra 3 | import Utils 4 | 5 | data LayerType = 6 | SigmoidLayer 7 | | LinearLayer 8 | | SoftmaxLayer 9 | | ReluLayer 10 | 11 | data VLayer = VLayer { 12 | layerType :: LayerType, 13 | rowNum :: Int, 14 | colNum :: Int, 15 | weight :: Matrix R, 16 | bias :: Matrix R, 17 | val :: Matrix R, 18 | delta :: Matrix R 19 | } 20 | 21 | {-- Linear Layer --} 22 | linearLayerInit :: Int -> Int -> VLayer 23 | linearLayerInit r c = VLayer { 24 | layerType = LinearLayer, 25 | rowNum = r, 26 | colNum = c, 27 | weight = (r >< c) genNormal, 28 | bias = (r >< c) genNormal, 29 | val = (r >< c) [0..] 30 | } 31 | 32 | forwardLinearLayer :: Matrix R -> VLayer -> Matrix R 33 | forwardLinearLayer input inputLayer = (weight inputLayer) * input + (bias inputLayer) 34 | 35 | backwardLinearLayer :: Matrix R -> VLayer -> Matrix R 36 | backwardLinearLayer backInput inputLayer = backInput 37 | 38 | {-- Sigmoid Layer --} 39 | sigmoidLayerInit :: Int -> Int -> VLayer 40 | sigmoidLayerInit r c = VLayer { 41 | layerType = SigmoidLayer, 42 | rowNum = r, 43 | colNum = c, 44 | weight = (r >< c) genNormal, 45 | bias = (r >< c) genNormal, 46 | val = (r >< c) [0..] 47 | } 48 | 49 | getSigmoidMatrix :: Matrix R -> Matrix R 50 | getSigmoidMatrix linear = 1.0 / (1.0 + (exp (- linear))) 51 | 52 | 53 | 54 | forwardSigmoidLayer :: Matrix R -> VLayer -> Matrix R 55 | forwardSigmoidLayer input layer = 56 | let linear = (weight layer) * input + (bias layer) in 57 | getSigmoidMatrix linear 58 | 59 | backwardSigmoidLayer :: Matrix R -> VLayer -> Matrix R 60 | backwardSigmoidLayer input layer = 61 | let linear = (weight layer) * input + (bias layer) in 62 | let sigmoid = getSigmoidMatrix linear in 63 | sigmoid * (1.0 - sigmoid) 64 | 65 | {-- Softmax Layer --} 66 | softmaxLayerInit :: Int -> Int -> VLayer 67 | softmaxLayerInit r c = VLayer { 68 | layerType = SoftmaxLayer, 69 | rowNum = r, 70 | colNum = c, 71 | weight = (r >< c) genNormal, 72 | bias = (r >< c) genNormal, 73 | val = (r >< c) [0..] 74 | } 75 | 76 | -- TODO: backward of softmax layer 77 | 78 | {-- Relu Layer --} 79 | reluLayerInit :: Int -> Int -> VLayer 80 | reluLayerInit r c = VLayer { 81 | layerType = ReluLayer, 82 | rowNum = r, 83 | colNum = c, 84 | weight = (r >< c 85 | ) genNormal, 86 | bias = (r >< c) genNormal, 87 | val = (r >< c) [0..] 88 | } 89 | forwardReluLayer :: Matrix R -> VLayer -> Matrix R 90 | forwardReluLayer input layer = 91 | let flagMatrix = cmap (\x -> if x >= 0.0 then 1.0 else 0.0 ) (weight layer) in 92 | flagMatrix * input 93 | 94 | 95 | backwardReluLayer :: Matrix R -> VLayer -> Matrix R 96 | backwardReluLayer backInput layer = 97 | cmap (\x -> if x <= 0.0 then x else 0.0) backInput 98 | 99 | -------------------------------------------------------------------------------- /vortex/Loss.hs: -------------------------------------------------------------------------------- 1 | module Loss where 2 | 3 | import Numeric.LinearAlgebra 4 | 5 | 6 | getLoss :: String -> Matrix R -> Matrix R -> Matrix R 7 | getLoss lossType yMat tMat = 8 | case lossType of 9 | "mse" -> mse yMat tMat 10 | otherwise -> yMat -- Warning: Never Used Necessery! 11 | 12 | mse :: Matrix R -> Matrix R -> Matrix R 13 | mse yMat tMat = 14 | let dyMat = yMat - tMat 15 | r = rows yMat 16 | c = cols yMat 17 | halfMat = (r >< c) [0.5 ..]::(Matrix R) in 18 | halfMat * dyMat * dyMat 19 | 20 | 21 | -------------------------------------------------------------------------------- /vortex/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | import Layer 3 | import Models 4 | import Numeric.LinearAlgebra 5 | import ImageProcess 6 | import Optimization 7 | import Trainer 8 | import Data.Vector.Storable (Vector, length, toList) 9 | 10 | 11 | main :: IO() 12 | main = 13 | do 14 | let inputLayer = linearLayerInit 2 2 15 | let sigmoidLayer = sigmoidLayerInit 2 2 16 | let outputLayer = linearLayerInit 2 1 in 17 | let model = Model [inputLayer, sigmoidLayer, outputLayer] in 18 | let input = (1><2)[1.0, 2.0]::Matrix R in 19 | let output = forward input model in 20 | print output 21 | 22 | 23 | 24 | testImageRegression :: FilePath -> IO() 25 | testImageRegression filepath = do 26 | imageM <- getImageInfo filepath 27 | case imageM of 28 | Nothing -> putStrLn "Nohthing ! Guess what happened ? :) " >> return () 29 | Just imagePixel8 -> 30 | let rgbs = getImageRGBs imagePixel8 31 | w = getImageWidth imagePixel8 32 | h = getImageHeight imagePixel8 33 | rgbsList = Data.Vector.Storable.toList rgbs 34 | (rlist, glist, blist) = genRGBList rgbsList 35 | Just rMat = genMatrixFromList rlist w h 36 | Just gMat = genMatrixFromList glist w h 37 | Just bMat = genMatrixFromList blist w h in 38 | --- test 39 | print "prepare the model!" >> 40 | let rinputLayer = linearLayerInit w h 41 | rreluLayer1 = reluLayerInit w h 42 | rreluLayer2 = reluLayerInit w h 43 | rreluLayer3 = reluLayerInit w h 44 | routputLayer= linearLayerInit w h 45 | rmodel = Model [rinputLayer, rreluLayer1, rreluLayer2, rreluLayer3, routputLayer] 46 | ginputLayer = linearLayerInit w h 47 | greluLayer1 = reluLayerInit w h 48 | greluLayer2 = reluLayerInit w h 49 | greluLayer3 = reluLayerInit w h 50 | goutputLayer= linearLayerInit w h 51 | gmodel = Model [ginputLayer, greluLayer1, greluLayer2, greluLayer3, goutputLayer] 52 | binputLayer = linearLayerInit w h 53 | breluLayer1 = reluLayerInit w h 54 | breluLayer2 = reluLayerInit w h 55 | breluLayer3 = reluLayerInit w h 56 | boutputLayer= linearLayerInit w h 57 | bmodel = Model [binputLayer, breluLayer1, breluLayer2, breluLayer3, boutputLayer] in 58 | print "begin to train the model" >> 59 | let trainConfig = TrainConfig { 60 | trainConfigRowNum=w, 61 | trainConfigColNum=h, 62 | trainConfigLearningRate=0.95, 63 | trainConfigMomentum=1.0, 64 | trainConfigDecay=0.95, 65 | trainConfigEpsilon=0.00001, 66 | trainConfigBatchSize=100, 67 | trainConfigOptimization="adadelta" 68 | } in 69 | trainSingleData rmodel trainConfig rMat 70 | -------------------------------------------------------------------------------- /vortex/Models.hs: -------------------------------------------------------------------------------- 1 | module Models where 2 | 3 | import Layer 4 | import Numeric.LinearAlgebra 5 | import Data.List 6 | import Loss 7 | 8 | data Model a = Model [a] 9 | 10 | addLayer :: Model a -> a -> Model a 11 | addLayer (Model []) layer = Model [layer] 12 | addLayer (Model l) layer = Model (l++[layer]) 13 | 14 | genParamsList :: Model VLayer -> [Matrix R] 15 | genParamsList (Model []) = [] 16 | genParamsList m = 17 | let genModelParams' res (Model []) = reverse res 18 | genModelParams' res (Model (mx:mxs)) = 19 | genModelParams' ((weight mx):res) (Model mxs) in 20 | genModelParams' [] m 21 | 22 | 23 | -- update the model's params from the params list 24 | updateModelParams :: Model VLayer -> [Matrix R] -> Model VLayer 25 | updateModelParams (Model []) _ = Model [] 26 | updateModelParams m p = 27 | let updateModelParams' (Model res) (Model []) _ = Model (reverse res) 28 | updateModelParams' (Model res) (Model (mx:mxs)) (px:pxs) = 29 | let newParams = mx {weight=px} in 30 | updateModelParams' (Model (newParams:res)) (Model mxs) pxs 31 | in updateModelParams' (Model []) m p 32 | 33 | genGParamsList :: Model VLayer -> [Matrix R] 34 | genGParamsList (Model []) = [] 35 | genGParamsList l = 36 | let genModelGParams' res (Model []) = reverse res 37 | genModelGParams' res (Model (mx:mxs)) = 38 | let gp = ( (rowNum mx) >< (colNum mx)) [0..]::(Matrix R) in 39 | genModelGParams' (gp:res) (Model mxs) in 40 | genModelGParams' [] l 41 | 42 | --updateModelGParams :: Model VLayer -> [Matrix R] -> Model VLayer 43 | -- update the gparams list from the model 44 | updateGParamsList :: Model VLayer -> [Matrix R] -> [Matrix R] 45 | updateGParamsList (Model []) _ = [] 46 | updateGParamsList l gpl = 47 | let updateModelGParams' res (Model []) _ = reverse res 48 | updateModelGParams res (Model (mx:mxs)) (gpx:gpxs) = 49 | let deltaUp = delta mx in 50 | updateModelGParams' ((deltaUp+gpx):res) (Model mxs) gpxs in 51 | updateModelGParams' [] l gpl 52 | 53 | 54 | forwardInterface :: Matrix R -> VLayer -> Matrix R 55 | forwardInterface input layer = 56 | case (layerType layer) of 57 | LinearLayer -> forwardLinearLayer input layer 58 | SigmoidLayer -> forwardSigmoidLayer input layer 59 | --SoftmaxLayer -> forwardSoftmaxLayer input layer 60 | ReluLayer -> forwardReluLayer input layer 61 | 62 | 63 | backwardInterface :: VLayer -> Matrix R -> Matrix R 64 | backwardInterface layer output = 65 | case (layerType layer) of 66 | LinearLayer -> backwardLinearLayer output layer 67 | SigmoidLayer -> backwardSigmoidLayer output layer 68 | ReluLayer -> backwardReluLayer output layer 69 | 70 | -- forward process of the neural network model 71 | forward :: Matrix R -> Model VLayer -> Matrix R 72 | forward input (Model []) = input 73 | forward input (Model xs) = foldl forwardInterface input xs 74 | 75 | -- the backpropagate algorithm of Neural Network 76 | -- update the delta of each layer from end to start 77 | backward :: String -> Matrix R -> Matrix R -> Model VLayer -> Model VLayer 78 | backward _ _ _ (Model []) = Model [] 79 | backward lossType yMat tMat l = 80 | let loss = getLoss lossType yMat tMat in 81 | let backward' (Model res) (Model []) _ = Model (reverse res) 82 | backward' (Model res) (Model (mx:mxs)) dw = 83 | let dwUp = backwardInterface mx dw 84 | layerUp = mx {delta=dwUp} in 85 | backward' (Model (layerUp:res)) (Model mxs) dwUp in 86 | backward' (Model []) l loss 87 | -------------------------------------------------------------------------------- /vortex/Optimization.hs: -------------------------------------------------------------------------------- 1 | module Optimization where 2 | 3 | import Numeric.LinearAlgebra 4 | 5 | class Optimize a where 6 | --optimizeInit :: a -> Double -> Double -> (Int, Int) -> a 7 | paramUpdate :: a -> a 8 | 9 | data SGD = SGD { 10 | sgdLearningRate :: Double, 11 | sgdDecay :: Double, 12 | sgdMomentum :: Double, 13 | sgdParams :: [Matrix R], 14 | sgdGparams :: [Matrix R], 15 | sgdDeltaPre :: [Matrix R], 16 | sgdBatchSize :: Double 17 | } 18 | 19 | instance Optimize SGD where 20 | paramUpdate sgd = 21 | let learningRate = sgdLearningRate sgd in 22 | let decay = sgdDecay sgd in 23 | let momentum = sgdMomentum sgd in 24 | let params = sgdParams sgd in 25 | let gparams = sgdGparams sgd in 26 | let deltaPre = sgdDeltaPre sgd in 27 | let batchSize = sgdBatchSize sgd in 28 | let _sgd (px:pxs) (gx: gxs) (dx:dxs) paUpdate deUpdate gaZeros = 29 | let r = rows gx in 30 | let c = cols gx in 31 | let lrMat = (r >< c) [learningRate..]:: (Matrix R) in 32 | let batchSizeMat = (r >< c) [batchSize..] :: (Matrix R) in 33 | let momMat = (r >< c) [momentum..] :: (Matrix R) in 34 | let gUp = gx * lrMat / batchSizeMat in 35 | let ugd = momMat * dx - gx in 36 | let pu = px + ugd in _sgd pxs gxs dxs (paUpdate++[pu]) (deUpdate++[ugd]) (gaZeros++[(r >< c) [0..]]) 37 | _sgd [] [] [] paUpdate deUpdate gaZeros = SGD { 38 | sgdLearningRate=learningRate, 39 | sgdDecay=decay, 40 | sgdMomentum=momentum, 41 | sgdParams=paUpdate, 42 | sgdGparams=gaZeros, 43 | sgdDeltaPre=deUpdate, 44 | sgdBatchSize=0 45 | } in 46 | _sgd params gparams deltaPre [] [] [] 47 | 48 | 49 | data Adadelta = Adadelta { 50 | adaDecay :: Double, 51 | adaEpsilon :: Double, 52 | adaBatchSize :: Double, 53 | adaParams :: [Matrix R], 54 | adaGparams :: [Matrix R], 55 | adaAccGrad :: [Matrix R], 56 | adaAccDelta :: [Matrix R] 57 | } 58 | 59 | 60 | instance Optimize Adadelta where 61 | paramUpdate ada = 62 | let decay = adaDecay ada in 63 | let epsilon = adaEpsilon ada in 64 | let batchSize = adaBatchSize ada in 65 | let params = adaParams ada in 66 | let gparams = adaGparams ada in 67 | let accGrad = adaAccGrad ada in 68 | let accDelta = adaAccDelta ada in 69 | let _ada (px:pxs) (gx:gxs) (accgx:accgxs) (accdx:accdxs) paUpdate gradUpdate deltaUpdate gaZeros = 70 | let r = rows px in 71 | let c = cols px in 72 | let decayMat = (r >< c) [decay ..] :: (Matrix R) in 73 | let epsilonMat = (r >< c) [epsilon ..] :: (Matrix R) in 74 | let batchSizeMat = (r >< c) [batchSize ..] :: (Matrix R) in 75 | let oneMat = (r >< c) [1.0 ..]:: (Matrix R) in 76 | let gUp = accgx / batchSizeMat in 77 | let gradUp = decayMat * accgx + (oneMat - decayMat) * gUp * gUp in 78 | let ugd = (cmap (\x -> -(sqrt x)) (accdx + epsilonMat)) / (cmap (\x -> sqrt x) (accgx + epsilonMat)) * gUp in 79 | let deltaUp = decayMat * accdx + (oneMat - decayMat) * ugd * ugd in 80 | let pu = px + ugd in 81 | _ada pxs gxs accgxs accdxs (pu:paUpdate) (gradUp:gradUpdate) (deltaUp:deltaUpdate) (((r >< c)[0.0 ..]):gaZeros) 82 | _ada [] [] [] [] paUpdate gradUpdate deltaUpdate gaZeros = Adadelta { 83 | adaDecay=decay, 84 | adaEpsilon=epsilon, 85 | adaBatchSize=batchSize, 86 | adaParams=(reverse paUpdate), 87 | adaGparams=(reverse gaZeros), 88 | adaAccGrad=(reverse gradUpdate), 89 | adaAccDelta=(reverse deltaUpdate) 90 | } 91 | in _ada params gparams accGrad accDelta [] [] [] [] 92 | -------------------------------------------------------------------------------- /vortex/Trainer.hs: -------------------------------------------------------------------------------- 1 | module Trainer where 2 | 3 | import Numeric.LinearAlgebra 4 | import Models 5 | import Layer 6 | import Optimization 7 | import Data.Foldable 8 | import Control.Monad.IO.Class 9 | import Utils 10 | 11 | data TrainConfig = TrainConfig { 12 | trainConfigRowNum :: Int, 13 | trainConfigColNum :: Int, 14 | trainConfigLearningRate :: Double, 15 | trainConfigMomentum :: Double, 16 | trainConfigDecay :: Double, 17 | trainConfigEpsilon :: Double, 18 | trainConfigBatchSize :: Double, 19 | trainConfigOptimization:: String 20 | } 21 | 22 | trainSingleData :: Model VLayer -> TrainConfig -> Matrix R -> IO () 23 | trainSingleData (Model []) _ _ = print "No models !" >> return () 24 | trainSingleData neuModel trainConfig inputData = 25 | let r = trainConfigRowNum trainConfig 26 | c = trainConfigColNum trainConfig 27 | paramsList = genParamsList neuModel 28 | gparamsList = genGParamsList neuModel 29 | accGradList = accMatrixInit paramsList 30 | accDeltaList = accMatrixInit paramsList 31 | optimize = Adadelta { 32 | adaDecay = trainConfigDecay trainConfig, 33 | adaEpsilon = trainConfigEpsilon trainConfig, 34 | adaBatchSize = (trainConfigBatchSize trainConfig), 35 | adaParams = paramsList, 36 | adaGparams = gparamsList, 37 | adaAccGrad = accGradList, 38 | adaAccDelta = accDeltaList 39 | } in 40 | -- begin to train 41 | forM_ [1..10000] $ \idx -> do 42 | --print idx 43 | let output = forward inputData neuModel in 44 | --print "backpropagate the model" >> 45 | let neuModel = backward "mse" output inputData neuModel in 46 | --print "neumodel" >> 47 | let gparamsList = updateGParamsList neuModel gparamsList in 48 | --print "continue" >> 49 | if mod idx 100 == 0 && idx >= 100 then 50 | -- update the params in optimize 51 | -- update the params in model 52 | let optimize = paramUpdate optimize 53 | paramsList = adaParams optimize 54 | neuModel = updateModelParams neuModel paramsList in 55 | print (getAverageMat output) >> 56 | return() 57 | else return() 58 | -------------------------------------------------------------------------------- /vortex/Utils.hs: -------------------------------------------------------------------------------- 1 | module Utils where 2 | 3 | import Data.Random.Normal 4 | import Numeric.LinearAlgebra 5 | import System.Random 6 | --import Test.QuickCheck 7 | 8 | genNormal :: (Random a, Floating a) => [a] 9 | genNormal = let g = mkStdGen 1001 in 10 | normals g 11 | 12 | testGenNormal :: (Random a, Floating a) => [a] 13 | testGenNormal = let g = mkStdGen 1001 in 14 | take 10 (normals g) 15 | 16 | getAverageMat :: Matrix R -> Double 17 | getAverageMat mat = 18 | let r_f = fromIntegral $ rows mat 19 | c_f = fromIntegral $ cols mat 20 | sumMat = sumElements mat in 21 | sumMat / (r_f * c_f) 22 | 23 | --------------------------------------------------------------------------------