{-# LANGUAGE OverloadedStrings
, DataKinds
, BangPatterns
, TupleSections
, TypeFamilies
, FlexibleContexts #-}
module Pdf.Extract.Spacing
where

-- | This module provides functions for inserting inter-word spaces. A
-- simple rule-based insertion of spaces will work for many texts. But
-- in the case of spaced letters for accentuation, like found in older
-- printings, rule-based insertion might fail. So this module provides
-- an artificial neural network, which can be trained with such cases.

import qualified Data.Text as T
import Data.List
import Data.Maybe
import GHC.Generics hiding (S)
import Control.Lens
import qualified Data.Csv as Csv
import Data.Char
import qualified Data.Vector.Storable as V
import Data.Semigroup
import Grenade
import Grenade.Utils.OneHot
import GHC.TypeNats
import Control.Monad.Random
import Numeric.LinearAlgebra ( maxIndex )
import qualified Numeric.LinearAlgebra.Static as SA
import System.IO
import qualified Data.ByteString.Lazy.Char8 as C8

import Pdf.Extract.Glyph
import Pdf.Extract.Linearize
import Pdf.Extract.Precision

-- * Representation of spaces

-- | Every algorithm for inserting inter-word spaces is considered as
-- a classification algorithm: Each 'Glyph' or 'Char' (or whatever) of
-- a line must be classified either as an item with a space after it,
-- a space before it, spaces around it or as not spaced at all. We use
-- a parametric algebraic data type, `LeftSpacing`, for representing
-- these spacing classes by simply wrapping a glyph or character
-- according to one of these spacing classes.
--
-- We also use 'LeftSpacing' for representing spaces in training and
-- validation data. We can use plain text files with manually verified
-- spaces as training data and transform this plain text into a
-- representation of inter-word spacing using `LeftSpacing`. There are
-- no spaces from the input left in the output characters that are
-- wrapped into 'LeftSpacing'. See 'representSpacesAfter' for such a
-- transformation.
--
-- 'LeftSpacing' is an instance of the functor type class. This
-- enables us to simply use standard 'fmap' to access all the glyph
-- information after space insertion. So in the end, we are free to
-- stack modularized extraction algorithms in whatever order we want.
--
-- Actually only 'SpaceAfter' and 'NoSpace' is used, the others are
-- there for making a conceptionally complete set.
data LeftSpacing a
  = SpaceBefore a               -- ^ Represents a character or 'Glyph'
                                -- with a space before it.
  | SpaceAfter a                -- ^ Represents a character or 'Glyph'
                                -- with a space after it.
  | SpaceAround a               -- ^ Represents a character or 'Glyph'
                                -- with spaces around it.
  | NoSpace a                   -- ^ Represents a character or 'Glyph'
                                -- with neither space before nor after
                                -- it.
  deriving (Show, Eq)

instance Functor LeftSpacing where
  fmap f (SpaceBefore a) = SpaceBefore (f a)
  fmap f (SpaceAfter a) = SpaceAfter (f a)
  fmap f (SpaceAround a) = SpaceAround (f a)
  fmap f (NoSpace a) = NoSpace (f a)

instance Linearizable a => Linearizable (LeftSpacing a) where
  linearize (NoSpace a) = linearizeWithoutState (const ("","")) a
  linearize (SpaceBefore a) = linearizeWithoutState (const (" ","")) a
  linearize (SpaceAfter a) = linearizeWithoutState (const (""," ")) a
  linearize (SpaceAround a) = linearizeWithoutState (const (" "," ")) a

-- | Unwrap a 'LeftSpacing' item.
--
-- Consider using `fmap` instead.
withoutSpace :: LeftSpacing a -> a
withoutSpace (SpaceBefore a) = a
withoutSpace (SpaceAfter a) = a
withoutSpace (NoSpace a) = a

-- | Linearize left spacing text to text.
leftSpacingToText :: [LeftSpacing T.Text] -> T.Text
leftSpacingToText [] = ""
leftSpacingToText ((NoSpace a):xs) = a <> (leftSpacingToText xs)
leftSpacingToText ((SpaceAfter a):xs) = a <> " " <> (leftSpacingToText xs)
leftSpacingToText ((SpaceBefore a):xs) = " " <> a <> (leftSpacingToText xs)

-- | Linearize a line of 'Glyph's to 'T.Text' after space insertion.
leftSpacingGlyphsToText :: Glyph g =>
                           T.Text -- ^ missing text value in glyph data
                        -> [LeftSpacing g]
                        -> T.Text
leftSpacingGlyphsToText missing =
  leftSpacingToText . (map (fmap (fromMaybe missing . text)))

-- * Rule-based insertion of inter-word spaces

-- | Insert spaces on the basis of the size of a glyph. If the
-- distance to the next glyph exceeds the product of the size and a
-- spacing factor, insert a space. In Antiqua scripts (english print)
-- a space was traditionally (at least) a third of the size of a
-- letter. So 1/3 is a good factor to start with.
sizeSpacingFactor :: Glyph g => Double -> [g] -> [LeftSpacing g]
sizeSpacingFactor _ [] = []
sizeSpacingFactor _ (g:[]) = [NoSpace g]
sizeSpacingFactor spacing (g:gn:gs)
  | dist > spacing * (size g)
  = (SpaceAfter g) : sizeSpacingFactor spacing (gn:gs)
  | otherwise
  = (NoSpace g) : sizeSpacingFactor spacing (gn:gs)
  where
    dist = abs((xLeft gn) - (width g) - (xLeft g))

-- | Insert spaces on the basis of the width of a glyph. If the
-- distance to the next glyph exceeds the product of the width and a
-- spacing factor, insert a space.
widthSpacingFactor :: Glyph g => Double -> [g] -> [LeftSpacing g]
widthSpacingFactor _ [] = []
widthSpacingFactor _ (g:[]) = [NoSpace g]
widthSpacingFactor spacing (g:gn:gs)
  | dist > spacing * (width g)
  = (SpaceAfter g) : widthSpacingFactor spacing (gn:gs)
  | otherwise
  = (NoSpace g) : widthSpacingFactor spacing (gn:gs)
  where
    dist = abs((xLeft g) - (xLeft gn))

-- * Artificial neural network for inserting inter-word spaces

-- | Represent training and validation data. This reads a text
-- (`String`) and wraps every character into the `LeftSpacing`
-- functor. Spaces from input string are removed from the output list,
-- but are represented by the functor.
representSpacesAfter :: [Char] -> [LeftSpacing Char]
representSpacesAfter [] = []
representSpacesAfter (x:[])
  | x == ' ' = []
  | otherwise = (NoSpace x):[]
representSpacesAfter (x:x2:xs)
  | x == ' ' = representSpacesAfter (x2:xs) -- drop leading space
  | x2 == ' ' = (SpaceAfter x) : (representSpacesAfter xs)
  | otherwise = (NoSpace x) : (representSpacesAfter (x2:xs))

-- | Helper function for cleaning plain text for training.
cleanForSpaceTraining :: T.Text -> [T.Text]
cleanForSpaceTraining =
  map (T.filter (/=chr 12)) .    -- remove form feeds
  filter (/="") .                -- remove empty lines
  filter (/=(T.pack [chr 12])) . -- remove lines containing form feed
                                 -- only, e.g. last line
  T.lines                        -- split into lines

-- | Validate that the text in a line of input data and in a line of
-- training data is the same.
validateSameText :: Glyph g => [g] -> [LeftSpacing Char] -> Bool
validateSameText glyphs gold =
  (T.concat $ map (fromMaybe "" . text) glyphs) ==
  (T.pack $ map withoutSpace gold)

-- | Generate a data vector from a 'Glyph'.
singleGlyphSpacingVector :: Glyph g => g -> V.Vector Double
singleGlyphSpacingVector g =
  V.fromList $
  [ (width g) / (size g)
  , (size g) / (width g)
  , fromIntegral $ fromEnum $ (size g) < (width g)
  , fromIntegral $ fromEnum $ (size g) == (width g)
  , fromIntegral $ fromEnum $ (size g) > (width g)
  -- , charFeature ord g -- ordinal, causes noise in data and bad results
  , charFeature (fromEnum . isUpper) g
  , charFeature (fromEnum . isLower) g
  , charFeature (fromEnum . (`elem` (",;:.!?"::[Char]))) g
  -- FIXME: make fit for french punctuation
  ]
  where
    charFeature f = fromIntegral . (fromMaybe 0 . (fmap (f . T.head))) . text

-- | Generate data vectors from a line of 'Glyph's by moving a window
-- over the line. The number of preceding and succeeding glyphs,
-- i.e. the size of the window, is set by the first two
-- arguments.
--
-- Missing predecessors (in the beginning of a line) or missing
-- successors (at the end of a line) are represented as missing by
-- one-hot encoded presence/missing vector entries. See
-- 'mkSpacingVector' for details.
mkSpacingVectors
  :: Glyph g =>
     Int                             -- ^ number of preceding glyphs in window
  -> Int                             -- ^ number of succeeding glyphs in window
  -> [g]                             -- ^ the line's glyphs
  -> [V.Vector Double]               -- ^ a vector of float values for each glyph
mkSpacingVectors pre succ gs =
  take (length gs) $ drop pre $
  fst $
  foldr moveWindow ([], (take pre $ repeat Nothing)) $
  ((take pre $ repeat Nothing) ++ (map Just gs) ++ (take succ $ repeat Nothing))
  where
    moveWindow :: Glyph g =>
                  Maybe g
               -> ([V.Vector Double], [Maybe g])
               -> ([V.Vector Double], [Maybe g])
    moveWindow curr (vecs, oldWindow) = ((mkSpacingVector newWindow):vecs, newWindow)
      where
        newWindow = take (pre + succ + 1) (curr:oldWindow)

-- | Make a data vector from a window on some glyphs.
mkSpacingVector :: Glyph g =>
                   [Maybe g]    -- ^ the glyphs in the moving window
                -> V.Vector Double
mkSpacingVector [] = V.empty
mkSpacingVector (g:[]) = V.concat
  [ V.singleton $ fromIntegral $ fromEnum $ isJust g
  , V.singleton $ fromIntegral $ fromEnum $ isNothing g
  , fromMaybe (V.fromList $ take lenSingleVector $ repeat 0.0) $
    fmap singleGlyphSpacingVector g
  ]
  where
    -- SHAPE: adjust to length of singleGlyphSpacingVector
    lenSingleVector = 8
mkSpacingVector (g1:g2:gs) = V.concat
  [ mkSpacingVector (g1:[])
  , (V.singleton $ fromMaybe 0.0 $ (/) <$> dist <*> fmap width g1)
  , mkSpacingVector (g2:gs)
  ]
  where
    dist = spaceBetween <$> g1 <*> g2

-- | Calculate the horizontal space in between two glyphs.
spaceBetween :: (Glyph g) => g -> g -> Double
spaceBetween g1 g2 = abs $ (xLeft g2) - (xRight g1) -- FIXME?

-- | Bring data vectors into shape for training or testing an
-- ANN. This shapes a pair of 'Glyph' vector and 'LeftSpacing'
-- character.
trainingShape :: KnownNat n =>
                 LeftSpacing Char -- ^ label data, i.e. a character wrapped into 'LeftSpacing'
              -> V.Vector Double  -- ^ a data vector
              -> Maybe (S ('D1 n), SpacingOutput)
-- trainingShape (NoSpace _) v = (,) <$> (fromStorable v) <*> oneHot 0
-- trainingShape (SpaceAfter _) v = (,) <$> (fromStorable v) <*> oneHot 1
-- trainingShape (SpaceBefore _) v = (,) <$> (fromStorable v) <*> oneHot 1 -- FIXME: if ever used
-- trainingShape (SpaceAround _) v = (,) <$> (fromStorable v) <*> oneHot 1 -- FIXME: if ever used
trainingShape sp v = (,) <$> (fromStorable v) <*> (oneHot $ leftSpacingToLabel sp)

-- | Make one-hot encoding labels from 'LeftSpacing'.
leftSpacingToLabel :: LeftSpacing a -> Int
leftSpacingToLabel (NoSpace _) = 0
leftSpacingToLabel _ = 1

-- | Return a 'LeftSpacing' constructor for an integer label.
leftSpacingFromLabel :: Int -> (a -> LeftSpacing a)
leftSpacingFromLabel 0 = NoSpace
leftSpacingFromLabel _ = SpaceAfter

-- | Verify training data (or testing data) and generate shaped data
-- for a grenade network using n preceding and m succeeding glyphs,
-- where n and m are given as arguments. This takes a line of text
-- from the set of training data and the corresponding line of glyphs
-- as arguments. The verification tests if both lines contain the same
-- sequence of characters. It is also verified, that a shape was
-- generated for each input glyph.
--
-- If the verification fails, a 'Left' value is returned with an error
-- string.
--
-- Note that this is a generic function. You should use a closure with
-- a type signature like follows to make your shapes of data for a
-- defined number of preceding and succeeding glyphs:
--
-- @myTrainingShapes :: (Glyph g) = T.Text -> [g] -> Either String [(S ('D1 65), SpacingOutput)]@
-- @myTrainingShapes = mkTrainingShapes 0 5@
mkTrainingShapes
  :: (KnownNat n, Glyph g) =>
     Int                    -- ^ number of predecessors in window
  -> Int                    -- ^ number of successors in window
  -> T.Text                 -- ^ a line of text from the training data
  -> [g]                    -- ^ a line of glyphs
  -> Either String [(S ('D1 n), SpacingOutput)]
mkTrainingShapes pre succ txtLine glyphs' =
  join $
  fmap ((ifEitherP
         ((== (length unspacedLine)) . length)
         (const "Error while generating training data: input vector does not fit into shape")
         id) .
        catMaybes .
        (map (uncurry trainingShape)) .
        (zip unspacedLine) .
        (mkSpacingVectors pre succ)) $
  ifEitherP
  ((==(map withoutSpace unspacedLine)) . T.unpack . glyphsTxt)
  (T.unpack .
   T.concat .
   ([ "Error: Line of training data does not match PDF line\n"
       , "Training data:\n"
       , txtLine
       , "\nPDF data:\n"] ++) .
   (:[]) .
   glyphsTxt)
  id
  glyphs
  where
    ifEitherP p l r val
      | p val = Right $ r val
      | otherwise = Left $ l val
    unspacedLine = representSpacesAfter $ T.unpack txtLine
    glyphs = sortOn xLeft glyphs'
    glyphsTxt = T.concat . mapMaybe text -- glyphs

-- | Generate shaped training data with a window showing 2
-- predecessors and 2 successor.
mkTrainingShapes22
  :: (Glyph g) =>
     T.Text                 -- ^ a line of text from the training data
  -> [g]                    -- ^ a line of glyphs
  -> Either String [SpacingRow]
mkTrainingShapes22 = mkTrainingShapes 2 2

-- | Generate shaped data to be run through the network. This is a
-- generic function for generating shaped data with n preceeding and m
-- succeeding glyphs.
mkRunningShapes
  :: (KnownNat n, Glyph g) =>
     Int                    -- ^ number of predecessors in window
  -> Int                    -- ^ number of successors in window
  -> [g]                    -- ^ a line of glyphs
  -> Either String [S ('D1 n)]
mkRunningShapes pre succ glyphs =
  ifEitherP
  ((== (length glyphs)) . length)
  (const "Error while generating data: input vector does not fit into shape")
  id $
  catMaybes $
  map fromStorable $
  mkSpacingVectors pre succ glyphs
  where
    ifEitherP p l r val
      | p val = Right $ r val
      | otherwise = Left $ l val

-- | Generate shaped data for a network with 2 predecessors and 2
-- successors.
mkRunningShapes22 :: Glyph g => [g] -> Either String [SpacingShape]
mkRunningShapes22 = mkRunningShapes 2 2

-- | The shape of data input into the ANN.
--
-- Note that this must be determined from the length of the vector
-- returned by 'singleGlyphSpacingVector', 'mkSpacingVector' and the
-- number of preceding and succeeding glyphs in 'mkTrainingShapes'.
type SpacingShape = S ('D1 54)

-- | The shape of data output from the ANN.
type SpacingOutput = S ('D1 2)

-- | The shape of training data for the ANN.
type SpacingRow = (SpacingShape, SpacingOutput)

-- | The ANN for inserting inter-word spaces.
type SpacingNet
  = Network
    '[ FullyConnected 54 216, Logit,
       FullyConnected 216 216, Logit,
       FullyConnected 216 216, Logit,
       -- FullyConnected 216 216, Logit,
       FullyConnected 216 2, Logit]
    '[ 'D1 54, 'D1 216, 'D1 216,
       'D1 216, 'D1 216,
       'D1 216, 'D1 216,
       -- 'D1 216, 'D1 216,
       'D1 2, 'D1 2]

-- | A net with random weights.
randomSpacingNet :: MonadRandom m => m SpacingNet
randomSpacingNet = randomNetwork

-- | Run a single iteration learning the network.
runSpacingIteration
  :: Handle                     -- ^ a file handle for logging
  -> [SpacingRow]               -- ^ training data
  -> Maybe [SpacingRow]         -- ^ validation data (or Nothing)
  -> LearningParameters         -- ^ learning rate
  -> SpacingNet                 -- ^ the current network
  -> Int                        -- ^ iteration number
  -> IO SpacingNet              -- ^ returns a new network
runSpacingIteration log trainRows validateRows rate net i = do
  let trained' = foldl' (trainEach ( rate { learningRate = learningRate rate * 0.9 ^ i} )) net trainRows
      tRes = fmap (\(rowP,rowL) -> (rowL,) $ runNet trained' rowP) trainRows
      tRes' = fmap (\(S1D label, S1D prediction) -> ( maxIndex (SA.extract label)
                                                    , maxIndex (SA.extract prediction))) tRes
      vRes = fmap (fmap (\(rowP,rowL) -> (rowL,) $ runNet trained' rowP)) validateRows
      vRes' = fmap (fmap (\(S1D label, S1D prediction) ->
                            ( maxIndex (SA.extract label)
                            , maxIndex (SA.extract prediction)))) vRes
  C8.putStr $
    Csv.encode $ (:[]) $
    (precisionLabel 1 tRes'
     & prec_goldStandard .~ (Just "training data")
     & prec_method .~ (Just "2pre2post"))
  case vRes' of
    Nothing -> do
      return ()
    Just res -> do
      C8.putStr $
        Csv.encode $ (:[]) $
        (precisionLabel 1 res
         & prec_goldStandard .~ (Just "validation data")
         & prec_method .~ (Just "2pre2post"))
  return trained'
  where
    trainEach rate' !network (i, o) = train rate' network i o

-- | Run the trained network a line of 'Glyph's. The glyphs should be
-- sorted like in 'linearizeLine'.
runSpacingNetOnLine
  :: (Glyph g) =>
     SpacingNet
  -> [g]
  -> Either String [LeftSpacing g]
runSpacingNetOnLine network glyphs =
  fmap ((map (uncurry (runSpacingNet network))) .
        (zip glyphs)) $
  mkRunningShapes22 glyphs

-- | Run the trained network on input data.
runSpacingNet :: SpacingNet -> a -> SpacingShape -> LeftSpacing a
runSpacingNet net char input =
  spaceFromLabel char $ runNet net input

-- | Evaluate the output from the network.
spaceFromLabel :: a -> SpacingOutput -> LeftSpacing a
spaceFromLabel char (S1D label) = mkSpace char $ maxIndex $ SA.extract label
  where
    mkSpace char 0 = NoSpace char
    mkSpace char 1 = SpaceAfter char


{-# LANGUAGE BangPatterns, RecordWildCards #-}
-- |
-- Module      : Criterion
-- Copyright   : (c) 2009-2014 Bryan O'Sullivan
--
-- License     : BSD-style
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : GHC
--
-- Core benchmarking code.

module Criterion.Internal
    (
      runAndAnalyse
    , runAndAnalyseOne
    , runNotAnalyse
    , addPrefix
    ) where

import Control.DeepSeq (rnf)
import Control.Exception (evaluate)
import Control.Monad (foldM, forM_, void, when)
import Control.Monad.Reader (ask, asks)
import Control.Monad.Trans (liftIO)
import Control.Monad.Trans.Either
import Data.Binary (encode)
import Data.Int (Int64)
import qualified Data.ByteString.Lazy as L
import Criterion.Analysis (analyseSample, noteOutliers)
import Criterion.IO (header, hGetReports)
import Criterion.IO.Printf (note, printError, prolix, writeCsv)
import Criterion.Measurement (runBenchmark, secs)
import Criterion.Monad (Criterion)
import Criterion.Report (report)
import Criterion.Types hiding (measure)
import Criterion.Versus (vscsv, versusReports, VersusReport(..))
import qualified Data.Map as Map
import Statistics.Resampling.Bootstrap (Estimate(..))
import System.Directory (getTemporaryDirectory, removeFile)
import System.IO (IOMode(..), SeekMode(..), hClose, hSeek, openBinaryFile,
                  openBinaryTempFile)
import Text.Printf (printf)

-- | Run a single benchmark and analyse its performance.
runAndAnalyseOne :: Int -> String -> Benchmarkable -> Criterion Report
runAndAnalyseOne i desc bm = do
  Config{..} <- ask
  (meas,timeTaken) <- liftIO $ runBenchmark bm timeLimit
  when (timeTaken > timeLimit * 1.25) .
    void $ prolix "measurement took %s\n" (secs timeTaken)
  _ <- prolix "analysing with %d resamples\n" resamples
  erp <- runEitherT $ analyseSample i desc meas
  case erp of
    Left err -> printError "*** Error: %s\n" err
    Right rpt@Report{..} -> do
      let SampleAnalysis{..} = reportAnalysis
          OutlierVariance{..} = anOutlierVar
          wibble = case ovEffect of
                     Unaffected -> "unaffected" :: String
                     Slight -> "slightly inflated"
                     Moderate -> "moderately inflated"
                     Severe -> "severely inflated"
          (builtin, others) = splitAt 1 anRegress
      let r2 n = printf "%.3f R\178" n
      forM_ builtin $ \Regression{..} ->
        case Map.lookup "iters" regCoeffs of
          Nothing -> return ()
          Just t  -> bs secs "time" t >> bs r2 "" regRSquare
      bs secs "mean" anMean
      bs secs "std dev" anStdDev
      forM_ others $ \Regression{..} -> do
        _ <- bs r2 (regResponder ++ ":") regRSquare
        forM_ (Map.toList regCoeffs) $ \(prd,val) ->
          bs (printf "%.3g") ("  " ++ prd) val
      writeCsv csvFile (desc,
                        estPoint anMean, estLowerBound anMean, estUpperBound anMean,
                        estPoint anStdDev, estLowerBound anStdDev,
                        estUpperBound anStdDev)
      when (verbosity == Verbose || (ovEffect > Slight && verbosity > Quiet)) $ do
        when (verbosity == Verbose) $ noteOutliers reportOutliers
        _ <- note "variance introduced by outliers: %d%% (%s)\n"
             (round (ovFraction * 100) :: Int) wibble
        return ()
      _ <- note "\n"
      return rpt
      where bs :: (Double -> String) -> String -> Estimate -> Criterion ()
            bs f metric Estimate{..} =
              note "%-20s %-10s (%s .. %s%s)\n" metric
                   (f estPoint) (f estLowerBound) (f estUpperBound)
                   (if estConfidenceLevel == 0.95 then ""
                    else printf ", ci %.3f" estConfidenceLevel)

-- | Run, and analyse, one or more benchmarks.
runAndAnalyse :: (String -> Bool) -- ^ A predicate that chooses
                                  -- whether to run a benchmark by its
                                  -- name.
              -> Benchmark
              -> Criterion ()
runAndAnalyse p bs' = do
  mbRawFile <- asks rawDataFile
  (rawFile, handle) <- liftIO $
    case mbRawFile of
      Nothing -> do
        tmpDir <- getTemporaryDirectory
        openBinaryTempFile tmpDir "criterion.dat"
      Just file -> do
        handle <- openBinaryFile file ReadWriteMode
        return (file, handle)
  liftIO $ L.hPut handle header

  let go (!k, !vr) (pfx, Environment mkenv mkbench) = do
        e <- liftIO $ do
               ee <- mkenv
               evaluate (rnf ee)
               return ee
        go (k, vr) (pfx, mkbench e)
      go (!k, !vr) (pfx, Benchmark desc b)
          | p desc'   = do _ <- note "benchmarking %s\n" desc'
                           rpt <- runAndAnalyseOne k desc' b
                           liftIO $ L.hPut handle (encode rpt)
                           return $! (k + 1, vr)
          | otherwise = return (k :: Int, vr)
          where desc' = addPrefix pfx desc
      go (!k, !vr) (pfx, BenchGroup desc bs) =
          foldM go (k, vr) [(addPrefix pfx desc, b) | b <- bs]
      go (!k, !vr) (pfx, BenchVersus desc envs algs)
         | p desc'   = do
             envs' <- mapM mkEnv envs
             liftIO $ evaluate $ rnf envs'
             let indices = [(a, e, aN, eN) | (aN, a) <- algs
                                           , (eN, e) <- envs']
                 vs = VersusReport {
                     vsReportDescription = desc'
                   , vsReportData = []
                   , vsReportDataPoints = map fst envs
                   , vsReportIndices = [((aN, eN), i)|
                                        (i, (_, _, aN, eN)) <- zip [k..] indices]
                   }
             (k', _) <- foldM go (k, [])
                        [(desc', bench name $ a e)
                        | (a, e, aN, eN) <- indices
                        , let name = aN ++ "/" ++ show eN]
             return (k', vs:vr)
         | otherwise = return (k :: Int, vr)
         where desc' = addPrefix pfx desc
               mkEnv (t, mkenv) = liftIO $ do
                 e <- mkenv
                 return (t, e)
  (_, vsRpts) <- go (0, []) ("", bs')

  rpts <- (either fail return =<<) . liftIO $ do
    hSeek handle AbsoluteSeek 0
    rs <- hGetReports handle
    hClose handle
    case mbRawFile of
      Just _ -> return rs
      _      -> removeFile rawFile >> return rs
  let vsRpts' = versusReports vsRpts rpts
  report rpts vsRpts'
  junit rpts
  vscsv vsRpts'

-- | Run a benchmark without analysing its performance.
runNotAnalyse :: Int64            -- ^ Number of loop iterations to run.
              -> (String -> Bool) -- ^ A predicate that chooses
                                  -- whether to run a benchmark by its
                                  -- name.
              -> Benchmark
              -> Criterion ()
runNotAnalyse iters p bs' = goQuickly "" bs'
  where goQuickly :: String -> Benchmark -> Criterion ()
        goQuickly pfx (Environment mkenv mkbench) = do
            e <- liftIO mkenv
            goQuickly pfx (mkbench e)
        goQuickly pfx (Benchmark desc b)
            | p desc'   = do _ <- note "benchmarking %s\n" desc'
                             runOne b
            | otherwise = return ()
            where desc' = addPrefix pfx desc
        goQuickly pfx (BenchGroup desc bs) =
            mapM_ (goQuickly (addPrefix pfx desc)) bs
        goQuickly pfx (BenchVersus desc envs algs) = do
            envs' <- mapM mkEnv envs
            liftIO $ evaluate $ rnf envs'
            mapM_ (goQuickly pfx') [bench name $ a e
                                   | (aN, a) <- algs, (eN, e) <- envs'
                                   , let name = aN ++ "/" ++ show eN]
            where mkEnv (t, mkenv) = liftIO $ do
                    e <- mkenv
                    return (t, e)
                  pfx' = addPrefix pfx desc

        runOne (Benchmarkable run) = liftIO (run iters)

-- | Add the given prefix to a name.  If the prefix is empty, the name
-- is returned unmodified.  Otherwise, the prefix and name are
-- separated by a @\'\/\'@ character.
addPrefix :: String             -- ^ Prefix.
          -> String             -- ^ Name.
          -> String
addPrefix ""  desc = desc
addPrefix pfx desc = pfx ++ '/' : desc

-- | Write summary JUnit file (if applicable)
junit :: [Report] -> Criterion ()
junit rs
  = do junitOpt <- asks junitFile
       case junitOpt of
         Just fn -> liftIO $ writeFile fn msg
         Nothing -> return ()
  where
    msg = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" ++
          printf "<testsuite name=\"Criterion benchmarks\" tests=\"%d\">\n"
          (length rs) ++
          concatMap single rs ++
          "</testsuite>\n"
    single Report{..} = printf "  <testcase name=\"%s\" time=\"%f\" />\n"
               (attrEsc reportName) (estPoint $ anMean $ reportAnalysis)
    attrEsc = concatMap esc
      where
        esc '\'' = "'"
        esc '"'  = """
        esc '<'  = "<"
        esc '>'  = ">"
        esc '&'  = "&"
        esc c    = [c]


{-# LANGUAGE CPP #-}

-- !!! Testing Typeable instances
module Main(main) where

import Data.Dynamic
#if MIN_VERSION_base(4,10,0)
import Data.Typeable (TyCon, TypeRep, typeOf)
#endif
import Data.Array
import Data.Array.MArray
import Data.Array.ST
import Data.Array.IO
import Data.Array.Unboxed
import Data.Complex
import Data.Int
import Data.Word
import Data.IORef
import System.IO
import Control.Monad.ST
import System.Mem.StableName
import System.Mem.Weak
import Foreign.StablePtr
import Control.Exception
import Foreign.C.Types

main :: IO ()
main = do
   print (typeOf (undefined :: [()]))
   print (typeOf (undefined :: ()))
   print (typeOf (undefined :: ((),())))
   print (typeOf (undefined :: ((),(),())))
   print (typeOf (undefined :: ((),(),(),())))
   print (typeOf (undefined :: ((),(),(),(),())))
   print (typeOf (undefined :: (() -> ())))
   print (typeOf (undefined :: (Array () ())))
   print (typeOf (undefined :: Bool))
   print (typeOf (undefined :: Char))
   print (typeOf (undefined :: (Complex ())))
   print (typeOf (undefined :: Double))
   print (typeOf (undefined :: (Either () ())))
   print (typeOf (undefined :: Float))
   print (typeOf (undefined :: Handle))
   print (typeOf (undefined :: Int))
   print (typeOf (undefined :: Integer))
   print (typeOf (undefined :: IO ()))
   print (typeOf (undefined :: (Maybe ())))
   print (typeOf (undefined :: Ordering))

   print (typeOf (undefined :: Dynamic))
   print (typeOf (undefined :: (IORef ())))
   print (typeOf (undefined :: Int8))
   print (typeOf (undefined :: Int16))
   print (typeOf (undefined :: Int32))
   print (typeOf (undefined :: Int64))
   print (typeOf (undefined :: (ST () ())))
   print (typeOf (undefined :: (StableName ())))
   print (typeOf (undefined :: (StablePtr ())))
   print (typeOf (undefined :: TyCon))
   print (typeOf (undefined :: TypeRep))
   print (typeOf (undefined :: Word8))
   print (typeOf (undefined :: Word16))
   print (typeOf (undefined :: Word32))
   print (typeOf (undefined :: Word64))

   print (typeOf (undefined :: ArithException))
   print (typeOf (undefined :: AsyncException))
   print (typeOf (undefined :: (IOArray () ())))
   print (typeOf (undefined :: (IOUArray () ())))
   print (typeOf (undefined :: (STArray () () ())))
   print (typeOf (undefined :: (STUArray () () ())))
   print (typeOf (undefined :: (StableName ())))
   print (typeOf (undefined :: (StablePtr ())))
   print (typeOf (undefined :: (UArray () ())))
   print (typeOf (undefined :: (Weak ())))

   print (typeOf (undefined :: CChar))
   print (typeOf (undefined :: CSChar))
   print (typeOf (undefined :: CUChar))
   print (typeOf (undefined :: CShort))
   print (typeOf (undefined :: CUShort))
   print (typeOf (undefined :: CInt))
   print (typeOf (undefined :: CUInt))
   print (typeOf (undefined :: CLong))
   print (typeOf (undefined :: CULong))
   print (typeOf (undefined :: CLLong))
   print (typeOf (undefined :: CULLong))
   print (typeOf (undefined :: CFloat))
   print (typeOf (undefined :: CDouble))

   print (typeOf (undefined :: CPtrdiff))
   print (typeOf (undefined :: CSize))
   print (typeOf (undefined :: CWchar))
   print (typeOf (undefined :: CSigAtomic))
   print (typeOf (undefined :: CClock))
   print (typeOf (undefined :: CTime))


module SimpleR.R.Parser.Syntax where

import qualified Data.Complex as C

data RSource = Source
  { srcFile :: String
  , srcLine :: Int
  , srcCol :: Int
  } deriving (Eq, Show, Read)

data RIdentAnnot = RIdentAnnot deriving (Eq, Show, Read)

data RIdent = RIdent
  { ridPkg :: Maybe String
  , ridName :: String
  , ridSrc :: Maybe RSource
  , ridAnnot :: Maybe RIdentAnnot
  } deriving (Eq, Show, Read)

data RNumeric =
    RNumInt Int
  | RNumNaInt
  | RNumFloat Double
  | RNumNaFloat
  | RNumComplex (C.Complex Double)
  | RNumNaComplex
  deriving (Eq, Show, Read)

data RBool =
    RBool Bool
  | RNaBool
  deriving (Eq, Show, Read)

data RString =
    RString String
  | RNaString
  deriving (Eq, Show, Read)

data RUnOp =
    RUMinus
  | RUPlus
  | RUNot
  | RUForm
  | RUHelp
  deriving (Eq, Show, Read)

data RBinOp =
    RPlus | RMinus | RMult | RDiv | RPow | RMod | RIntDiv
  | RGt | RGe | RLt | RLe | REq | RNeq
  | RAnd | RAndVec | ROr | ROrVec
  | RMatrixMult | ROuterProd | RKronProd
  | RAssignArrow | RSuperAssignArrow
  | RObjAttrGet
  | RRange
  | RForm
  | RGetPackage
  | RGetPackageInt
  | RMatch
  | RHelp

  | RColonAssign
  deriving (Eq, Show, Read)

data RParam =
    RParam RIdent
  | RDefault RIdent RExpr
  | RVarParam
  deriving (Eq, Show, Read)

data RArg =
    RExprArg RExpr
  | RIdentAssign RIdent RExpr
  | RIdentAssignEmpty RIdent
  | RStringAssign RString RExpr
  | RStringAssignEmpty RString
  | RNullAssign RExpr
  | RNullAssignEmpty
  | RVarArg
  deriving (Eq, Show, Read)

data RConst =
    RNumConst RNumeric
  | RStrConst RString
  | RBoolConst RBool
  | RNaConst
  deriving (Eq, Show, Read)

data RExpr =
    RConst RConst
  | RVar RIdent
  | RNull
  | RUnOp RUnOp RExpr
  | RBinOp RBinOp RExpr RExpr
  | RFunCall RExpr [RArg]
  | RFunDef [RParam] RExpr
  | RSeq [RExpr]

  | RVecProj RExpr [RArg]
  | RVecSub RExpr [RArg]
  | RListName RExpr RExpr
  | RObjAttr RExpr RExpr

  | RIf RExpr RExpr
  | RIfElse RExpr RExpr RExpr
  | RFor RIdent RExpr RExpr
  | RWhile RExpr RExpr
  | RRepeat RExpr
  | RNext
  | RBreak
  deriving (Eq, Show, Read)

data RProgram = RProgram [RExpr] deriving (Eq, Show, Read)

ppRProg :: RProgram -> String
ppRProg (RProgram rexprs) =
  "RProgram [\n" ++ concatMap (\e -> show e ++ ",\n") rexprs ++ "]"


{-# language
        BangPatterns
      , CPP
      , GeneralizedNewtypeDeriving
      , InstanceSigs
      , MagicHash
      , ScopedTypeVariables
      , StandaloneDeriving
      , UnboxedTuples
  #-}

#if __GLASGOW_HASKELL__ >= 800
{-# language TypeInType #-}
#endif

{-# OPTIONS_GHC
      -Weverything
      -fno-warn-unsafe
      -fno-warn-orphans
      -fno-warn-name-shadowing
      -fno-warn-missing-import-lists
      -fno-warn-implicit-prelude
      -O2
#-}

-- | Orphan instances for the 'Prim' typeclass.
module Data.Primitive.Instances () where

import Data.Complex (Complex(..))
#if !MIN_VERSION_primitive(0,7,0)
import Data.Functor.Const (Const(..))
#if MIN_VERSION_base(4,8,0)
import Data.Functor.Identity (Identity(..))
#endif
import qualified Data.Monoid as Monoid
import qualified Data.Semigroup as Semigroup
import Data.Ord (Down(..))
#endif
import Data.Primitive.Types (Prim(..), defaultSetOffAddr#, defaultSetByteArray#)
import GHC.Real (Ratio(..))
import Data.Word (Word64)
import GHC.Fingerprint (Fingerprint(..))
import GHC.Exts (State#, Int#, Addr#, MutableByteArray#, (+#), (*#))

instance Prim a => Prim (Complex a) where
  sizeOf# _ = 2# *# sizeOf# (undefined :: a)
  alignment# _ = alignment# (undefined :: a)
  indexByteArray# arr# i# =
    let x,y :: a
        x = indexByteArray# arr# (2# *# i#)
        y = indexByteArray# arr# (2# *# i# +# 1#)
    in x :+ y
  readByteArray# :: forall s a. (Prim a) => MutableByteArray# s -> Int# -> State# s -> (# State# s, Complex a #)
  readByteArray# arr# i# =
    \s0 -> case readByteArray# arr# (2# *# i#) s0 of
      (# s1#, x #) -> case readByteArray# arr# (2# *# i# +# 1#) s1# of
        (# s2#, y #) -> (# s2#, x :+ y #)
  writeByteArray# :: forall s a. (Prim a) => MutableByteArray# s -> Int# -> Complex a -> State# s -> State# s
  writeByteArray# arr# i# (a :+ b) =
    \s0 -> case writeByteArray# arr# (2# *# i#) a s0 of
      s1 -> case writeByteArray# arr# (2# *# i# +# 1#) b s1 of
        s2 -> s2
  setByteArray# = defaultSetByteArray#
  indexOffAddr# :: Addr# -> Int# -> Complex a
  indexOffAddr# addr# i# =
    let x,y :: a
        x = indexOffAddr# addr# (2# *# i#)
        y = indexOffAddr# addr# (2# *# i# +# 1#)
    in x :+ y
  readOffAddr# :: forall s a. (Prim a) => Addr# -> Int# -> State# s -> (# State# s, Complex a #)
  readOffAddr# addr# i# =
    \s0 -> case readOffAddr# addr# (2# *# i#) s0 of
      (# s1, x #) -> case readOffAddr# addr# (2# *# i# +# 1#) s1 of
        (# s2, y #) -> (# s2, x :+ y #)
  writeOffAddr# :: forall s a. (Prim a) => Addr# -> Int# -> Complex a -> State# s -> State# s
  writeOffAddr# addr# i# (a :+ b) =
    \s0 -> case writeOffAddr# addr# (2# *# i#) a s0 of
      s1 -> case writeOffAddr# addr# (2# *# i# +# 1#) b s1 of
        s2 -> s2
  setOffAddr# = defaultSetOffAddr#
  {-# INLINE sizeOf# #-}
  {-# INLINE alignment# #-}
  {-# INLINE indexByteArray# #-}
  {-# INLINE readByteArray# #-}
  {-# INLINE writeByteArray# #-}
  {-# INLINE setByteArray# #-}
  {-# INLINE indexOffAddr# #-}
  {-# INLINE readOffAddr# #-}
  {-# INLINE writeOffAddr# #-}
  {-# INLINE setOffAddr# #-}

instance (Integral a, Prim a) => Prim (Ratio a) where
  sizeOf# _ = 2# *# sizeOf# (undefined :: a)
  alignment# _ = alignment# (undefined :: a)
  indexByteArray# arr# i# =
    let x,y :: a
        x = indexByteArray# arr# (2# *# i#)
        y = indexByteArray# arr# (2# *# i# +# 1#)
    in x :% y
  readByteArray# :: forall s a. (Prim a) => MutableByteArray# s -> Int# -> State# s -> (# State# s, Ratio a #)
  readByteArray# arr# i# =
    \s0 -> case readByteArray# arr# (2# *# i#) s0 of
      (# s1#, x #) -> case readByteArray# arr# (2# *# i# +# 1#) s1# of
        (# s2#, y #) -> (# s2#, x :% y #)
  writeByteArray# :: forall s a. (Prim a) => MutableByteArray# s -> Int# -> Ratio a -> State# s -> State# s
  writeByteArray# arr# i# (a :% b) =
    \s0 -> case writeByteArray# arr# (2# *# i#) a s0 of
      s1 -> case writeByteArray# arr# (2# *# i# +# 1#) b s1 of
        s2 -> s2
  setByteArray# = defaultSetByteArray#
  indexOffAddr# :: Addr# -> Int# -> Ratio a
  indexOffAddr# addr# i# =
    let x,y :: a
        x = indexOffAddr# addr# (2# *# i#)
        y = indexOffAddr# addr# (2# *# i# +# 1#)
    in x :% y
  readOffAddr# :: forall s a. (Prim a) => Addr# -> Int# -> State# s -> (# State# s, Ratio a #)
  readOffAddr# addr# i# =
    \s0 -> case readOffAddr# addr# (2# *# i#) s0 of
      (# s1, x #) -> case readOffAddr# addr# (2# *# i# +# 1#) s1 of
        (# s2, y #) -> (# s2, x :% y #)
  writeOffAddr# :: forall s a. (Prim a) => Addr# -> Int# -> Ratio a -> State# s -> State# s
  writeOffAddr# addr# i# (a :% b) =
    \s0 -> case writeOffAddr# addr# (2# *# i#) a s0 of
      s1 -> case writeOffAddr# addr# (2# *# i# +# 1#) b s1 of
        s2 -> s2
  setOffAddr# = defaultSetOffAddr#
  {-# INLINE sizeOf# #-}
  {-# INLINE alignment# #-}
  {-# INLINE indexByteArray# #-}
  {-# INLINE readByteArray# #-}
  {-# INLINE writeByteArray# #-}
  {-# INLINE setByteArray# #-}
  {-# INLINE indexOffAddr# #-}
  {-# INLINE readOffAddr# #-}
  {-# INLINE writeOffAddr# #-}
  {-# INLINE setOffAddr# #-}

instance Prim Fingerprint where
  sizeOf# _ = 2# *# sizeOf# (undefined :: Word64)
  alignment# _ = alignment# (undefined :: Word64)
  indexByteArray# arr# i# =
    let x,y :: Word64
        x = indexByteArray# arr# (2# *# i#)
        y = indexByteArray# arr# (2# *# i# +# 1#)
    in Fingerprint x y
  readByteArray# :: forall s. MutableByteArray# s -> Int# -> State# s -> (# State# s, Fingerprint #)
  readByteArray# arr# i# =
    \s0 -> case readByteArray# arr# (2# *# i#) s0 of
      (# s1#, x #) -> case readByteArray# arr# (2# *# i# +# 1#) s1# of
        (# s2#, y #) -> (# s2#, Fingerprint x y #)
  writeByteArray# :: forall s. MutableByteArray# s -> Int# -> Fingerprint -> State# s -> State# s
  writeByteArray# arr# i# (Fingerprint a b) =
    \s0 -> case writeByteArray# arr# (2# *# i#) a s0 of
      s1 -> case writeByteArray# arr# (2# *# i# +# 1#) b s1 of
        s2 -> s2
  setByteArray# = defaultSetByteArray#
  indexOffAddr# :: Addr# -> Int# -> Fingerprint
  indexOffAddr# addr# i# =
    let x,y :: Word64
        x = indexOffAddr# addr# (2# *# i#)
        y = indexOffAddr# addr# (2# *# i# +# 1#)
    in Fingerprint x y
  readOffAddr# :: forall s. Addr# -> Int# -> State# s -> (# State# s, Fingerprint #)
  readOffAddr# addr# i# =
    \s0 -> case readOffAddr# addr# (2# *# i#) s0 of
      (# s1, x #) -> case readOffAddr# addr# (2# *# i# +# 1#) s1 of
        (# s2, y #) -> (# s2, Fingerprint x y #)
  writeOffAddr# :: forall s. Addr# -> Int# -> Fingerprint -> State# s -> State# s
  writeOffAddr# addr# i# (Fingerprint a b) =
    \s0 -> case writeOffAddr# addr# (2# *# i#) a s0 of
      s1 -> case writeOffAddr# addr# (2# *# i# +# 1#) b s1 of
        s2 -> s2
  setOffAddr# = defaultSetOffAddr#
  {-# INLINE sizeOf# #-}
  {-# INLINE alignment# #-}
  {-# INLINE indexByteArray# #-}
  {-# INLINE readByteArray# #-}
  {-# INLINE writeByteArray# #-}
  {-# INLINE setByteArray# #-}
  {-# INLINE indexOffAddr# #-}
  {-# INLINE readOffAddr# #-}
  {-# INLINE writeOffAddr# #-}
  {-# INLINE setOffAddr# #-}

#if !MIN_VERSION_primitive(0,7,0)

deriving instance Prim a => Prim (Down a)
#if MIN_VERSION_base(4,8,0)
deriving instance Prim a => Prim (Identity a)
deriving instance Prim a => Prim (Monoid.Dual a)
deriving instance Prim a => Prim (Monoid.Sum a)
deriving instance Prim a => Prim (Monoid.Product a)
#endif
#if MIN_VERSION_base(4,9,0)
deriving instance Prim a => Prim (Semigroup.First a)
deriving instance Prim a => Prim (Semigroup.Last a)
deriving instance Prim a => Prim (Semigroup.Min a)
deriving instance Prim a => Prim (Semigroup.Max a)
#endif
deriving instance Prim a => Prim (Const a b)

#endif


{-# LANGUAGE OverloadedStrings #-}

module ML.Gym.Shape
  ( GymShape (..)
  , getGymShape
  ) where

import           ML.Gym.DType
import           ML.Gym.Util

import qualified Control.Exception        as E
import           Control.Monad            (join, void)
import qualified CPython                  as Py
import qualified CPython.Constants        as Py
import qualified CPython.Protocols.Object as Py
import qualified CPython.Types            as Py
import qualified CPython.Types.Exception  as Py
import qualified CPython.Types.Module     as Py
import qualified Data.ByteString          as BS
import           Data.Complex             (Complex)
import           Data.Maybe               (fromMaybe)
import qualified Data.Text                as T
import           System.Environment       (getArgs, getProgName)
import           System.Exit
import           System.IO
import           System.Random            (randomRIO)

data GymShape = GymShape1D Integer
              | GymShape2D Integer Integer
              | GymShape3D Integer Integer Integer
              deriving (Show, Eq)

getGymShape :: Py.Object space => space -> IO (Maybe GymShape)
getGymShape space = do
  let err = error "could not get gym shape"
  sh <- shape space >>= pyToTupleList >>= fmap (join . fmap sequence) . traverse (mapM pyToInteger)
  return $ mkGymShape <$> (sh :: Maybe [Integer])
  where mkGymShape [x1]     = GymShape1D x1
        mkGymShape [x1, x2] = GymShape2D x1 x2
        mkGymShape [x1, x2, x3] = GymShape3D x1 x2 x3
        mkGymShape xs       = error $ "Gym shape '" ++ show xs ++ "' not supported yet!"

shape :: Py.Object space => space -> IO Py.SomeObject
shape space = python (Py.toUnicode "shape" >>= Py.getAttribute space)


{-# LANGUAGE FlexibleContexts, UndecidableInstances #-}

module School.Train.TrainState
( HandlerStore(..)
, TrainState(..)
, def
) where

import Data.Default.Class (Default(..))
import Numeric.LinearAlgebra (Container, Vector)
import School.Types.PingPong (PingPong, pingPongSingleton)
import School.Unit.UnitParams (UnitParams(..))

data HandlerStore a = CostList [a]
                    | NoStore deriving (Eq, Show)

data TrainState a = TrainState
  { handlerStore :: HandlerStore a
  , iterationCount :: Int
  , learningRate :: a
  , paramDerivs :: [UnitParams a]
  , paramList :: PingPong (UnitParams a)
  } deriving (Show)

instance (Container Vector a, Eq a, Num a) => Eq (TrainState a) where
  s1 == s2 = handlerStore s1 == handlerStore s2
          && iterationCount s1 == iterationCount s2
          && learningRate s1 == learningRate s2
          && paramDerivs s1 == paramDerivs s2
          && paramList s1 == paramList s2

instance (Num a) => Default (TrainState a) where
  def = TrainState { handlerStore = NoStore
                   , iterationCount = 0
                   , learningRate = 0
                   , paramDerivs = []
                   , paramList = pingPongSingleton EmptyParams
                   }


-- |
-- Module      :  SysmonHints
-- Copyright   :  (c) Vitaliy Rukavishnikov 2011
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  virukav@gmail.com
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Generate the Sysmon hints (suggestions) by comparing the data from sysmon
-- report to the corresponding data from the configuration.

module Database.Sybase.Sysmon.SysmonHints where
import Database.Sybase.Sysmon.Log
import Database.Sybase.Sysmon.LogTypes
import Database.Sybase.Sysmon.SysmonTypes
import Text.Printf
import Statistics.Sample
import Control.Monad.Reader
import Data.Vector (fromList)
import Data.ConfigFile
import Data.Either.Utils (forceEither)

type HintEnv a = Reader HConfig a

-- | Default configuration. To override the default configuration item
-- use ConfigFile package API.
defConfig = forceEither $ do
  let cp = emptyCP

  cp <- set cp "DEFAULT" "hiCPU" (show 85.0)
  cp <- set cp "DEFAULT" "hiIO" (show 50.0)
  cp <- set cp "DEFAULT" "hiIdle" (show 30.0)
  cp <- set cp "DEFAULT" "hiCheckDiskIO" (show 50.0)
  cp <- set cp "DEFAULT" "loCacheHits" (show 90.0)
  cp <- set cp "DEFAULT" "hiCacheWash" (show 5.0)
  cp <- set cp "DEFAULT" "loLargeIO" (show 90.0)
  cp <- set cp "DEFAULT" "loAvgDiskIO" (show 0.005)
  cp <- set cp "DEFAULT" "hiStdDeviation" (show 30.0)
  cp <- set cp "DEFAULT" "hiSwitchPerTransaction" (show 60.0)
  cp <- set cp "DEFAULT" "hiContextSwitchDue" (show 10.0)
  cp <- set cp "DEFAULT" "hiDirtyBuffers" (show 3.0)
  cp <- set cp "DEFAULT" "hiUlcSemRequests" (show 10.0)
  cp <- set cp "DEFAULT" "hiLogSemRequests" (show 10.0)
  cp <- set cp "DEFAULT" "hiAvgLogWrites" (show 1.0)
  cp <- set cp "DEFAULT" "hiCommitedTrans" (show 50)
  cp <- set cp "DEFAULT" "hiPageSplits" (show 10)
  cp <- set cp "DEFAULT" "hiLockSummary" (show 10.0)
  cp <- set cp "DEFAULT" "hiDeadlock" (show 10.0)
  cp <- set cp "DEFAULT" "hiLastPageLock" (show 10.0)
  cp <- set cp "DEFAULT" "hiLockPromotions" (show 20)
  cp <- set cp "DEFAULT" "loCacheSpinContention" (show 10.0)
  cp <- set cp "DEFAULT" "ioDelayBy" "Disk"
  return cp

-- | Create Sysmon configuration from ConfigParser
mkConfig :: ConfigParser -> HConfig
mkConfig c = let cp = Data.ConfigFile.merge defConfig c in
  HConfig {
    hiCPU = forceEither $ get cp "Sysmon" "hiCPU",
    hiIO = forceEither $ get cp "Sysmon" "hiIO",
    hiIdle = forceEither $ get cp "Sysmon" "hiIdle",
    hiCheckDiskIO = forceEither $ get cp "Sysmon" "hiCheckDiskIO",
    loCacheHits = forceEither $ get cp "Sysmon" "loCacheHits",
    hiCacheWash = forceEither $ get cp "Sysmon" "hiCacheWash",
    loLargeIO = forceEither $ get cp "Sysmon" "loLargeIO",
    loAvgDiskIO = forceEither $ get cp "Sysmon" "loAvgDiskIO",
    hiStdDeviation = forceEither $ get cp "Sysmon" "hiStdDeviation",
    hiSwitchPerTransaction = forceEither $ get cp "Sysmon" "hiSwitchPerTransaction",
    hiContextSwitchDue = forceEither $ get cp "Sysmon" "hiContextSwitchDue",
    hiDirtyBuffers = forceEither $ get cp "Sysmon" "hiDirtyBuffers",
    hiUlcSemRequests = forceEither $ get cp "Sysmon" "hiUlcSemRequests",
    hiLogSemRequests = forceEither $ get cp "Sysmon" "hiLogSemRequests",
    hiAvgLogWrites = forceEither $ get cp "Sysmon" "hiAvgLogWrites",
    hiCommitedTrans = forceEither $ get cp "Sysmon" "hiCommitedTrans",
    hiPageSplits = forceEither $ get cp "Sysmon" "hiPageSplits",
    hiLockSummary = forceEither $ get cp "Sysmon" "hiLockSummary",
    hiDeadlock = forceEither $ get cp "Sysmon" "hiDeadlock",
    hiLastPageLock = forceEither $ get cp "Sysmon" "hiLastPageLock",
    hiLockPromotions = forceEither $ get cp "Sysmon" "hiLockPromotions",
    loCacheSpinContention = forceEither $ get cp "Sysmon" "loCacheSpinContention",
    ioDelayBy = forceEither $ get cp "Sysmon" "ioDelayBy"
  }

eval :: Sysmon -> HintEnv [Hint]
eval s = do
   e <- ask
   let results = [(id, foldResult [r s e | r <- rs] (&&), action) |
                  (id, rs, action) <- fs
                 ]
   return [(id,action,facts) | (id, (b, facts), action) <- results, b]

sysmonHints :: ConfigParser -> Sysmon -> [Hint]
sysmonHints cnf s = runReader (eval s) (mkConfig cnf)

percent i t = fromIntegral i / fromIntegral t * 100.0

result :: (LogShow a) => Bool -> [String] -> [a] -> Result
result b fs ys = (b, [f ++ " = " ++ lshow y | (f,y) <- zip fs ys, b])

foldResult :: [Result] -> (Bool -> Bool -> Bool) -> Result
foldResult ds cond = foldr1 f ds where
    f (b, s) (b', s') = (cond b b', if b then s ++ s' else s')

-- | Kernel contention
checkCpuBusy s e =
     let busy = avgCpuBusy $ kernel s
         b = busy >= hiCPU e in
       result b ["CPU Busy"] [busy]

checkCpuIdle s e =
     let busy = avgCpuBusy $ kernel s
         b = busy <= 100.0 - hiCPU e in
       result b ["CPU Idle"] [100.0 - busy]

checkIOEngine s e =
     let iobusy = avgIOBusy $ kernel s
         cpubusy = avgCpuBusy $ kernel s
         b = iobusy >= hiIO e && cpubusy <= (100.0 - hiCPU e) in
       result b ["Engine IO Busy", "Engine CPU Busy"] [iobusy, cpubusy]

checkIODisk s e =
    let checkIO = checkDiskIO $ kernel s
        avgIO = avgDiskIO $ kernel s
        b = checkIO >= hiCheckDiskIO e && avgIO <= loAvgDiskIO e in
     result b ["Check Disk IO", "Average Disk IO"] [checkIO, avgIO]

-- | Task contention
checkEngineBalance s e =
    let ts = taskSwitch $ task s
        sd = stdDev $ fromList $ map (fromIntegral.numSwitch) ts
        b = sd >= hiStdDeviation e in
     result b ["Standard deviation"] [sd]

checkSwitchesPerTran s e =
    let ts = totSwitch $ task s
        tr = commited $ transaction s
        pt = if tr == 0 then 0
               else fromIntegral ts / fromIntegral tr
        b = pt >= hiSwitchPerTransaction e in
      result b ["Context switches per transaction"] [pt]

checkContextSwitches s e =
     let sw = taskSwitchDue $ task s
         cs = [(cacheSearchMiss, "Cache Search Misses"),
               (diskWrites, "System Disk Writes"),
               (batchSize, "Exceeding I/O batch size"),
               (logicLockCont, "Logical Lock Contention"),
               (addrLockCont, "Address Lock Contention"),
               (latchCont, "Latch Contention"),
               (semCont, "Log Semaphore Contention"),
               (plcLockCont, "PLC Lock Contention"),
               (lastLogPage, "Last Log Page Writes"),
               (conflicts, "Modify Conflicts"),
               (deviceCont, "I/O Device Contention"),
               (netSent, "Network Packet Sent"),
               (netServices, "Network services"),
               (other, "Other Causes")
              ]

         conv (f, x) = let res = percent (f sw) (totSwitchDue sw) in (x, res)
         rs = unzip $ filter (\(_,res) -> res >= hiContextSwitchDue e) $
                               map conv cs
         b = not $ null $ fst rs in
       uncurry (result b) rs

-- | Transaction contention
checkUlcCont s e =
     let req = ulsSemReqs $ transaction s
         cont = percent (waited req) (totReq req)
         b = cont >= hiUlcSemRequests e in
      result b ["ULC Semaphore Contention"] [cont]

checkLogCont s e =
     let req = logSemReqs $ transaction s
         cont = percent (waited req) (totReq req)
         b = cont >= hiLogSemRequests e in
      result b ["Log Semaphore Contention"] [cont]

checkAvgLogWrites s e =
     let trans = commited $ transaction s
         avgWrites = avgLogWrites $ transaction s
         b = trans >= hiCommitedTrans e && avgWrites >= hiAvgLogWrites e in
      result b ["Avg # Writes per Log Page"] [avgWrites]

-- | Index contention
checkPageCont s e =
     let cont = splits $ index s
         b = cont >= hiPageSplits e in
      result b ["Page Splits"] [cont]

-- | Lock contention
checkLockCont s e =
     let cont = percent (lockCont $ lock s) (lockReqs $ lock s)
         b = cont >= hiLockSummary e in
      result b ["Average Lock Contention"] [cont]

checkDeadlocks s e =
     let cont = percent (deadlocks $ lock s) (lockReqs $ lock s)
         b = cont >= hiDeadlock e in
       result b ["Deadlock Percentage"] [cont]

checkLastPageLocks s e =
      let cont = percent (waited $ lpLock $ lock s) (totReq $ lpLock $ lock s)
          b = cont >= hiLastPageLock e in
       result b ["Last Page Lock"] [cont]

checkLockPromotion s e =
      let b = promotions (lock s) >= hiLockPromotions e in
       result b ["Lock Promotions"] [promotions $ lock s]

-- | Cache contention
verifyNamedCache cache field valid msg  =
     let res c = (cacheName c, field c)
         ps = map res (caches cache)
         cs = unzip $ filter (\(_, val) -> valid val) ps
         b = not $ null $ fst cs in
       result b (map (++ msg) $ fst cs) (snd cs)

checkCacheTurnover s e =
      let db = (dirtyBuffers.cache) s
          b = db >= hiDirtyBuffers e in
        result b ["Buffers Grabbed Dirty"] [db]

checkSpinCont s e =
      let valid val = val > 0 && val <= loCacheSpinContention e in
        verifyNamedCache (cache s) spinContention valid ".Spinlock contention"

checkCacheHits s e =
      let valid val = val > 0 && val <= loCacheHits e
          field c = percent (hits c) (totHitsMiss c) in
         verifyNamedCache (cache s) field valid ".Hits"

checkCacheWash s e =
      let valid val = val >= hiCacheWash e
          field c = percent (wash c) (totHitsMiss c) in
         verifyNamedCache (cache s) field valid ".Wash"

checkCacheLargeIO s e =
       let valid val = val <= loLargeIO e
           field c = percent (largeIO c) (largeIOTotal c) in
         verifyNamedCache (cache s) field valid ".Large IO"

-- | Group checks
checkIOBusy s e =
     let checkset = [checkIOEngine, checkIODisk] in
       foldResult [r s e | r <- checkset] (&&)

checkResourceCont s e =
      let checkset = [checkContextSwitches, checkSpinCont, checkUlcCont,
                     checkLogCont, checkPageCont, checkLockCont] in
       foldResult [r s e | r <- checkset] (||)

-- | Sysmon rules
fs =
   [
   ("ruleMoreEngines",
     [checkCpuBusy, checkResourceCont],
     "Consider to increase the number of engines"),
   ("ruleLessEngines",
     [checkCpuIdle],
     "Consider to decrease the number of engines"),
   ("rulesEnginesBalance",
     [checkEngineBalance],
     "Engines are unbalanced regarding task context switches"),
   ("ruleSwitchPerTransaction",
     [checkSwitchesPerTran],
     "The increasing number of the context switches  per transaction"),
   ("ruleContextSwitchDue",
     [checkContextSwitches],
     "Consider resources tuning to decrease the context switches due to"),
   ("ruleIOBusy",
     [checkIOBusy],
     "The job is IO bound"),
   ("ruleCacheContention",
    [checkCacheTurnover,
     checkSpinCont,
     checkCacheHits,
     checkCacheWash,
     checkCacheLargeIO],
    "Cache contention"),
   ("ruleLockContention",
     [checkLockCont,
      checkDeadlocks,
      checkLastPageLocks,
      checkLockPromotion],
     "Lock contention")
   ]


-- (C) Copyright Chris Banks 2011-2012

-- This file is part of The Continuous Pi-calculus Workbench (BondCalculusWB).

--     BondCalculusWB is free software: you can redistribute it and/or modify
--     it under the terms of the GNU General Public License as published by
--     the Free Software Foundation, either version 3 of the License, or
--     (at your option) any later version.

--     BondCalculusWB is distributed in the hope that it will be useful,
--     but WITHOUT ANY WARRANTY; without even the implied warranty of
--     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--     GNU General Public License for more details.

--     You should have received a copy of the GNU General Public License
--     along with BondCalculusWB.  If not, see <http://www.gnu.org/licenses/>.

module BioCalcLib.Plot
    (plot, plotD, plotToFile, layout, plots, plotPhaseToFile, plotPhase,
     plotPhaseD, plotphase, layout2phase, colours
    ) where

import Graphics.Rendering.Chart
import Graphics.Rendering.Chart.Gtk
import Graphics.Rendering.Chart.Backend.Cairo
import Data.Colour.Names
import Data.Colour.SRGB
import Data.Colour
-- import Data.Accessor
import Data.Default.Class
import Control.Lens
import qualified Control.Exception as X
import qualified Numeric.LinearAlgebra as LA
import Control.Monad
import Graphics.UI.Gtk.Misc.DrawingArea
import qualified Data.List as L

import BioCalcLib.Lib

-- Plots the time series in a GTK window
plot :: [Double] -> [(String,[Double])] -> IO ()
plot ts dims = renderableToWindow (toRenderable (layout ts dims)) 639 480

plotD  :: DrawingArea -> [Double] -> [(String,[Double])] -> IO ()
plotD da ts dims = do
  _ <- updateCanvas (toRenderable (layout ts dims)) da
  return ()

-- Plots the time series to a file
plotToFile :: [Double] -> [(String,[Double])] -> String -> IO ()
plotToFile ts dims file = void $ renderableToFile (FileOptions (842, 595) PDF) file (toRenderable (layout ts dims))

-- gets a plot layout with plots for each dimension
layout :: [Double] -> [(String, [Double])] -> Layout Double Double
layout ts dims = layout_plots .~ plots ts (colours (length dims)) dims
  $ def
                 -- layout1_legend ^= Nothing $ {-remove to add legend-}

-- gets the plots for each dimension
-- plots :: [Double] -> [AlphaColour Double] -> [(String,[Double])] ->
--          [Either (Plot Double Double) b]
plots :: [Double] -> [AlphaColour Double] -> [(String,[Double])] ->
         [Plot Double Double]
plots _ _ [] = []
plots ts (colour:cs) ((lbl,pts):dims)
    = toPlot
      ( plot_lines_style .~ solidLine 1 colour
      $ plot_lines_values .~ [zip ts pts]
      $ plot_lines_title .~ lbl
      $ def
      ) : plots ts cs dims
plots _ [] _ = X.throw $ CpiException
               "BondCalculus.Plot.plots: Run out of colours!"

---------------
-- Phase plots:
---------------

plotPhaseToFile :: [(String, [Double])] -> String -> IO ()
plotPhaseToFile dims file = void $ renderableToFile
                                   (FileOptions (842, 595) PDF) file
                                   (toRenderable (layout2phase dims))

-- getRender :: LA.Vector Double -> LA.Matrix Double -> [Species] -> [Species] -> Int -> Int -> (Maybe (Render ()))
-- getRender  ts soln ss ss' ww wh = (Just $ runBackend (defaultEnv bitmapAlignmentFns)
--            ( void $ render (getLayout ts soln ss ss') (fromIntegral ww, fromIntegral wh) )
--          )

plotPhase :: PlotValue y0 => [(String, [y0])] -> IO ()
plotPhase dims = renderableToWindow (toRenderable (layout2phase dims)) 640 480

plotPhaseD  :: DrawingArea -> [(String,[Double])] -> IO ()
plotPhaseD da dims = void $ updateCanvas (toRenderable (layout2phase dims)) da

plotphase :: [(x, y)] -> Plot x y
plotphase pts
    = toPlot
      $ plot_lines_values .~ [pts]
      $ plot_lines_style .~ solidLine 1 (opaque blue)
      $ def

layout2phase :: PlotValue y0 => [(String, [y0])] -> Layout y0 y0
layout2phase dims
    = layout_plots .~ [plotphase $ zip (snd (head dims)) (snd (dims!!1))]
--      $ layout1_bottom_axis ^: laxis_generate ^= autoScaledLogAxis defaultLogAxis
      $ layout_x_axis . laxis_title .~ "["++fst (head dims)++"]"
--      $ layout1_left_axis ^: laxis_generate ^= autoScaledLogAxis defaultLogAxis
      $ layout_y_axis . laxis_title .~ "["++fst (dims!!1)++"]"
      $ def

-------------------

-- gives n visually distinct colours
-- algorithm taken from the MATLAB 'varycolor' function
-- by Daniel Helmick: http://j.mp/xowLV2
colours :: Int -> [AlphaColour Double]
colours n
    | n<=0 = []
    | n==1 = [clr 0 1 0]
    | n==2 = [clr 0 1 0,clr 0 1 1]
    | n==3 = [clr 0 1 0,clr 0 1 1,clr 0 0 1]
    | n==4 = [clr 0 1 0,clr 0 1 1,clr 0 0 1,clr 1 0 1]
    | n==5 = [clr 0 1 0,clr 0 1 1,clr 0 0 1,clr 1 0 1,clr 1 0 0]
    | n==6 = [clr 0 1 0,clr 0 1 1,clr 0 0 1,clr 1 0 1,clr 1 0 0,clr 0 0 0]
    | otherwise = sec (1::Integer) ++ sec 2 ++ sec 3 ++ sec 4 ++ sec 5
    where
      s = fromIntegral(n `div` 5)
      e = fromIntegral(n `mod` 5)
      f x y
          | x<=y = 1.0
          | otherwise = 0.0
      g x = [1..(s + f x e)]
      sec x
          | x==1 = [clr 0 1 ((m-1)/(s + f x e - 1)) | m<-g x]
          | x==2 = [clr 0 ((s + f x e - m)/(s + f x e)) 1 | m<-[1..(s + f x e)]]
          | x==3 = [clr (m/(s + f x e)) 0 1 | m<-[1..(s + f x e)]]
          | x==4 = [clr 1 0 ((s + f x e - m)/(s + f x e)) | m<-[1..(s + f x e)]]
          | x==5 = [clr ((s + f x e - m)/(s + f x e)) 0 0 | m<-[1..(s + f x e)]]
          | otherwise = undefined

clr :: Double -> Double -> Double -> AlphaColour Double
clr r g b = opaque $ sRGB r g b

{-- test data
testT = [0.0,0.1..2500.0]::[Double]
testD1 = [0,0.1..2500]::[Double]
testD2 = [x*x|x<-[0,0.1..2500]]::[Double]

testPlot1 = plot_lines_style ^= solidLine 1 (opaque $ sRGB 0.5 0.5 1)
            $ plot_lines_values ^= [zip testT testD1]
            $ plot_lines_title ^= "test1"
            $ defaultPlotLines

testPlot2 = plot_lines_style ^= solidLine 1 (opaque red)
            $ plot_lines_values ^= [zip testT testD2]
            $ plot_lines_title ^= "test2"
            $ defaultPlotLines

testLayout = layout1_title ^= "Test graph!"
             $ layout1_plots ^= [Left (toPlot testPlot1),
                                 Left (toPlot testPlot2)]
             $ defaultLayout1

testPlot = renderableToWindow (toRenderable testLayout) 640 480
-}


{-# OPTIONS  #-}
-----------------------------------------------------------------------------
-- |
-- Module      : Language.Scheme.R5RS.Parser.Token
-- Copyright   : (c) Tyler Prete
-- License     : BSD-style
-- Maintainer  : psyonic@gmail.com
-- Stability   : experimental
-- Portability : ghc
--
-- Lexical tokens for the Scheme R5RS lexer.
-- See: <http://people.csail.mit.edu/jaffer/r5rs_9.html#SEC72>
-----------------------------------------------------------------------------

module Language.Scheme.R5RS.Parser.Token ( Token (..) )
where
import Language.Scheme.R5RS.Syntax.Expression (Number)
--import Data.Complex -- for Complex Float

-- | Lexical tokens.
data Token
    -- Identifier
    = Identifier !String
    | Boolean Bool
    | Number Number
    | Character Char
    | String !String
    | LeftParen
    | RightParen
    | PoundLeftParen
    | Tick
    | BackTick
    | Comma
    | CommaAt
    | Dot
    deriving (Eq, Show, Ord)


{-# OPTIONS_GHC -Wall #-}

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}

module Data.NutMeg
    ( NutMeg (..)
    , NutPlot (..)
    , NutWave (..)
    , NutPlotType (..)
    , NutField (..)
    , nutFieldName, nutFieldName'
    , bytesPerReal, bytesPerReal'
    , bytesPerComplex, bytesPerComplex'
    , popNutElement
    , readNutRealRow, readNutComplexRow
    , nutPlot, nutFlag, nutWave
    , nutRealWave, asRealVector
    , nutComplexWave, asComplexVector
    , flattenRealPlots
    , flattenComplexPlots
    , parseNutPlot
    , parseNutMeg
    , readNutRaw
    -- , encodeNutPlot
    ) where

import           Data.Maybe
import           Data.Int
import           Data.Complex
import           Data.Binary.Get
import qualified Data.Map.Strict       as M
import qualified Data.ByteString       as BS
import qualified Data.ByteString.Char8 as CS
import qualified Data.ByteString.Lazy  as BL
import qualified Data.Vector.Unboxed   as V
import qualified Data.Matrix.Unboxed   as A

-- | NutMeg wave form data dypes
data NutWave = NutRealWave    {-# UNPACK #-} !(V.Vector Double)
             | NutComplexWave {-# UNPACK #-} !(V.Vector (Complex Double))
    deriving (Show, Eq)

nutWave :: NutWave -> Either (V.Vector (Complex Double)) (V.Vector Double)
nutWave (NutRealWave nw) = Right nw
nutWave (NutComplexWave nw) = Left nw

nutRealWave :: NutWave -> Maybe (V.Vector Double)
nutRealWave (NutRealWave nw) = Just nw
nutRealWave _                = Nothing

asRealVector :: NutWave -> V.Vector Double
asRealVector (NutRealWave nw) = nw
asRealVector _                = undefined

concatRealWaves :: [NutWave] -> NutWave
concatRealWaves = NutRealWave . V.concat . map asRealVector

joinRealWaves :: NutWave -> NutWave -> NutWave
joinRealWaves a b = concatRealWaves [a, b]

flattenRealPlots :: [NutPlot] -> NutPlot
flattenRealPlots nps = let { nutPlotName  = pn'
                           ; nutNumVars   = nv'
                           ; nutNumPoints = np'
                           ; nutVariables = vn'
                           ; nutPlotType  = pt'
                           ; nutData      = dt'
                           } in NutPlot { .. }
  where fp = head nps
        pn' = nutPlotName fp
        nv' = nutNumVars fp
        np' = nutNumPoints fp
        vn' = nutVariables fp
        pt' = nutPlotType fp
        dt' = M.unionsWith joinRealWaves (map nutData nps)

nutComplexWave :: NutWave -> Maybe (V.Vector (Complex Double))
nutComplexWave (NutComplexWave nw) = Just nw
nutComplexWave _                   = Nothing

asComplexVector :: NutWave -> V.Vector (Complex Double)
asComplexVector (NutComplexWave nw) = nw
asComplexVector _                   = undefined

concatComplexWaves :: [NutWave] -> NutWave
concatComplexWaves = NutComplexWave . V.concat . map asComplexVector

joinComplexWaves :: NutWave -> NutWave -> NutWave
joinComplexWaves a b = concatComplexWaves [a, b]

flattenComplexPlots :: [NutPlot] -> NutPlot
flattenComplexPlots nps = let { nutPlotName  = pn'
                              ; nutNumVars   = nv'
                              ; nutNumPoints = np'
                              ; nutVariables = vn'
                              ; nutPlotType  = pt'
                              ; nutData      = dt'
                              } in NutPlot { .. }
  where fp = head nps
        pn' = nutPlotName fp
        nv' = nutNumVars fp
        np' = nutNumPoints fp
        vn' = nutVariables fp
        pt' = nutPlotType fp
        dt' = M.unionsWith joinRealWaves (map nutData nps)

-- | Real and Complex NutMeg plots
data NutPlotType = NutRealPlot | NutComplexPlot
    deriving (Show, Eq)

-- | Convert a flag from file to plot type
nutFlag :: String -> NutPlotType
nutFlag "complex" = NutComplexPlot
nutFlag "real"    = NutRealPlot
nutFlag _         = undefined

-- | Data Fields in NutMeg Files
data NutField = NutTitle
              | NutDate
              | NutPlotname
              | NutFlags
              | NutNoVariables
              | NutNoPoints
              | NutVariables
              | NutBinData
    deriving (Show, Eq, Enum, Ord, Bounded)

-- Alternaitve Show instance calling `nutFieldName`.
-- instance Show NutField where
--   show nfn = CS.unpack . nutFieldName $ nfn

-- | Translate fieldname to ByteString representation in NutMeg file.
nutFieldName :: NutField -> BS.ByteString
nutFieldName NutTitle       = "Title:"
nutFieldName NutDate        = "Date:"
nutFieldName NutPlotname    = "Plotname:"
nutFieldName NutFlags       = "Flags:"
nutFieldName NutNoVariables = "No. Variables:"
nutFieldName NutNoPoints    = "No. Points:"
nutFieldName NutVariables   = "Variables:"
nutFieldName NutBinData     = "Binary:"

-- | Convenient Transformer to Lazy ByteString
nutFieldName' :: NutField -> BL.ByteString
nutFieldName' = BL.fromStrict . nutFieldName

-- | A 'plot' as it is represented within the NutMeg File format.
data NutPlot = NutPlot { nutPlotName  :: String
                       , nutNumVars   :: Int
                       , nutNumPoints :: Int
                       , nutVariables :: [String]
                       , nutPlotType  :: NutPlotType
                       , nutData      :: !(M.Map String NutWave) }
--              | ComplexPlot { nutPlotName    :: String
--                            , nutNumVars     :: Int
--                            , nutNumPoints   :: Int
--                            , nutVariables   :: [String]
--                            , nutPlotType    :: NutPlotType
--                            , complexNutData :: !(M.Map String NutWave) }
    deriving (Show)

-- | Representation of NutMeg file contents, where plot names are mapped to
-- corresponding plot types and data.
data NutMeg = NutMeg { nutTitle :: String
                     , nutDate  :: String
                     , nutPlots :: !(M.Map String NutPlot)}
    deriving (Show)

-- | How many bytes per real data point
bytesPerReal :: Int
bytesPerReal = 8
-- | Convenient transformation to Int64 for certain calculations
bytesPerReal' :: Int64
bytesPerReal' = fromIntegral bytesPerReal

-- | How many bytes per complex data point
bytesPerComplex :: Int
bytesPerComplex = 2 * bytesPerReal
-- | Convenient transformation to Int64 for certain calculations
bytesPerComplex' :: Int64
bytesPerComplex' = fromIntegral bytesPerReal

-- | Convenience function for reading a NutMeg File
readNutRaw :: FilePath -> IO BS.ByteString
readNutRaw = BS.readFile

-- | Reads a line from a list of ByteStrings, that starts with a given prefix.
readNutElement' :: BS.ByteString -> [BS.ByteString] -> Maybe String
readNutElement' eid bs = CS.unpack . CS.strip <$> elem' bs
    where elem' = CS.stripPrefix eid . head . filter (BS.isPrefixOf eid)

-- | Takes a `NutField` name and returns the correspinding value.
readNutElement :: NutField -> BS.ByteString -> String
readNutElement nf bs = fromJust $ readNutElement' nfn bls
    where nfn = nutFieldName nf
          bls = CS.lines bs

-- | Read a row of real valued data
readNutRealRow :: Int64 -> Int -> BL.ByteString -> V.Vector Double
readNutRealRow n o = V.fromList . runGet (skip (o * bytesPerReal) >> decoder [])
    where
        o' = fromIntegral (o * bytesPerReal)
        n' = n * bytesPerReal'
        decoder !acc =  do
            !br <- bytesRead
            !be <- isEmpty
            if (br >= (n' + o')) || be
               then return $! reverse acc
               else getDoublebe >>= decoder . (:acc)

-- | Read a row of complex valued data
readNutComplexRow :: Int64 -> Int -> BL.ByteString -> V.Vector (Complex Double)
readNutComplexRow n o = V.fromList . runGet (skip (o * bytesPerComplex) >> decoder)
    where
        o' = fromIntegral (o * bytesPerComplex)
        n' = n * bytesPerComplex'
        decoder =  do
            br <- bytesRead
            be <- isEmpty
            if (br >= (2 * n' + o')) || be
               then return []
               else do !r  <- getDoublebe
                       !c  <- getDoublebe
                       !ds <- decoder
                       return $! ( (r:+c) : ds )

-- vl = [rc (j * nv) | j <- [ 0 .. (np - 1) ]]
-- map V.length vl

-- | Construct NutPlot type
nutPlot :: String -> NutPlotType -> Int -> Int -> [String] -> BL.ByteString -> NutPlot
nutPlot pn nt np nv vn bs
        = NutPlot { nutPlotName  = pn
                  , nutNumVars   = nv
                  , nutNumPoints = np
                  , nutVariables = vn
                  , nutPlotType  = nt
                  , nutData      = M.fromList $ zip vn dt }
    where
      rr = \i -> readNutRealRow (fromIntegral nv) (fromIntegral i) bs
      rc = \i -> readNutComplexRow (fromIntegral nv) (fromIntegral i) bs
      !dt = if nt == NutRealPlot
               then map NutRealWave    . A.toColumns . A.fromRows
                                       $ [rr (j * nv) | j <- [ 0 .. (np - 1) ]]
               else map NutComplexWave . A.toColumns . A.fromRows
                                       $ [rc (j * nv) | j <- [ 0 .. (np - 1) ]]

-- | Get the first NutMeg Element and the Rest
popNutElement :: NutField -> BS.ByteString -> (Maybe BS.ByteString, BS.ByteString)
popNutElement field dat = (elem'', rest)
    where nextField = succ field
          (elem', rest) = BS.breakSubstring (nutFieldName nextField) dat
          elem''        = CS.strip <$> BS.stripPrefix (nutFieldName field) elem'

-- | Extract NutMeg header information
parseNutHeader :: BS.ByteString -> [String]
parseNutHeader = ph NutTitle
    where ph nf bs | BS.null bs = []
                   | (nf == NutTitle) || (nf == NutDate) =
                       let (e, r) = popNutElement nf bs
                        in (CS.unpack . fromJust $ e) : ph (succ nf) r
                   | otherwise = undefined

-- | Extract NutPlot header information.
parseNutPlotHeader :: BS.ByteString -> [String]
parseNutPlotHeader = ph NutPlotname
    where ph nf bs | nf `elem` [ NutPlotname .. NutNoPoints ] =
                       let (e, r) = popNutElement nf bs
                        in (CS.unpack . fromJust $ e) : ph (succ nf) r
                   | otherwise = []

-- | Returns a NutPlot for a given ByteString segment.
parseNutPlot :: BS.ByteString -> NutPlot
parseNutPlot plt = nutPlot pn fl np nv vn dt
    where
      (hdr, dat) = BS.breakSubstring (nutFieldName NutBinData) plt
      hdr'       = parseNutPlotHeader hdr
      pn         = head hdr'
      fl         = nutFlag (hdr' !! 1)
      nv         = read (hdr' !! 2) :: Int
      np         = read (hdr' !! 3) :: Int
      vr         = snd . BS.breakSubstring "\t" . snd
                 . BS.breakSubstring (nutFieldName NutVariables) $ hdr
      vn         = map (CS.unpack . (!!1) . CS.words) $ CS.lines vr
      dt         = BL.fromStrict . fromJust . BS.stripPrefix "Binary:\n" $ dat

-- | Split a nut String at BS.null s
splitNutString :: BS.ByteString -> [NutPlot] -> [NutPlot]
splitNutString bs bl | BS.null bs = bl
                     | otherwise = splitNutString sp (parseNutPlot sl : bl)
                            where Just ps  = BS.stripPrefix pnf bs
                                  (fp, sp) = BS.breakSubstring pnf ps
                                  sl       = BS.concat [pnf, fp]
                                  pnf      = nutFieldName NutPlotname

-- | Returns a NutMeg for given file contents.
parseNutMeg :: BS.ByteString -> NutMeg
parseNutMeg nut = NutMeg { nutTitle = nt
                         , nutDate  = nd
                         , nutPlots = mps }
    where
      (hdr, bdy) = BS.breakSubstring (nutFieldName NutPlotname) nut
      nt         = readNutElement NutTitle hdr
      nd         = readNutElement NutDate hdr
      nps        = splitNutString bdy []
      mps        = M.fromList $ zip (map nutPlotName nps) nps

-- encodeNutPlot :: NutPlot -> ByteString


module ZeroStuff (zeroStuff) where

import IQ
import Data.Complex
import Control.Monad
import Pipes

zeroStuff :: (Monad m, Num a) => Int -> Pipe a a m ()
zeroStuff factor = forever $ await >>= yield >> replicateM_ (factor - 1) (yield 0)
{-# INLINE zeroStuff #-}