Adapt MNIST example to use the original lecun data files

.gitignore

@@ -3,3 +3,4 @@ cabal.project.local
 cabal.sandbox.config
 dist/
 dist-newstyle/
+data

.hlint.yaml

@@ -0,0 +1,64 @@
+# HLint configuration file
+# https://github.com/ndmitchell/hlint
+##########################
+
+# This file contains a template configuration file, which is typically
+# placed as .hlint.yaml in the root of your project
+
+
+- ignore: {name: "Redundant bracket"}
+- ignore: {name: "Reduce duplication"}
+
+
+# Specify additional command line arguments
+#
+# - arguments: [--color, --cpp-simple, -XQuasiQuotes]
+
+
+# Control which extensions/flags/modules/functions can be used
+#
+# - extensions:
+#   - default: false # all extension are banned by default
+#   - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used
+#   - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module
+#
+# - flags:
+#   - {name: -w, within: []} # -w is allowed nowhere
+#
+# - modules:
+#   - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set'
+#   - {name: Control.Arrow, within: []} # Certain modules are banned entirely
+#
+# - functions:
+#   - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules
+
+
+# Add custom hints for this project
+#
+# Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar"
+# - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x}
+
+
+# Turn on hints that are off by default
+#
+# Ban "module X(module X) where", to require a real export list
+# - warn: {name: Use explicit module export list}
+#
+# Replace a $ b $ c with a . b $ c
+# - group: {name: dollar, enabled: true}
+#
+# Generalise map to fmap, ++ to <>
+# - group: {name: generalise, enabled: true}
+
+
+# Ignore some builtin hints
+# - ignore: {name: Use let}
+# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules
+
+
+# Define some custom infix operators
+# - fixity: infixr 3 ~^#^~
+
+
+# To generate a suitable file for HLint do:
+# $ hlint --default > .hlint.yaml

.travis.yml

@@ -18,6 +18,7 @@ before_install:
 install:
  - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
  - travis_retry cabal-3.0 update
+# - cabal-3.0 install hlint
 
 notifications:
   email: false
@@ -27,4 +28,9 @@ script:
  - cabal-3.0 configure --enable-tests
  - cabal-3.0 build all
  - cabal-3.0 test --test-show-details=direct -j1
-
+ # - cabal-3.0 run feedforward
+ # - cabal-3.0 run recurrent
+ - ./runMNIST.sh data -l 5000 -i 3
+ - ./runGAN-MNIST.sh data -i 3
+ - ./runIris.sh
+   #- hlint .

examples/grenade-examples.cabal

@@ -15,8 +15,6 @@ source-repository head
   type: git
   location: https://github.com/HuwCampbell/grenade.git
 
-library
-
 executable             feedforward
     ghc-options:       -Wall -threaded -O2
     main-is:           main/feedforward.hs
@@ -39,37 +37,57 @@ executable             mnist
     ghc-options:       -Wall -threaded -O2
     main-is:           main/mnist.hs
     build-depends:     base
+                     , cereal
                      , grenade
-                     , attoparsec
-                     , either
+                     , filepath
+                     , bytestring
                      , optparse-applicative            >= 0.13       && < 0.16
-                     , text                            == 1.2.*
                      , mtl                             >= 2.2.1      && < 2.3
                      , hmatrix                         >= 0.18       && < 0.21
                      , transformers
                      , semigroups
                      , singletons
                      , MonadRandom
                      , vector
+                     , split
+                     , zlib
+
+executable             iris
+    ghc-options:       -Wall -threaded -O2
+    main-is:           main/iris.hs
+    build-depends:     base
+                     , MonadRandom
+                     , bytestring
+                     , cassava
+                     , filepath
+                     , grenade
+                     , hmatrix                         >= 0.18       && < 0.21
+                     , mtl                             >= 2.2.1      && < 2.3
+                     , optparse-applicative            >= 0.13       && < 0.16
+                     , random-shuffle
+                     , semigroups
+                     , singletons
+                     , transformers
+                     , vector
 
 executable             gan-mnist
     ghc-options:       -Wall -threaded -O2
     main-is:           main/gan-mnist.hs
     build-depends:     base
+                     , cereal
                      , grenade
-                     , attoparsec
+                     , filepath
                      , bytestring
-                     , cereal
-                     , either
                      , optparse-applicative            >= 0.13       && < 0.16
-                     , text                            == 1.2.*
                      , mtl                             >= 2.2.1      && < 2.3
                      , hmatrix                         >= 0.18       && < 0.21
                      , transformers
                      , semigroups
                      , singletons
+                     , split
                      , MonadRandom
                      , vector
