diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +The BSD License + +Copyright (c) , +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + - Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + + - Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + + - Neither the name of the nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE diff --git a/NN.hs b/NN.hs new file mode 100644 --- /dev/null +++ b/NN.hs @@ -0,0 +1,11 @@ +module NN(module NN.DSL, + module NN.CLI, + module NN.Graph, + module NN.Passes, + module NN.Visualize) where + +import NN.CLI +import NN.DSL +import NN.Graph +import NN.Passes +import NN.Visualize diff --git a/NN/Backend/Caffe.hs b/NN/Backend/Caffe.hs new file mode 100644 --- /dev/null +++ b/NN/Backend/Caffe.hs @@ -0,0 +1,19 @@ +module NN.Backend.Caffe where + +import Gen.Caffe.NetParameter as NP + +import Control.Lens +import Data.Graph.Inductive.Query +import qualified Data.Sequence as S + +import NN.DSL +import NN.Passes + +caffePasses :: [Pass] +caffePasses = [addConnection, addLabels] ++ optimizeInPlaceLayer ReLU ++ optimizeInPlaceLayer Dropout + +middleEnd :: Net -> Net +middleEnd = optimizeWith caffePasses + +backend :: Net -> NetParameter +backend gr = def & _layer <>~ S.fromList (topsort' gr) diff --git a/NN/Backend/Torch.hs b/NN/Backend/Torch.hs new file mode 100644 --- /dev/null +++ b/NN/Backend/Torch.hs @@ -0,0 +1,9 @@ +module NN.Backend.Torch(NN.Backend.Torch.backend) where + +import NN.Backend.Torch.Codegen +import NN.Backend.Torch.Torch + +import NN.DSL + +backend :: Net -> Maybe String +backend = fmap (codegen . lower) . linearize . clean diff --git a/NN/CLI.hs b/NN/CLI.hs new file mode 100644 --- /dev/null +++ b/NN/CLI.hs @@ -0,0 +1,56 @@ +module NN.CLI where + +import Control.Applicative +import Control.Lens hiding ((<.>)) +import Control.Monad +import qualified Data.ByteString.Lazy as BS +import NN.Backend.Caffe as Caffe +import NN.Backend.Torch as Torch +import NN.DSL +import NN.Passes +import NN.Visualize +import Options.Applicative hiding ((&)) +import System.Exit +import System.FilePath.Posix +import System.Process +import Text.ProtocolBuffers as P + +caffePrototxt :: NetBuilder -> FilePath -> FilePath -> IO () +caffePrototxt net prototxtPath binaryToText' = do + parse net & Caffe.middleEnd & Caffe.backend & messagePut & BS.writeFile binaryPath + rawSystem binaryToText' [binaryPath, prototxtPath] >>= exitWith + where + binaryPath = prototxtPath <.> "protobinary" + +netPdf :: NetBuilder -> FilePath -> IO () +netPdf net path = void $ visualize (parse net) & pdf path + +torchCode :: NetBuilder -> FilePath -> IO () +torchCode net path = do + let Just code = parse net & Torch.backend + writeFile path code + +data Command = Caffe String String | Torch String | PDF String + +filename = strOption (long "output" <> help "Write output to FILE" <> metavar "FILE") +binaryToText = strOption (long "binary_to_text" + <> help "Path to binary_to_text.py BINARY" + <> showDefault + <> metavar "BINARY" + <> value "./binary_to_text.py") + +opts :: Parser Command +opts = subparser (caffe <> torch <> pdf') + where + nc name parser desc = command name (info (helper <*> parser) (progDesc desc)) + caffe = nc "caffe" (Caffe <$> filename <*> binaryToText) "Generate a Caffe .prototxt to run with `caffe train --model=<>" + torch = nc "torch" (Torch <$> filename) "Generate Lua code to be `require`'d into an existing Torch script" + pdf' = nc "pdf" (PDF <$> filename) "Generate a PDF visualizing the model's connectivity" + +run :: NetBuilder -> Command -> IO () +run net (Caffe prototxtPath binaryToTextPath) = caffePrototxt net prototxtPath binaryToTextPath +run net (Torch path) = torchCode net path +run net (PDF path) = netPdf net path + +cli :: NetBuilder -> IO () +cli net = execParser (info (helper <*> opts) idm) >>= run net diff --git a/NN/DSL.hs b/NN/DSL.hs new file mode 100644 --- /dev/null +++ b/NN/DSL.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE OverloadedStrings #-} +module NN.DSL(module NN.DSL, P.Phase(..), DP.DB(..), LP.LayerParameter) where + +import Gen.Caffe.AccuracyParameter as AP +import Gen.Caffe.ConvolutionParameter as CP +import Gen.Caffe.DataParameter as DP +import Gen.Caffe.DataParameter.DB as DP +import Gen.Caffe.DropoutParameter as DP +import Gen.Caffe.FillerParameter as FP +import Gen.Caffe.InnerProductParameter as IP +import Gen.Caffe.LayerParameter as LP +import Gen.Caffe.LRNParameter as LRN +import Gen.Caffe.NetStateRule as NS +import Gen.Caffe.ParamSpec as PS +import Gen.Caffe.Phase as P +import Gen.Caffe.PoolingParameter as PP +import Gen.Caffe.PoolingParameter.PoolMethod as PP +import Gen.Caffe.TransformationParameter as TP + +import Control.Lens +import Data.Maybe +import Data.Sequence +import Text.ProtocolBuffers as P + +import NN.Graph + +type Net = Gr LayerParameter () +type AnnotatedNet a = Gr (LayerParameter, a) () +type NetBuilder = G LayerParameter () + +data LayerTy = Data + | Pool + | Concat + | Conv + | IP + | LRN + | ReLU + | Dropout + | Accuracy + | SoftmaxWithLoss + deriving (Show, Eq, Enum) + +-- Manually implement for exhausiveness checking + Caffe +-- idiosyncracies +asCaffe :: LayerTy -> String +asCaffe Data = "Data" +asCaffe Concat = "Concat" +asCaffe Pool = "Pooling" +asCaffe Conv = "Convolution" +asCaffe IP = "InnerProduct" +asCaffe LRN = "LRN" +asCaffe ReLU = "ReLU" +asCaffe Dropout = "Dropout" +asCaffe Accuracy = "Accuracy" +asCaffe SoftmaxWithLoss = "SoftmaxWithLoss" + +toCaffe :: String -> Maybe LayerTy +toCaffe "Data" = Just Data +toCaffe "Concat" = Just Concat +toCaffe "Pooling" = Just Pool +toCaffe "Convolution" = Just Conv +toCaffe "InnerProduct" = Just IP +toCaffe "LRN" = Just LRN +toCaffe "ReLU" = Just ReLU +toCaffe "Dropout" = Just Dropout +toCaffe "Accuracy" = Just Accuracy +toCaffe "SoftmaxWithLoss" = Just SoftmaxWithLoss +toCaffe _ = Nothing + +s = P.fromString + +def :: Default a => a +def = P.defaultValue + +ty type'' = LP._type' ?~ s (asCaffe type'') + +layerTy :: LayerParameter -> LayerTy +layerTy l = fromJust (LP.type' l) & toString & toCaffe & fromJust + +phase' phase'' = LP._include <>~ singleton (def & _phase ?~ phase'') + +param' v = _param .~ fromList v + +-- Data +setF outer f n = set (outer . _Just . f) (Just n) +source' source'' = setF _data_param DP._source (s source'') +cropSize' = setF _transform_param TP._crop_size +meanFile' meanFile'' = setF _transform_param TP._mean_file (s meanFile'') +mirror' = setF _transform_param TP._mirror +batchSize' = setF _data_param DP._batch_size +backend' = setF _data_param DP._backend + +-- Convolution +setConv = setF _convolution_param +numOutputC' = setConv CP._num_output +kernelSizeC' = setConv CP._kernel_size +padC' = setConv CP._pad +groupC' = setConv CP._group +strideC' = setConv CP._stride +biasFillerC' = setConv CP._bias_filler +weightFillerC' = setConv CP._weight_filler + +-- Pooling +setPool = setF _pooling_param +pool' = setPool PP._pool +sizeP' = setPool PP._kernel_size +strideP' = setPool PP._stride +padP' = setPool PP._pad + +-- Inner Product +setIP = setF _inner_product_param +weightFillerIP' = setIP IP._weight_filler +numOutputIP' = setIP IP._num_output +biasFillerIP' = setIP IP._bias_filler + +-- LRN +setLRN = setF _lrn_param +localSize' = setLRN LRN._local_size +alphaLRN' = setLRN LRN._alpha +betaLRN' = setLRN LRN._beta + +-- Fillers +constant value' = def & FP._type' ?~ s "constant" & _value ?~ value' +gaussian std' = def & FP._type' ?~ s "gaussian" & _std ?~ std' +xavier std' = def & FP._type' ?~ s "xavier" & _std ?~ std' +zero = constant 0.0 + +-- Multipler +lrMult' value' = _lr_mult ?~ value' +decayMult' value' = _decay_mult ?~ value' + +-- Simple Layers +accuracy k' = def & ty Accuracy & phase' TEST & _accuracy_param ?~ (def & AP._top_k ?~ k') +softmax = def & ty SoftmaxWithLoss +dropout ratio = def & ty Dropout & _dropout_param ?~ (def & _dropout_ratio ?~ ratio) +relu = def & ty ReLU +conv = def & ty Conv & _convolution_param ?~ def +ip n = def & ty IP & _inner_product_param ?~ def & numOutputIP' n +data' = def & ty Data & _transform_param ?~ def & _data_param ?~ def +maxPool = def & ty Pool & _pooling_param ?~ def & pool' MAX +avgPool = def & ty Pool & _pooling_param ?~ def & pool' AVE +lrn = def & ty LRN & _lrn_param ?~ def +concat' = def & ty Concat diff --git a/NN/Examples/AlexNet.hs b/NN/Examples/AlexNet.hs new file mode 100644 --- /dev/null +++ b/NN/Examples/AlexNet.hs @@ -0,0 +1,50 @@ +module NN.Examples.AlexNet where + +import Control.Lens +import Control.Monad + +import NN +import NN.Examples.ImageNet + +alexTrain = train & cropSize' 227 & batchSize' 256 & mirror' True +alexTest = test & cropSize' 227 & batchSize' 50 & mirror' False + +alexLrn = lrn & localSize' 5 & alphaLRN' 0.0001 & betaLRN' 0.75 +alexConv = conv & param' alexMult & weightFillerC' (gaussian 0.01) & biasFillerC' zero +alexIP n = ip n & param' alexMult & weightFillerIP' (gaussian 0.005) & biasFillerIP' (constant 0.1) +alexPool = maxPool & sizeP' 3 + +alexMult = [def & lrMult' 1 & decayMult' 1, -- weights + def & lrMult' 2 & decayMult' 0] -- biases + +-- |Model +conv1 = alexConv & numOutputC' 96 & kernelSizeC' 11 & strideC' 4 +conv2 = alexConv & numOutputC' 256 & padC' 2 & kernelSizeC' 5 & groupC' 2 +conv3 = alexConv & numOutputC' 384 & padC' 1 & kernelSizeC' 3 +conv4 = alexConv & numOutputC' 384 & padC' 1 & kernelSizeC' 3 & groupC' 2 & biasFillerC' (constant 0.1) +conv5 = alexConv & numOutputC' 256 & padC' 1 & kernelSizeC' 3 & groupC' 2 & biasFillerC' (constant 0.1) + +alexNetSmall = do + (input', representation) <- sequential [conv1, relu, alexPool & strideP' 3] + forM_ [alexTrain, alexTest] $ attach (To input') + forM_ [accuracy 1, accuracy 5, softmax] $ attach (From representation) + +alexNet = do + -- Set up the model + (input', representation) <- + sequential [ + -- Convolutional Layers + conv1, relu, alexLrn, alexPool & strideP' 3, + conv2, relu, alexLrn, alexPool & strideP' 2, + conv3, relu, + conv4, relu, + conv5, relu, alexPool & strideP' 2, + -- FC Layers + alexIP 4096, relu, dropout 0.5, + alexIP 4096, relu, dropout 0.5, + alexIP 1000 & weightFillerIP' (gaussian 0.01) & biasFillerIP' zero] + + forM_ [alexTrain, alexTest] $ attach (To input') + forM_ [accuracy 1, accuracy 5, softmax] $ attach (From representation) + +main = cli alexNet diff --git a/NN/Examples/Demo.hs b/NN/Examples/Demo.hs new file mode 100644 --- /dev/null +++ b/NN/Examples/Demo.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} +module NN.Examples.Demo where + +import Gen.Caffe.LayerParameter as LP +import Gen.Caffe.NetParameter as NP + +import Control.Lens +import GHC.IO.Handle +import System.IO.Temp +import System.Process +import Text.Printf + +import NN +import NN.Backend.Caffe as Caffe +import NN.Backend.Torch as Torch +import NN.Examples.AlexNet +import NN.Examples.GoogLeNet + +caffe :: IO () +caffe = do + let output = parse googLeNet & Caffe.middleEnd & Caffe.backend + let names = output ^. NP._layer ^..traverse . LP._name ^..traverse . _Just + print names + +torch :: IO () +torch = do + let Just output = parse alexNetSmall & Torch.backend + putStr $ output ++ "\n" + +visualizeGoogLeNet :: IO () +visualizeGoogLeNet = do + (file, handle) <- openTempFile "/tmp" "graph.pdf" + hClose handle + f <- parse googLeNet & visualize & pdf file + _ <- system $ printf "open %s &" f + return () + +visualizeGoogLeNetDensity :: IO () +visualizeGoogLeNetDensity = do + (file, handle) <- openTempFile "/tmp" "graph.pdf" + hClose handle + f <- parse googLeNet & visualizeWith (scaled downscaleReLU) & pdf file + _ <- system $ printf "open %s &" f + return () + where + downscaleReLU lp = go (layerTy lp) + where + go ReLU = 1 + go _ = 2 diff --git a/NN/Examples/GoogLeNet.hs b/NN/Examples/GoogLeNet.hs new file mode 100644 --- /dev/null +++ b/NN/Examples/GoogLeNet.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE RecordWildCards #-} +module NN.Examples.GoogLeNet where + +import Gen.Caffe.FillerParameter as FP +import Gen.Caffe.InnerProductParameter as IP +import Gen.Caffe.LayerParameter as LP + +import Control.Lens +import Control.Monad +import Data.Sequence (singleton) +import Data.Word + +import NN +import NN.Examples.ImageNet + + +googleTrain = train & mirror' True & batchSize' 32 & cropSize' 224 +googleTest = test & mirror' False & batchSize' 50 & cropSize' 224 + +googleMult = [def & lrMult' 1 & decayMult' 1, -- weights + def & lrMult' 2 & decayMult' 0] -- biases +googleConv = conv & param' googleMult & biasFillerC' (constant 0.2) +googleLRN = lrn & localSize' 5 & alphaLRN' 0.0001 & betaLRN' 0.75 +googlePool = maxPool & sizeP' 3 & strideP' 2 +googleIP n = ip n & param' googleMult + +conv1 = googleConv & numOutputC' 64 & padC' 3 & kernelSizeC' 7 & strideC' 2 & weightFillerC' (xavier 0.1) +conv2 = googleConv & numOutputC' 192 & padC' 1 & kernelSizeC' 3 & weightFillerC' (xavier 0.03) + +topPool = avgPool & sizeP' 7 & strideP' 1 +topFc = googleIP 1000 & biasFillerIP' (constant 0) & weightFillerIP' (xavier 0.0) + -- Weird, but in Caffe replication + & _inner_product_param._Just.IP._weight_filler._Just._std .~ Nothing + +data Inception = Inception {_1x1, _3x3reduce, _3x3, _5x5reduce, _5x5, _poolProj :: Word32} + +inception :: Node -> Inception -> G LayerParameter Node +inception input Inception{..} = do + columns' <- mapM sequential columns + concat'' <- layer' concat' + forM_ columns' $ \(bottom, top) -> input >-> bottom >> top >-> concat'' + return concat'' + where + columns = [ + [googleConv & numOutputC' _1x1 & kernelSizeC' 1 & weightFillerC' (xavier 0.03), relu], + [googleConv & numOutputC' _3x3reduce & kernelSizeC' 1 & weightFillerC' (xavier 0.09), relu, googleConv & numOutputC' _3x3 & kernelSizeC' 3 & weightFillerC' (xavier 0.03) & padC' 1, relu], + [googleConv & numOutputC' _5x5reduce & kernelSizeC' 1 & weightFillerC' (xavier 0.2), relu, googleConv & numOutputC' _5x5 & kernelSizeC' 5 & weightFillerC' (xavier 0.03) & padC' 2, relu], + [maxPool& sizeP' 3 & strideP' 3 & padP' 1, googleConv & numOutputC' _poolProj & kernelSizeC' 1 & weightFillerC' (xavier 0.1), relu]] + +intermediateClassifier :: Node -> NetBuilder +intermediateClassifier source = do + (input, representation) <- sequential [pool1, conv1', relu, fc1, relu, dropout 0.7, fc2] + source >-> input + + forM_ [accuracy 1, accuracy 5, softmax & _loss_weight <>~ singleton 0.3] $ attach (From representation) + where + pool1 = avgPool & sizeP' 5 & strideP' 3 + conv1' = googleConv & numOutputC' 128 & kernelSizeC' 1 & weightFillerC' (xavier 0.08) + fc1 = googleIP 1024 & weightFillerIP' (xavier 0.02) & biasFillerIP' (constant 0.2) + fc2 = googleIP 1000 & weightFillerIP' (xavier 0.0009765625) & biasFillerIP' (constant 0) + +-- What to do at each step in the inner column? +data ColumnStep = I Inception | Classifier | MaxPool + +googLeNet = do + (input, initial) <- sequential [conv1, relu, googlePool, googleLRN, conv2, relu, googleLRN, googlePool] + + incepted <- foldM inceptionClassifier initial [ + I $ Inception 64 96 128 16 32 32, + I $ Inception 128 128 192 32 96 64, + MaxPool, + I $ Inception 192 96 208 16 48 64, + Classifier, + I $ Inception 150 112 224 24 64 64, + I $ Inception 128 128 256 24 64 64, + I $ Inception 112 144 288 32 64 64, + Classifier, + I $ Inception 256 160 320 32 128 128, + MaxPool, + I $ Inception 256 160 320 32 128 128, + I $ Inception 384 192 384 48 128 128] + + (_, representation) <- return (incepted, incepted) >- sequential [topPool, dropout 0.4, topFc] + + forM_ [accuracy 1, accuracy 5, softmax] $ attach (From representation) + forM_ [googleTrain, googleTest] $ attach (To input) + where + inceptionClassifier input (I inceptor) = inception input inceptor + inceptionClassifier input Classifier = intermediateClassifier input >> return input + inceptionClassifier input MaxPool = do {node <- layer' googlePool; input >-> node; return node} + +main :: IO () +main = cli googLeNet diff --git a/NN/Examples/ImageNet.hs b/NN/Examples/ImageNet.hs new file mode 100644 --- /dev/null +++ b/NN/Examples/ImageNet.hs @@ -0,0 +1,16 @@ +module NN.Examples.ImageNet(test, train) where + +import Gen.Caffe.DataParameter.DB as DP + +import Control.Lens + +import NN.DSL + +-- |Base layer specifications +imagenetData = data' + & meanFile' "data/ilsvrc12/imagenet_mean.binaryproto" + & backend' LMDB + +-- |Data +test = imagenetData & phase' TEST & source' "examples/imagenet/ilsvrc12_train_lmdb" +train = imagenetData & phase' TRAIN & source' "examples/imagenet/ilsvrc12_train_lmdb" diff --git a/NN/Graph.hs b/NN/Graph.hs new file mode 100644 --- /dev/null +++ b/NN/Graph.hs @@ -0,0 +1,41 @@ +module NN.Graph(module NN.Graph, Gr, Node) where + +import Control.Arrow +import Control.Monad.State.Strict +import Data.Graph.Inductive.Graph +import Data.Graph.Inductive.PatriciaTree + +-- Useful Graph Combinators +type G a = State (Node, Gr a ()) + +sequential :: [a] -> G a (Node, Node) +sequential = stack . map layer + +layer :: a -> G a (Node, Node) +layer l = do + gid <- layer' l + return (gid, gid) + +layer' :: a -> G a Node +layer' l = do + (gid, s) <- get + put (gid + 1, insNode (gid, l) s) + return gid + +data Attach = From Node | To Node +attach :: Attach -> a -> G a () +attach (From n) l = do {l' <- layer' l; n >-> l'} +attach (To n) l = do {l' <- layer' l; l' >-> n} + +(>->) :: Node -> Node -> G a () +(>->) from to = modify (second (insEdge (from, to, ()))) + +stack :: [G a (Node, Node)] -> G a (Node, Node) +stack = foldl1 (>-) + +(>-) :: G a (Node, Node) -> G a (Node, Node) -> G a (Node, Node) +base >- above = do + (from, midBelow) <- base + (midAbove, top) <- above + midBelow >-> midAbove + return (from, top) diff --git a/NN/Passes.hs b/NN/Passes.hs new file mode 100644 --- /dev/null +++ b/NN/Passes.hs @@ -0,0 +1,86 @@ +module NN.Passes(module NN.Passes) where + +import NN.DSL +import NN.Graph + +import Gen.Caffe.LayerParameter as LP + +import Control.Lens +import Control.Monad.State.Strict +import Data.Char +import qualified Data.Foldable as F +import Data.Graph.Inductive.Graph hiding ((&)) +import qualified Data.Graph.Inductive.Graph as G +import Data.Maybe +import qualified Data.Sequence as S + +import Text.Printf +import Text.ProtocolBuffers as P + +type Pass = (Net, Node, LayerParameter) -> LayerParameter + +layerName :: LayerParameter -> Int -> Utf8 +layerName l i = printf "%s_%d" (type' l & fromJust & toString & map toLower) i & s + +runPass :: Net -> Pass -> Net +runPass gr pass = gmap run gr + where + run (_pre, i, lp, _suc) = (_pre, i, pass (gr, i, lp), _suc) + +addLabels :: Pass +addLabels (_, _, lp) = update (layerTy lp) + where + update Data = lp & LP._top <>~ S.singleton (s "label") + update SoftmaxWithLoss = lp & LP._bottom <>~ S.singleton (s "label") + update Accuracy = lp & LP._bottom <>~ S.singleton (s "label") + update _ = lp + +-- |If our layerTy is the given layer that is performed in-place, then +-- update `top` to point to `bottom`. +-- If any of our parents are performed in-place, update `bottom` to +-- point to our parents `top` +optimizeInPlaceLayer :: LayerTy -> [Pass] +optimizeInPlaceLayer layerTy' = [updateIfInPlace, updateIfParentInPlace] where + inPlace lp = layerTy lp == layerTy' + inPlaceParents gr i = filter inPlace . map fst $ pres gr i + + updateIfInPlace (_, i, lp) = + case (layerTy lp == layerTy', F.toList (top lp)) of + (True, [_]) -> lp & LP._top .~ bottom lp + (True, _) -> error $ printf "Can only have one output for an in-place layer" ++ show (layerName lp i) + (False, _) -> lp + + updateIfParentInPlace :: Pass + updateIfParentInPlace (gr, i, lp) = + case updateFromParents (gr, i, lp) of + Left e -> error e + Right lp' -> lp' + + updateFromParents :: (Net, Node, LayerParameter) -> Either String LayerParameter + updateFromParents (gr, i, lp) = + case (inPlaceParents gr i, F.toList (bottom lp)) of + ([], _) -> Right lp + (parents, bottoms) -> + -- TODO this is super dodgy and incorrect in the general + -- case (there are some weird invariants we rely on), but it works for now. + if length parents /= length bottoms + then Left $ printf "Must have all parents in-place for in-place optimizations" ++ show (layerName lp i) + else let parentTops = F.concatMap (F.toList . LP.top) parents in + if length parentTops == length ((F.toList . LP.bottom) lp) + then Right $ lp & LP._bottom .~ S.fromList parentTops + else Left $ error "asdf" + +labelled gr = map (\ j -> (lab' (context gr j), j)) +pres gr j = labelled gr (G.pre gr j) + +addConnection :: Pass +addConnection (gr, i, lp) = lp + & LP._name ?~ layerName lp i + & LP._bottom .~ S.fromList (map (uncurry layerName) (pres gr i)) + & LP._top <>~ S.singleton (layerName lp i) + +optimizeWith :: [Pass] -> Net -> Net +optimizeWith passes gr = foldl runPass gr passes + +parse :: G a b -> Gr a () +parse g = snd (execState g (1, empty)) diff --git a/NN/Visualize.hs b/NN/Visualize.hs new file mode 100644 --- /dev/null +++ b/NN/Visualize.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} +module NN.Visualize where + +import Data.GraphViz +import Data.GraphViz.Attributes.Colors.Brewer +import Data.GraphViz.Attributes.Complete +import qualified Data.Text.Lazy as L + +import Data.Graph.Inductive.Graph +import NN.DSL + +type NetVizParams = GraphvizParams Node LayerParameter () () LayerParameter + +defaultNNParams = + nonClusteredParams { + -- Let's visualize neural networks from the bottom up + globalAttributes = [GraphAttrs [RankDir FromBottom]], + fmtNode = fmtLabelParameter +} + + +scaled :: (LayerParameter -> Double) -> NetVizParams +scaled f = defaultNNParams { fmtNode = setSize } + where + setSize n@(_, lp) = fmtNode defaultNNParams n ++ [Width width', Height height'] + where + width' = 0.75 * scale + height' = 0.5 * scale + scale = f lp + +visualizeWith :: NetVizParams -> Net -> DotGraph Node +visualizeWith = graphToDot + +visualize :: Net -> DotGraph Node +visualize = visualizeWith defaultNNParams + +png :: FilePath -> DotGraph Node -> IO FilePath +png path g = runGraphviz g Png path + +pdf :: FilePath -> DotGraph Node -> IO FilePath +pdf path g = runGraphviz g Pdf path + +fmtLabelParameter :: (Node, LayerParameter) -> [Attribute] +fmtLabelParameter (_, lp) = + [FontName "Source Code Pro", + textLabel label, + style filled, + fillColor color'] + where + maxColors = 8 + idx = ((+1) . (`mod` maxColors) . fromEnum . layerTy) lp + scheme = BScheme Pastel2 (fromIntegral maxColors) + color' = BC scheme (fromIntegral idx) + label = (L.pack . asCaffe . layerTy) lp diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/caffegraph.cabal b/caffegraph.cabal new file mode 100644 --- /dev/null +++ b/caffegraph.cabal @@ -0,0 +1,38 @@ +name: caffegraph +version: 0.1.0.0 +synopsis: A compiler for building, optimizing, visualizing, and generating (Caffe/Torch) DNNs +license: BSD3 +license-file: LICENSE +author: Andrew Tulloch +maintainer: andrew@tullo.ch +homepage: https://github.com/ajtulloch/caffegraph/ +category: Math +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 +source-repository head + type: git + location: https://github.com/ajtulloch/caffegraph/ + +Library + GHC-Options: -Wall -fno-warn-missing-signatures + Hs-Source-Dirs: . + exposed-modules: NN, NN.CLI, NN.DSL, NN.Graph, NN.Passes, NN.Visualize, NN.Backend.Caffe, NN.Backend.Torch + NN.Examples.ImageNet, NN.Examples.AlexNet, NN.Examples.GoogLeNet, NN.Examples.Demo + build-depends: base >=4.7 && <4.8 + , bytestring + , containers + , fgl + , filepath + , graphviz + , language-lua + , lens + , mtl + , process + , protocol-buffers + , protocol-buffers-descriptor + , template-haskell + , temporary + , optparse-applicative + , text + default-language: Haskell2010