+                     , zlib
 
 executable             recurrent
     ghc-options:       -Wall -threaded -O2

examples/main/feedforward.hs

@@ -91,9 +91,7 @@ feedForward' =
 main :: IO ()
 main = do
     FeedForwardOpts examples rate load save <- execParser (info (feedForward' <**> helper) idm)
-    net0 <- case load of
-      Just loadFile -> netLoad loadFile
-      Nothing -> randomNet
+    net0 <- maybe randomNet netLoad load
 
     net <- netTrain net0 rate examples
     netScore net

examples/main/gan-mnist.hs

@@ -4,7 +4,6 @@
 {-# LANGUAGE GADTs                 #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
 {-# LANGUAGE TypeOperators         #-}
-{-# LANGUAGE TupleSections         #-}
 {-# LANGUAGE TypeFamilies          #-}
 {-# LANGUAGE FlexibleContexts      #-}
 
@@ -39,23 +38,27 @@
 import           Control.Applicative
 import           Control.Monad
 import           Control.Monad.Random
-import           Control.Monad.Trans.Except
 
-import qualified Data.Attoparsec.Text as A
-import qualified Data.ByteString as B
+import           Codec.Compression.GZip ( decompress )
+import           Data.Serialize ( Get )
+import qualified Data.Serialize as Serialize
+import qualified Data.ByteString.Lazy as B
+
 import           Data.List ( foldl' )
+import           Data.List.Split ( chunksOf )
+import           Data.Maybe ( fromMaybe )
 #if ! MIN_VERSION_base(4,13,0)
 import           Data.Semigroup ( (<>) )
 #endif
-import           Data.Serialize
-import qualified Data.Text as T
-import qualified Data.Text.IO as T
+
+import           Data.Word ( Word32 , Word8 )
 import qualified Data.Vector.Storable as V
 
 import qualified Numeric.LinearAlgebra.Static as SA
 import           Numeric.LinearAlgebra.Data ( toLists )
 
 import           Options.Applicative
+import           System.FilePath ( (</>) ) 
 
 import           Grenade
 import           Grenade.Utils.OneHot
@@ -104,11 +107,13 @@ trainExample rate discriminator generator realExample noiseSource
    in ( newDiscriminator, newGenerator )
 
 
-ganTest :: (Discriminator, Generator) -> Int -> FilePath -> LearningParameters -> ExceptT String IO (Discriminator, Generator)
-ganTest (discriminator0, generator0) iterations trainFile rate = do
-  trainData      <- fmap fst <$> readMNIST trainFile
+ganTest :: (Discriminator, Generator) -> Int -> FilePath -> LearningParameters -> IO (Discriminator, Generator)
+ganTest (discriminator0, generator0) iterations dataDir rate = do
+  -- Note that for this example we use only the samples, and not the labels
+  trainData      <- fmap fst <$> readMNIST (dataDir </> "train-images-idx3-ubyte.gz")
+                                           (dataDir </> "train-labels-idx1-ubyte.gz")
 
-  lift $ foldM (runIteration trainData) ( discriminator0, generator0 ) [1..iterations]
+  foldM (runIteration trainData) ( discriminator0, generator0 ) [1..iterations]
 
     where
 
@@ -127,10 +132,9 @@ ganTest (discriminator0, generator0) iterations trainFile rate = do
 
   runIteration :: [S ('D2 28 28)] -> (Discriminator, Generator) -> Int -> IO (Discriminator, Generator)
   runIteration trainData ( !discriminator, !generator ) _ = do
-    trained'    <- foldM ( \(!discriminatorX, !generatorX ) realExample -> do
-                      fakeExample <- randomOfShape
-                      return $ trainExample rate discriminatorX generatorX realExample fakeExample
-                     ) ( discriminator, generator ) trainData
+    trained'    <- foldM ( \(!discriminatorX, !generatorX ) realExample ->
+                             trainExample rate discriminatorX generatorX realExample <$> randomOfShape )
+                         ( discriminator, generator ) trainData
 
 
     showShape' . snd . runNetwork (snd trained') =<< randomOfShape
@@ -140,7 +144,7 @@ ganTest (discriminator0, generator0) iterations trainFile rate = do
 data GanOpts = GanOpts FilePath Int LearningParameters (Maybe FilePath) (Maybe FilePath)
 
 mnist' :: Parser GanOpts
-mnist' = GanOpts <$> argument str (metavar "TRAIN")
+mnist' = GanOpts <$> argument str (metavar "DATADIR")
                  <*> option auto (long "iterations" <> short 'i' <> value 15)
                  <*> (LearningParameters
                        <$> option auto (long "train_rate" <> short 'r' <> value 0.01)
@@ -159,27 +163,69 @@ main = do
     Just loadFile -> netLoad loadFile
     Nothing -> (,) <$> randomDiscriminator <*> randomGenerator
 
-  res <- runExceptT $ ganTest nets0 iter mnist rate
-  case res of
-    Right nets1 -> case save of
-      Just saveFile -> B.writeFile saveFile $ runPut (put nets1)
-      Nothing -> return ()
-
-    Left err -> putStrLn err
-
-readMNIST :: FilePath -> ExceptT String IO [(S ('D2 28 28), S ('D1 10))]
-readMNIST mnist = ExceptT $ do
-  mnistdata <- T.readFile mnist
-  return $ traverse (A.parseOnly parseMNIST) (T.lines mnistdata)
+  nets1 <- ganTest nets0 iter mnist rate
+  case save of
+    Just saveFile -> B.writeFile saveFile $ Serialize.runPutLazy (Serialize.put nets1)
+    Nothing -> return ()
+
+
+-- Adapted from https://github.com/tensorflow/haskell/blob/master/tensorflow-mnist/src/TensorFlow/Examples/MNIST/Parse.hs
+-- Could also have used Data.IDX, although that uses a different Vector variant from that need for fromStorable
+readMNIST :: FilePath -> FilePath -> IO [(S ( 'D2 28 28), S ( 'D1 10))]
+readMNIST iFP lFP = do
+  labels  <- readMNISTLabels lFP
+  samples <- readMNISTSamples iFP
+  return $ zip
+    (fmap (fromMaybe (error "bad samples") . fromStorable) samples)
+    (fromMaybe (error "bad labels") . oneHot . fromIntegral <$> labels)
+
+-- | Check's the file's endianess, throwing an error if it's not as expected.
+checkEndian :: Get ()
+checkEndian = do
+  magic <- Serialize.getWord32be
+  when (magic `notElem` ([2049, 2051] :: [Word32]))
+    $ error "Expected big endian, but image file is little endian."
+
+-- | Reads an MNIST file and returns a list of samples.
+readMNISTSamples :: FilePath -> IO [V.Vector Double]
+readMNISTSamples path = do
+  raw <- decompress <$> B.readFile path
+  either fail ( return . fmap (V.map normalize) ) $ Serialize.runGetLazy getMNIST raw
+ where
+  getMNIST :: Get [V.Vector Word8]
+  getMNIST = do
+    checkEndian
+    -- Parse header data.
+    cnt    <- fromIntegral <$> Serialize.getWord32be
+    rows   <- fromIntegral <$> Serialize.getWord32be
+    cols   <- fromIntegral <$> Serialize.getWord32be
+    -- Read all of the data, then split into samples.
+    pixels <- Serialize.getLazyByteString $ fromIntegral $ cnt * rows * cols
+    return $ V.fromList <$> chunksOf (rows * cols) (B.unpack pixels)
+
+  normalize :: Word8 -> Double
+  normalize = (/ 255) . fromIntegral
+  -- There are other normalization functions in the literature, such as
+  -- normalize = (/ 0.3081) . (`subtract` 0.1307) . (/ 255) . fromIntegral
+  -- but we need values in the range [0..1] for the showShape' pretty printer
+
+-- | Reads a list of MNIST labels from a file and returns them.
+readMNISTLabels :: FilePath -> IO [Word8]
+readMNISTLabels path = do
+  raw <- decompress <$> B.readFile path
+  either fail return $ Serialize.runGetLazy getLabels raw
+ where
+  getLabels :: Get [Word8]
+  getLabels = do
+    checkEndian
+    -- Parse header data.
+    cnt <- fromIntegral <$> Serialize.getWord32be
+    -- Read all of the labels.
+    B.unpack <$> Serialize.getLazyByteString cnt
 
-parseMNIST :: A.Parser (S ('D2 28 28), S ('D1 10))
-parseMNIST = do
-  Just lab <- oneHot <$> A.decimal
-  pixels   <- many (A.char ',' >> A.double)
-  image    <- maybe (fail "Parsed row was of an incorrect size") pure (fromStorable . V.fromList $ pixels)
-  return (image, lab)
 
 netLoad :: FilePath -> IO (Discriminator, Generator)
 netLoad modelPath = do
   modelData <- B.readFile modelPath
-  either fail return $ runGet (get :: Get (Discriminator, Generator)) modelData
+  either fail return $
+    Serialize.runGetLazy (Serialize.get :: Get (Discriminator, Generator)) modelData