diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2012-2015 David Sorokin +Copyright (c) 2012-2017 David Sorokin All rights reserved. diff --git a/Simulation/Aivika/Experiment.hs b/Simulation/Aivika/Experiment.hs --- a/Simulation/Aivika/Experiment.hs +++ b/Simulation/Aivika/Experiment.hs @@ -1,11 +1,11 @@ -- | -- Module : Simulation.Aivika.Experiment --- Copyright : Copyright (c) 2012-2015, David Sorokin +-- Copyright : Copyright (c) 2012-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental --- Tested with: GHC 7.10.1 +-- Tested with: GHC 8.0.1 -- -- This module re-exports the library functionality. -- @@ -13,37 +13,9 @@ module Simulation.Aivika.Experiment (-- * Modules module Simulation.Aivika.Experiment.Types, - module Simulation.Aivika.Experiment.HtmlWriter, - module Simulation.Aivika.Experiment.LastValueView, - module Simulation.Aivika.Experiment.TableView, - module Simulation.Aivika.Experiment.TimingStatsView, - module Simulation.Aivika.Experiment.TimingStatsWriter, - module Simulation.Aivika.Experiment.SamplingStatsWriter, - module Simulation.Aivika.Experiment.FinalStatsView, module Simulation.Aivika.Experiment.Histogram, - module Simulation.Aivika.Experiment.ExperimentSpecsView, - module Simulation.Aivika.Experiment.ExperimentSpecsWriter, - module Simulation.Aivika.Experiment.ExperimentWriter, - module Simulation.Aivika.Experiment.FinalTableView, - module Simulation.Aivika.Experiment.InfoView, - module Simulation.Aivika.Experiment.Utils, - module Simulation.Aivika.Experiment.WebPageRenderer, - module Simulation.Aivika.Experiment.FileRenderer) where + module Simulation.Aivika.Experiment.Utils) where import Simulation.Aivika.Experiment.Types -import Simulation.Aivika.Experiment.HtmlWriter -import Simulation.Aivika.Experiment.LastValueView -import Simulation.Aivika.Experiment.TableView -import Simulation.Aivika.Experiment.TimingStatsView -import Simulation.Aivika.Experiment.TimingStatsWriter -import Simulation.Aivika.Experiment.SamplingStatsWriter -import Simulation.Aivika.Experiment.FinalStatsView import Simulation.Aivika.Experiment.Histogram -import Simulation.Aivika.Experiment.ExperimentSpecsView -import Simulation.Aivika.Experiment.ExperimentSpecsWriter -import Simulation.Aivika.Experiment.ExperimentWriter -import Simulation.Aivika.Experiment.FinalTableView -import Simulation.Aivika.Experiment.InfoView import Simulation.Aivika.Experiment.Utils -import Simulation.Aivika.Experiment.WebPageRenderer -import Simulation.Aivika.Experiment.FileRenderer diff --git a/Simulation/Aivika/Experiment/Base.hs b/Simulation/Aivika/Experiment/Base.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Experiment/Base.hs @@ -0,0 +1,43 @@ + +-- | +-- Module : Simulation.Aivika.Experiment.Base +-- Copyright : Copyright (c) 2012-2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 8.0.1 +-- +-- This module re-exports the library functionality. +-- + +module Simulation.Aivika.Experiment.Base + (-- * Modules + module Simulation.Aivika.Experiment.Base.ExperimentSpecsView, + module Simulation.Aivika.Experiment.Base.ExperimentSpecsWriter, + module Simulation.Aivika.Experiment.Base.ExperimentWriter, + module Simulation.Aivika.Experiment.Base.FileRenderer, + module Simulation.Aivika.Experiment.Base.FinalStatsView, + module Simulation.Aivika.Experiment.Base.FinalTableView, + module Simulation.Aivika.Experiment.Base.HtmlWriter, + module Simulation.Aivika.Experiment.Base.InfoView, + module Simulation.Aivika.Experiment.Base.LastValueView, + module Simulation.Aivika.Experiment.Base.SamplingStatsWriter, + module Simulation.Aivika.Experiment.Base.TableView, + module Simulation.Aivika.Experiment.Base.TimingStatsView, + module Simulation.Aivika.Experiment.Base.TimingStatsWriter, + module Simulation.Aivika.Experiment.Base.WebPageRenderer) where + +import Simulation.Aivika.Experiment.Base.ExperimentSpecsView +import Simulation.Aivika.Experiment.Base.ExperimentSpecsWriter +import Simulation.Aivika.Experiment.Base.ExperimentWriter +import Simulation.Aivika.Experiment.Base.FileRenderer +import Simulation.Aivika.Experiment.Base.FinalStatsView +import Simulation.Aivika.Experiment.Base.FinalTableView +import Simulation.Aivika.Experiment.Base.HtmlWriter +import Simulation.Aivika.Experiment.Base.InfoView +import Simulation.Aivika.Experiment.Base.LastValueView +import Simulation.Aivika.Experiment.Base.SamplingStatsWriter +import Simulation.Aivika.Experiment.Base.TableView +import Simulation.Aivika.Experiment.Base.TimingStatsView +import Simulation.Aivika.Experiment.Base.TimingStatsWriter +import Simulation.Aivika.Experiment.Base.WebPageRenderer diff --git a/Simulation/Aivika/Experiment/Base/ExperimentSpecsView.hs b/Simulation/Aivika/Experiment/Base/ExperimentSpecsView.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Experiment/Base/ExperimentSpecsView.hs @@ -0,0 +1,97 @@ + +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Simulation.Aivika.Experiment.Base.ExperimentSpecsView +-- Copyright : Copyright (c) 2012-2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 8.0.1 +-- +-- The module defines 'ExperimentSpecsView' that shows the +-- experiment specs. +-- + +module Simulation.Aivika.Experiment.Base.ExperimentSpecsView + (ExperimentSpecsView(..), + defaultExperimentSpecsView) where + +import Control.Monad +import Control.Monad.Trans + +import Data.Monoid + +import Simulation.Aivika.Experiment.Types +import Simulation.Aivika.Experiment.Base.WebPageRenderer +import Simulation.Aivika.Experiment.Base.HtmlWriter +import Simulation.Aivika.Experiment.Base.ExperimentWriter +import Simulation.Aivika.Experiment.Base.ExperimentSpecsWriter + +-- | Defines the 'View' that shows the experiment specs. +data ExperimentSpecsView = + ExperimentSpecsView { experimentSpecsTitle :: String, + -- ^ The title for the view. + experimentSpecsDescription :: String, + -- ^ The description for the view. + experimentSpecsWriter :: ExperimentSpecsWriter + -- ^ It shows the specs. + } + +-- | This is the default view. +defaultExperimentSpecsView :: ExperimentSpecsView +defaultExperimentSpecsView = + ExperimentSpecsView { experimentSpecsTitle = "Experiment Specs", + experimentSpecsDescription = "It shows the experiment specs.", + experimentSpecsWriter = defaultExperimentSpecsWriter } + +instance ExperimentView ExperimentSpecsView (WebPageRenderer a) where + + outputView v = + let reporter exp renderer dir = + do st <- newExperimentSpecs v exp + let context = + WebPageContext $ + WebPageWriter { reporterWriteTOCHtml = experimentSpecsTOCHtml st, + reporterWriteHtml = experimentSpecsHtml st } + return ExperimentReporter { reporterInitialise = return (), + reporterFinalise = return (), + reporterSimulate = const $ return mempty, + reporterContext = context } + in ExperimentGenerator { generateReporter = reporter } + +-- | The state of the view. +data ExperimentSpecsViewState = + ExperimentSpecsViewState { experimentSpecsView :: ExperimentSpecsView, + experimentSpecsExperiment :: Experiment } + +-- | Create a new state of the view. +newExperimentSpecs :: ExperimentSpecsView -> Experiment -> ExperimentWriter ExperimentSpecsViewState +newExperimentSpecs view exp = + return ExperimentSpecsViewState { experimentSpecsView = view, + experimentSpecsExperiment = exp } + +-- | Get the HTML code. +experimentSpecsHtml :: ExperimentSpecsViewState -> Int -> HtmlWriter () +experimentSpecsHtml st index = + do header st index + let writer = experimentSpecsWriter (experimentSpecsView st) + write = experimentSpecsWrite writer + exp = experimentSpecsExperiment st + write writer exp + +header :: ExperimentSpecsViewState -> Int -> HtmlWriter () +header st index = + do writeHtmlHeader3WithId ("id" ++ show index) $ + writeHtmlText (experimentSpecsTitle $ experimentSpecsView st) + let description = experimentSpecsDescription $ experimentSpecsView st + unless (null description) $ + writeHtmlParagraph $ + writeHtmlText description + +-- | Get the TOC item +experimentSpecsTOCHtml :: ExperimentSpecsViewState -> Int -> HtmlWriter () +experimentSpecsTOCHtml st index = + writeHtmlListItem $ + writeHtmlLink ("#id" ++ show index) $ + writeHtmlText (experimentSpecsTitle $ experimentSpecsView st) diff --git a/Simulation/Aivika/Experiment/Base/ExperimentSpecsWriter.hs b/Simulation/Aivika/Experiment/Base/ExperimentSpecsWriter.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Experiment/Base/ExperimentSpecsWriter.hs @@ -0,0 +1,131 @@ + +-- | +-- Module : Simulation.Aivika.Experiment.Base.ExperimentSpecsWriter +-- Copyright : Copyright (c) 2012-2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 8.0.1 +-- +-- The module defines 'ExperimentSpecsWriter' that knows how to write +-- in HTML the experiment specs which include the simulation specs and +-- the number of simulation runs. +-- + +module Simulation.Aivika.Experiment.Base.ExperimentSpecsWriter + (ExperimentSpecsWriter(..), + defaultExperimentSpecsWriter) where + +import Simulation.Aivika +import Simulation.Aivika.Experiment.Types +import Simulation.Aivika.Experiment.Base.HtmlWriter + +-- | Defines a writer that knows how to represent the +-- experiment specs as the HTML table. +data ExperimentSpecsWriter = + ExperimentSpecsWriter { experimentSpecsWidth :: Int, + -- ^ The width of the HTML table. + experimentSpecsNameText :: String, + -- ^ Translated text \"Experiment Specs\". + experimentSpecsStartTimeText :: String, + -- ^ Translated text \"start time\". + experimentSpecsStopTimeText :: String, + -- ^ Translated text \"stop time\". + experimentSpecsDTText :: String, + -- ^ Translated text \"time step\". + experimentSpecsRunCountText :: String, + -- ^ Translated text \"run count\". + experimentSpecsIntegMethodText :: String, + -- ^ Translated text \"integration method\". + experimentSpecsEulerText :: String, + -- ^ Translated text \"Euler's\". + experimentSpecsRungeKutta2Text :: String, + -- ^ Translated text \"the 2-nd order Runge-Kutta\". + experimentSpecsRungeKutta4Text :: String, + -- ^ Translated text \"the 4-th order Runge-Kutta\". + experimentSpecsFormatter :: ShowS, + -- ^ The formatter of numbers. + experimentSpecsWrite :: ExperimentSpecsWriter + -> Experiment + -> HtmlWriter () + -- ^ This function creates HTML. + } + +-- | The default writer. +defaultExperimentSpecsWriter :: ExperimentSpecsWriter +defaultExperimentSpecsWriter = + ExperimentSpecsWriter { + experimentSpecsWidth = 400, + experimentSpecsNameText = "Experiment Specs", + experimentSpecsStartTimeText = "start time", + experimentSpecsStopTimeText = "stop time", + experimentSpecsDTText = "time step", + experimentSpecsRunCountText = "run count", + experimentSpecsIntegMethodText = "integration method", + experimentSpecsEulerText = "Euler's", + experimentSpecsRungeKutta2Text = "the 2-nd order Runge-Kutta", + experimentSpecsRungeKutta4Text = "the 4-th order Runge-Kutta", + experimentSpecsFormatter = id, + experimentSpecsWrite = \writer exp -> + do let format x = experimentSpecsFormatter writer x + writeHtml "

" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "
" + writeHtml "

" + writeHtmlText $ experimentSpecsNameText writer + writeHtml "

" + writeHtml "
" + writeHtmlText $ experimentSpecsStartTimeText writer + writeHtml "" + writeHtmlText $ format $ show $ spcStartTime $ experimentSpecs exp + writeHtml "
" + writeHtmlText $ experimentSpecsStopTimeText writer + writeHtml "" + writeHtmlText $ format $ show $ spcStopTime $ experimentSpecs exp + writeHtml "
" + writeHtmlText $ experimentSpecsDTText writer + writeHtml "" + writeHtmlText $ format $ show $ spcDT $ experimentSpecs exp + writeHtml "
" + writeHtmlText $ experimentSpecsRunCountText writer + writeHtml "" + writeHtmlText $ format $ show $ experimentRunCount exp + writeHtml "
" + writeHtmlText $ experimentSpecsIntegMethodText writer + writeHtml "" + let method = spcMethod $ experimentSpecs exp + writeHtml $ methodName method writer + writeHtml "
" + writeHtml "

" + } + +-- | Return the method name. +methodName :: Method -> ExperimentSpecsWriter -> String +methodName Euler = experimentSpecsEulerText +methodName RungeKutta2 = experimentSpecsRungeKutta2Text +methodName RungeKutta4 = experimentSpecsRungeKutta4Text diff --git a/Simulation/Aivika/Experiment/Base/ExperimentWriter.hs b/Simulation/Aivika/Experiment/Base/ExperimentWriter.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Experiment/Base/ExperimentWriter.hs @@ -0,0 +1,154 @@ + +-- | +-- Module : Simulation.Aivika.Experiment.Base.ExperimentWriter +-- Copyright : Copyright (c) 2012-2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 8.0.1 +-- +-- It defines the 'Exp' monad that allows providing computation with +-- an ability to resolve file paths. +-- +module Simulation.Aivika.Experiment.Base.ExperimentWriter + (ExperimentWriter, + runExperimentWriter, + ExperimentFilePath(..), + experimentFilePath, + resolveFilePath, + expandFilePath, + mapFilePath) where + +import Control.Applicative +import Control.Monad +import Control.Monad.Trans +import Control.Monad.State +import Control.Concurrent.MVar +import Control.Exception + +import qualified Data.Map as M +import qualified Data.Set as S + +import System.Directory +import System.FilePath + +import Simulation.Aivika.Trans.Exception +import Simulation.Aivika.Experiment.Utils (replace) + +-- | Specifies the file name, unique or writable, which can be appended with extension if required. +data ExperimentFilePath = WritableFilePath FilePath + -- ^ The file which is overwritten in + -- case if it existed before. + | UniqueFilePath FilePath + -- ^ The file which is always unique, + -- when an automatically generated suffix + -- is added to the name in case of need. + +-- | The default experiment file path. +experimentFilePath :: ExperimentFilePath +experimentFilePath = UniqueFilePath "experiment" + +-- | Resolve the file path relative to the specified directory passed in the first argument +-- and taking into account a possible requirement to have an unique file name. +resolveFilePath :: FilePath -> ExperimentFilePath -> ExperimentWriter FilePath +resolveFilePath dir (WritableFilePath path) = + return $ dir path +resolveFilePath dir (UniqueFilePath path) = + ExperimentWriter $ \r -> + let (name, ext) = splitExtension path + loop y i = + do let n = dir addExtension y ext + y' = name ++ "(" ++ show i ++ ")" + f1 <- doesFileExist n + f2 <- doesDirectoryExist n + if f1 || f2 + then loop y' (i + 1) + else do n' <- liftIO $ + modifyMVar r $ \s -> + if S.member n s + then return (s, Nothing) + else return (S.insert n s, Just n) + case n' of + Nothing -> loop y' (i + 1) + Just n' -> return n' + in loop name 2 + +-- | Expand the file path using the specified table of substitutions. +expandFilePath :: ExperimentFilePath -> M.Map String String -> ExperimentFilePath +expandFilePath (WritableFilePath path) map = WritableFilePath (expandTemplates path map) +expandFilePath (UniqueFilePath path) map = UniqueFilePath (expandTemplates path map) + +-- | Expand the string templates using the specified table of substitutions. +expandTemplates :: String -> M.Map String String -> String +expandTemplates name map = name' where + ((), name') = flip runState name $ + forM_ (M.assocs map) $ \(k, v) -> + do a <- get + put $ replace k v a + +-- | Transform the file path using the specified function. +mapFilePath :: (FilePath -> FilePath) -> ExperimentFilePath -> ExperimentFilePath +mapFilePath f (WritableFilePath path) = WritableFilePath (f path) +mapFilePath f (UniqueFilePath path) = UniqueFilePath (f path) + + +-- | Defines an 'IO' derived computation whithin which we can resolve the unique file paths. +newtype ExperimentWriter a = ExperimentWriter (MVar (S.Set String) -> IO a) + +instance Functor ExperimentWriter where + + {-# INLINE fmap #-} + fmap f (ExperimentWriter m) = + ExperimentWriter $ \r -> fmap f (m r) + +instance Applicative ExperimentWriter where + + {-# INLINE pure #-} + pure a = + ExperimentWriter $ \r -> return a + + {-# INLINE (<*>) #-} + (ExperimentWriter f) <*> (ExperimentWriter m) = + ExperimentWriter $ \r -> f r <*> m r + +instance Monad ExperimentWriter where + + {-# INLINE return #-} + return a = + ExperimentWriter $ \r -> return a + + {-# INLINE (>>=) #-} + (ExperimentWriter m) >>= k = + ExperimentWriter $ \r -> + do a <- m r + let ExperimentWriter b = k a + b r + +instance MonadIO ExperimentWriter where + + {-# INLINE liftIO #-} + liftIO m = ExperimentWriter $ \r -> liftIO m + +instance MonadException ExperimentWriter where + + {-# INLINE catchComp #-} + catchComp (ExperimentWriter m) h = + ExperimentWriter $ \r -> + catch (m r) $ \e -> + let ExperimentWriter m' = h e in m' r + + {-# INLINE finallyComp #-} + finallyComp (ExperimentWriter m) (ExperimentWriter m') = + ExperimentWriter $ \r -> + finally (m r) (m' r) + + {-# INLINE throwComp #-} + throwComp e = + ExperimentWriter $ \r -> + throw e + +-- | Run the 'ExperimentWriter' computation. +runExperimentWriter :: ExperimentWriter a -> IO a +runExperimentWriter (ExperimentWriter m) = + do r <- newMVar S.empty + m r diff --git a/Simulation/Aivika/Experiment/Base/FileRenderer.hs b/Simulation/Aivika/Experiment/Base/FileRenderer.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Experiment/Base/FileRenderer.hs @@ -0,0 +1,64 @@ + +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Simulation.Aivika.Experiment.Base.FileRenderer +-- Copyright : Copyright (c) 2012-2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 8.0.1 +-- +-- It defines a renderer that saves the results in files when running the simulation experiment. +-- + +module Simulation.Aivika.Experiment.Base.FileRenderer where + +import Control.Monad +import Control.Monad.Trans + +import System.Directory +import System.FilePath + +import Simulation.Aivika.Trans.Exception +import Simulation.Aivika.Experiment.Types +import Simulation.Aivika.Experiment.Base.ExperimentWriter + +-- | It defines a simulation 'Experiment' renderer that saves the results in files. +data FileRenderer a = FileRenderer a ExperimentFilePath + -- ^ A file renderer that depends on the provided parameter and + -- a directory path, where the simulation results are saved in. + +-- | A convenient type synonym for describing a file generator. +type FileGenerator a = ExperimentGenerator (FileRenderer a) + +-- | Saving the results of simulation in files when running the experiment. +instance ExperimentRendering (FileRenderer a) where + + -- | A file rendering context. + data ExperimentContext (FileRenderer a) = FileContext + -- ^ A file context constructor. + + -- | A file environment. + type ExperimentEnvironment (FileRenderer a) = FilePath + + -- | A file rendering monad. + type ExperimentMonad (FileRenderer a) = ExperimentWriter + + liftExperiment r = runExperimentWriter + + prepareExperiment e (FileRenderer _ path0) = + do path <- resolveFilePath "" path0 + liftIO $ do + when (experimentVerbose e) $ + do putStr "Updating directory " + putStrLn path + createDirectoryIfMissing True path + return path + + renderExperiment e r reporters path = return () + + onExperimentCompleted e r path = return () + + onExperimentFailed e r path e' = throwComp e' + diff --git a/Simulation/Aivika/Experiment/Base/FinalStatsView.hs b/Simulation/Aivika/Experiment/Base/FinalStatsView.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Experiment/Base/FinalStatsView.hs @@ -0,0 +1,166 @@ + +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Simulation.Aivika.Experiment.Base.FinalStatsView +-- Copyright : Copyright (c) 2012-2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 8.0.1 +-- +-- The module defines 'FinalStatsView' that gathers the statistics +-- in the final time points for different simulation runs. +-- + +module Simulation.Aivika.Experiment.Base.FinalStatsView + (FinalStatsView(..), + defaultFinalStatsView) where + +import Control.Monad +import Control.Monad.Trans +import Control.Concurrent.MVar + +import Data.IORef +import Data.Maybe + +import Simulation.Aivika +import Simulation.Aivika.Experiment.Types +import Simulation.Aivika.Experiment.Base.WebPageRenderer +import Simulation.Aivika.Experiment.Base.ExperimentWriter +import Simulation.Aivika.Experiment.Base.HtmlWriter +import Simulation.Aivika.Experiment.Base.SamplingStatsWriter +import Simulation.Aivika.Experiment.Concurrent.MVar + +-- | Defines the 'View' that gathers the statistics +-- in the final time points. +data FinalStatsView = + FinalStatsView { finalStatsTitle :: String, + -- ^ This is a title for the view. + finalStatsDescription :: String, + -- ^ This is a description used in HTML. + finalStatsWriter :: SamplingStatsWriter Double, + -- ^ It shows the sampling statistics. + finalStatsPredicate :: Event Bool, + -- ^ It specifies the predicate that defines + -- when we count data when gathering the statistics. + finalStatsTransform :: ResultTransform, + -- ^ The transform applied to the results before receiving series. + finalStatsSeries :: ResultTransform + -- ^ It defines the series for which the statistics to be collected. + } + +-- | The default statistics view. +defaultFinalStatsView :: FinalStatsView +defaultFinalStatsView = + FinalStatsView { finalStatsTitle = "Final Statistics Based on Observations", + finalStatsDescription = "Statistics is gathered in final time points for all runs.", + finalStatsWriter = defaultSamplingStatsWriter, + finalStatsPredicate = return True, + finalStatsTransform = id, + finalStatsSeries = id } + +instance ExperimentView FinalStatsView (WebPageRenderer a) where + + outputView v = + let reporter exp renderer dir = + do st <- newFinalStats v exp dir + let context = + WebPageContext $ + WebPageWriter { reporterWriteTOCHtml = finalStatsTOCHtml st, + reporterWriteHtml = finalStatsHtml st } + return ExperimentReporter { reporterInitialise = return (), + reporterFinalise = return (), + reporterSimulate = simulateFinalStats st, + reporterContext = context } + in ExperimentGenerator { generateReporter = reporter } + +-- | The state of the view. +data FinalStatsViewState = + FinalStatsViewState { finalStatsView :: FinalStatsView, + finalStatsExperiment :: Experiment, + finalStatsResults :: MVar (Maybe FinalStatsResults) } + +-- | The statistics results. +data FinalStatsResults = + FinalStatsResults { finalStatsNames :: [String], + finalStatsValues :: [MVar (SamplingStats Double)] } + +-- | Create a new state of the view. +newFinalStats :: FinalStatsView -> Experiment -> FilePath -> ExperimentWriter FinalStatsViewState +newFinalStats view exp dir = + do r <- liftIO $ newMVar Nothing + return FinalStatsViewState { finalStatsView = view, + finalStatsExperiment = exp, + finalStatsResults = r } + +-- | Create new statistics results. +newFinalStatsResults :: [String] -> Experiment -> IO FinalStatsResults +newFinalStatsResults names exp = + do values <- forM names $ \_ -> liftIO $ newMVar emptySamplingStats + return FinalStatsResults { finalStatsNames = names, + finalStatsValues = values } + +-- | Require to return unique final statistics results associated with the specified state. +requireFinalStatsResults :: FinalStatsViewState -> [String] -> IO FinalStatsResults +requireFinalStatsResults st names = + maybePutMVar (finalStatsResults st) + (newFinalStatsResults names (finalStatsExperiment st)) $ \results -> + if (names /= finalStatsNames results) + then error "Series with different names are returned for different runs: requireFinalStatsResults" + else return results + +-- | Simulate the specified series. +simulateFinalStats :: FinalStatsViewState -> ExperimentData -> Composite () +simulateFinalStats st expdata = + do let view = finalStatsView st + rs = finalStatsSeries view $ + finalStatsTransform view $ + experimentResults expdata + exts = resultsToDoubleStatsEitherValues rs + signals = experimentPredefinedSignals expdata + signal = filterSignalM (const predicate) $ + resultSignalInStopTime signals + names = map resultValueName exts + predicate = finalStatsPredicate view + results <- liftIO $ requireFinalStatsResults st names + let values = finalStatsValues results + handleSignalComposite signal $ \_ -> + forM_ (zip exts values) $ \(ext, value) -> + do x <- resultValueData ext + liftIO $ + modifyMVar_ value $ \y -> + let y' = combineSamplingStatsEither x y + in y' `seq` return y' + +-- | Get the HTML code. +finalStatsHtml :: FinalStatsViewState -> Int -> HtmlWriter () +finalStatsHtml st index = + do header st index + results <- liftIO $ readMVar (finalStatsResults st) + case results of + Nothing -> return () + Just results -> + do let names = finalStatsNames results + values = finalStatsValues results + writer = finalStatsWriter (finalStatsView st) + write = samplingStatsWrite writer + forM_ (zip names values) $ \(name, value) -> + do stats <- liftIO $ readMVar value + write writer name stats + +header :: FinalStatsViewState -> Int -> HtmlWriter () +header st index = + do writeHtmlHeader3WithId ("id" ++ show index) $ + writeHtmlText (finalStatsTitle $ finalStatsView st) + let description = finalStatsDescription $ finalStatsView st + unless (null description) $ + writeHtmlParagraph $ + writeHtmlText description + +-- | Get the TOC item. +finalStatsTOCHtml :: FinalStatsViewState -> Int -> HtmlWriter () +finalStatsTOCHtml st index = + writeHtmlListItem $ + writeHtmlLink ("#id" ++ show index) $ + writeHtmlText (finalStatsTitle $ finalStatsView st) diff --git a/Simulation/Aivika/Experiment/Base/FinalTableView.hs b/Simulation/Aivika/Experiment/Base/FinalTableView.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Experiment/Base/FinalTableView.hs @@ -0,0 +1,253 @@ + +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Simulation.Aivika.Experiment.Base.FinalTableView +-- Copyright : Copyright (c) 2012-2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 8.0.1 +-- +-- The module defines 'FinalTableView' that saves the simulation +-- results in the final time points for all simulation runs in +-- the CSV file. +-- + +module Simulation.Aivika.Experiment.Base.FinalTableView + (FinalTableView(..), + defaultFinalTableView) where + +import Control.Monad +import Control.Monad.Trans +import Control.Concurrent.MVar + +import qualified Data.Map as M +import Data.IORef +import Data.Maybe + +import System.IO +import System.FilePath + +import Simulation.Aivika +import Simulation.Aivika.Experiment.Types +import Simulation.Aivika.Experiment.Base.WebPageRenderer +import Simulation.Aivika.Experiment.Base.FileRenderer +import Simulation.Aivika.Experiment.Base.ExperimentWriter +import Simulation.Aivika.Experiment.Base.HtmlWriter +import Simulation.Aivika.Experiment.Concurrent.MVar + +-- | Defines the 'View' that saves the simulation +-- results in the final time points for all +-- simulation runs in the CSV file. +data FinalTableView = + FinalTableView { finalTableTitle :: String, + -- ^ This is a title used in HTML. + finalTableDescription :: String, + -- ^ This is a description used in HTML. + finalTableRunText :: String, + -- ^ Translated text \"Run\". + finalTableLinkText :: String, + -- ^ It specifies the text for the link + -- which is displayed in the HTML page. + -- The link downloads the corresponded + -- CSV file in the browser. + -- + -- An example is + -- + -- @ + -- finalTableLinkText = \"Download the CSV file\" + -- @ + finalTableFileName :: ExperimentFilePath, + -- ^ It defines the file name for the CSV file. + -- It may include special variable @$TITLE@. + -- + -- An example is + -- + -- @ + -- finalTableFileName = UniqueFilePath \"$TITLE.csv\" + -- @ + finalTableSeparator :: String, + -- ^ It defines the separator for the view. + -- It delimits the cells in the rows of the CSV file. + finalTableFormatter :: ShowS, + -- ^ It defines the formatter which is applied + -- to all values before they will be written + -- in the CSV file. + finalTablePredicate :: Event Bool, + -- ^ It specifies the predicate that defines + -- when we can save data in the table. + finalTableTransform :: ResultTransform, + -- ^ The transform applied to the results before receiving series. + finalTableSeries :: ResultTransform + -- ^ It defines the series to save in the CSV file. + } + +-- | The default table view. +defaultFinalTableView :: FinalTableView +defaultFinalTableView = + FinalTableView { finalTableTitle = "Final Table", + finalTableDescription = "It refers to the CSV file with the results in the final time points.", + finalTableRunText = "Run", + finalTableLinkText = "Download the CSV file", + finalTableFileName = UniqueFilePath "FinalTable.csv", + finalTableSeparator = ",", + finalTableFormatter = id, + finalTablePredicate = return True, + finalTableTransform = expandResults, + finalTableSeries = id } + +instance ExperimentView FinalTableView (WebPageRenderer a) where + + outputView v = + let reporter exp renderer dir = + do st <- newFinalTable v exp dir + let context = + WebPageContext + WebPageWriter { reporterWriteTOCHtml = finalTableTOCHtml st, + reporterWriteHtml = finalTableHtml st } + return ExperimentReporter { reporterInitialise = return (), + reporterFinalise = finaliseFinalTable st, + reporterSimulate = simulateFinalTable st, + reporterContext = context } + in ExperimentGenerator { generateReporter = reporter } + +instance ExperimentView FinalTableView (FileRenderer a) where + + outputView v = + let reporter exp renderer dir = + do st <- newFinalTable v exp dir + return ExperimentReporter { reporterInitialise = return (), + reporterFinalise = finaliseFinalTable st, + reporterSimulate = simulateFinalTable st, + reporterContext = FileContext } + in ExperimentGenerator { generateReporter = reporter } + +-- | The state of the view. +data FinalTableViewState = + FinalTableViewState { finalTableView :: FinalTableView, + finalTableExperiment :: Experiment, + finalTableDir :: FilePath, + finalTableFile :: IORef (Maybe FilePath), + finalTableResults :: MVar (Maybe FinalTableResults) } + +-- | The table results. +data FinalTableResults = + FinalTableResults { finalTableNames :: [String], + finalTableValues :: MVar (M.Map Int [String]) } + +-- | Create a new state of the view. +newFinalTable :: FinalTableView -> Experiment -> FilePath -> ExperimentWriter FinalTableViewState +newFinalTable view exp dir = + do f <- liftIO $ newIORef Nothing + r <- liftIO $ newMVar Nothing + return FinalTableViewState { finalTableView = view, + finalTableExperiment = exp, + finalTableDir = dir, + finalTableFile = f, + finalTableResults = r } + +-- | Create new table results. +newFinalTableResults :: [String] -> Experiment -> IO FinalTableResults +newFinalTableResults names exp = + do values <- newMVar M.empty + return FinalTableResults { finalTableNames = names, + finalTableValues = values } + +-- | Require to return unique final tables results associated with the specified state. +requireFinalTableResults :: FinalTableViewState -> [String] -> IO FinalTableResults +requireFinalTableResults st names = + maybePutMVar (finalTableResults st) + (newFinalTableResults names (finalTableExperiment st)) $ \results -> + if (names /= finalTableNames results) + then error "Series with different names are returned for different runs: requireFinalTableResults" + else return results + +-- | Simulation of the specified series. +simulateFinalTable :: FinalTableViewState -> ExperimentData -> Composite () +simulateFinalTable st expdata = + do let view = finalTableView st + rs = finalTableSeries view $ + finalTableTransform view $ + experimentResults expdata + exts = resultsToStringValues rs + signals = experimentPredefinedSignals expdata + signal = filterSignalM (const predicate) $ + resultSignalInStopTime signals + names = map resultValueName exts + predicate = finalTablePredicate view + results <- liftIO $ requireFinalTableResults st names + let values = finalTableValues results + handleSignalComposite signal $ \_ -> + do xs <- mapM resultValueData exts + i <- liftParameter simulationIndex + liftIO $ modifyMVar_ values $ return . M.insert i xs + +-- | Save the results in the CSV file after the simulation is complete. +finaliseFinalTable :: FinalTableViewState -> ExperimentWriter () +finaliseFinalTable st = + do let view = finalTableView st + run = finalTableRunText view + formatter = finalTableFormatter view + title = finalTableTitle view + separator = finalTableSeparator view + results <- liftIO $ readMVar $ finalTableResults st + case results of + Nothing -> return () + Just results -> + do let names = finalTableNames results + values = finalTableValues results + m <- liftIO $ readMVar values + file <- resolveFilePath (finalTableDir st) $ + mapFilePath (flip replaceExtension ".csv") $ + expandFilePath (finalTableFileName $ finalTableView st) $ + M.fromList [("$TITLE", title)] + liftIO $ do + -- create a new file + h <- openFile file WriteMode + -- write a header + hPutStr h $ show run + forM_ names $ \name -> + do hPutStr h separator + hPutStr h $ show name + hPutStrLn h "" + -- write data + forM_ (M.assocs m) $ \(i, xs) -> + do hPutStr h $ show i + forM_ xs $ \x -> + do hPutStr h separator + hPutStr h $ formatter x + hPutStrLn h "" + -- close file + hClose h + when (experimentVerbose $ finalTableExperiment st) $ + putStr "Generated file " >> putStrLn file + writeIORef (finalTableFile st) $ Just file + +-- | Get the HTML code. +finalTableHtml :: FinalTableViewState -> Int -> HtmlWriter () +finalTableHtml st index = + do header st index + file <- liftIO $ readIORef (finalTableFile st) + case file of + Nothing -> return () + Just f -> + writeHtmlParagraph $ + writeHtmlLink (makeRelative (finalTableDir st) f) $ + writeHtmlText (finalTableLinkText $ finalTableView st) + +header :: FinalTableViewState -> Int -> HtmlWriter () +header st index = + do writeHtmlHeader3WithId ("id" ++ show index) $ + writeHtmlText (finalTableTitle $ finalTableView st) + let description = finalTableDescription $ finalTableView st + unless (null description) $ + writeHtmlParagraph $ + writeHtmlText description + +-- | Get the TOC item. +finalTableTOCHtml :: FinalTableViewState -> Int -> HtmlWriter () +finalTableTOCHtml st index = + writeHtmlListItem $ + writeHtmlLink ("#id" ++ show index) $ + writeHtmlText (finalTableTitle $ finalTableView st) diff --git a/Simulation/Aivika/Experiment/Base/HtmlWriter.hs b/Simulation/Aivika/Experiment/Base/HtmlWriter.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Experiment/Base/HtmlWriter.hs @@ -0,0 +1,401 @@ + +-- | +-- Module : Simulation.Aivika.Experiment.Base.HtmlWriter +-- Copyright : Copyright (c) 2012-2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 8.0.1 +-- +-- This is an utility module that provides an HTML writer. +-- + +module Simulation.Aivika.Experiment.Base.HtmlWriter + (HtmlWriter, + runHtmlWriter, + composeHtml, + writeHtml, + writeHtmlLn, + writeHtmlText, + writeHtmlParagraph, + writeHtmlParagraphWithId, + writeHtmlHeader1, + writeHtmlHeader1WithId, + writeHtmlHeader2, + writeHtmlHeader2WithId, + writeHtmlHeader3, + writeHtmlHeader3WithId, + writeHtmlHeader4, + writeHtmlHeader4WithId, + writeHtmlHeader5, + writeHtmlHeader5WithId, + writeHtmlHeader6, + writeHtmlHeader6WithId, + writeHtmlBreak, + writeHtmlLink, + writeHtmlImage, + writeHtmlList, + writeHtmlListItem, + writeHtmlDocumentWithTitle, + encodeHtmlText) where + +import Control.Monad +import Control.Monad.Trans +import Control.Applicative + +import Network.URI + +import Simulation.Aivika.Experiment.Base.ExperimentWriter + +-- | It writes fast an HTML code. +newtype HtmlWriter a = + HtmlWriter { runHtmlWriter :: ShowS -> ExperimentWriter (a, ShowS) + -- ^ Run the HTML writer monad. + } + +instance Monad HtmlWriter where + + return a = HtmlWriter $ \f -> return (a, f) + + (HtmlWriter m) >>= k = HtmlWriter $ \f -> + do (a, f') <- m f + let HtmlWriter m' = k a + m' f' + +instance MonadIO HtmlWriter where + + liftIO m = HtmlWriter $ \f -> + do x <- liftIO m + return (x, f) + +instance Functor HtmlWriter where + + fmap f m = m >>= \a -> return (f a) + +instance Applicative HtmlWriter where + + pure = return + (<*>) = ap + +-- | Write the HTML code. +writeHtml :: String -> HtmlWriter () +writeHtml code = + HtmlWriter $ \f -> return ((), f . (code ++)) + +-- | Write the HTML code. +writeHtmlLn :: String -> HtmlWriter () +writeHtmlLn code = + do writeHtml code + writeHtml "\n" + +-- | Write the text in HTML. +writeHtmlText :: String -> HtmlWriter () +writeHtmlText text = + HtmlWriter $ \f -> return ((), f . (encodeHtmlText text ++)) + +-- | Compose the HTML applying the corresponded transformation. +composeHtml :: ShowS -> HtmlWriter () +composeHtml g = + HtmlWriter $ \f -> return ((), f . g) + +-- | Write the HTML link with the specified URI and contents. +writeHtmlLink :: String -> HtmlWriter () -> HtmlWriter () +writeHtmlLink uri inner = + do writeHtml "" + inner + writeHtml "" + +-- | Write the HTML image with the specified URI. +writeHtmlImage :: String -> HtmlWriter () +writeHtmlImage uri = + do writeHtml "" + +-- | Write the @\@ element with the specified contents. +writeHtmlParagraph :: HtmlWriter () -> HtmlWriter () +writeHtmlParagraph inner = + do writeHtml "

" + inner + writeHtml "

" + +-- | Write the @\@ element with the specified contents. +writeHtmlHeader1 :: HtmlWriter () -> HtmlWriter () +writeHtmlHeader1 inner = + do writeHtml "

" + inner + writeHtml "

" + +-- | Write the @\@ element with the specified contents. +writeHtmlHeader2 :: HtmlWriter () -> HtmlWriter () +writeHtmlHeader2 inner = + do writeHtml "

" + inner + writeHtml "

" + +-- | Write the @\@ element with the specified contents. +writeHtmlHeader3 :: HtmlWriter () -> HtmlWriter () +writeHtmlHeader3 inner = + do writeHtml "

" + inner + writeHtml "

" + +-- | Write the @\@ element with the specified contents. +writeHtmlHeader4 :: HtmlWriter () -> HtmlWriter () +writeHtmlHeader4 inner = + do writeHtml "

" + inner + writeHtml "

" + +-- | Write the @\@ element with the specified contents. +writeHtmlHeader5 :: HtmlWriter () -> HtmlWriter () +writeHtmlHeader5 inner = + do writeHtml "
" + inner + writeHtml "
" + +-- | Write the @\@ element with the specified contents. +writeHtmlHeader6 :: HtmlWriter () -> HtmlWriter () +writeHtmlHeader6 inner = + do writeHtml "
" + inner + writeHtml "
" + +-- | Write the @\@ element with the specified id and contents. +writeHtmlParagraphWithId :: String -> HtmlWriter () -> HtmlWriter () +writeHtmlParagraphWithId id inner = + do writeHtml "

" + inner + writeHtml "

" + +-- | Write the @\@ element with the specified id and contents. +writeHtmlHeader1WithId :: String -> HtmlWriter () -> HtmlWriter () +writeHtmlHeader1WithId id inner = + do writeHtml "

" + inner + writeHtml "

" + +-- | Write the @\@ element with the specified id and contents. +writeHtmlHeader2WithId :: String -> HtmlWriter () -> HtmlWriter () +writeHtmlHeader2WithId id inner = + do writeHtml "

" + inner + writeHtml "

" + +-- | Write the @\@ element with the specified id and contents. +writeHtmlHeader3WithId :: String -> HtmlWriter () -> HtmlWriter () +writeHtmlHeader3WithId id inner = + do writeHtml "

" + inner + writeHtml "

" + +-- | Write the @\@ element with the specified id and contents. +writeHtmlHeader4WithId :: String -> HtmlWriter () -> HtmlWriter () +writeHtmlHeader4WithId id inner = + do writeHtml "

" + inner + writeHtml "

" + +-- | Write the @\@ element with the specified id and contents. +writeHtmlHeader5WithId :: String -> HtmlWriter () -> HtmlWriter () +writeHtmlHeader5WithId id inner = + do writeHtml "
" + inner + writeHtml "
" + +-- | Write the @\@ element with the specified id and contents. +writeHtmlHeader6WithId :: String -> HtmlWriter () -> HtmlWriter () +writeHtmlHeader6WithId id inner = + do writeHtml "
" + inner + writeHtml "
" + +-- | Write the @\@ element. +writeHtmlBreak :: HtmlWriter () +writeHtmlBreak = + writeHtml "
" + +-- | Write the list of items wrapped in @\@. +writeHtmlList :: HtmlWriter () -> HtmlWriter () +writeHtmlList inner = + do writeHtml "
    " + inner + writeHtml "
" + +-- | Write the item list wrapped in @\@. +writeHtmlListItem :: HtmlWriter () -> HtmlWriter () +writeHtmlListItem inner = + do writeHtml "
  • " + inner + writeHtml "
    • " + +-- | Write the HTML document with the specified title and contents +writeHtmlDocumentWithTitle :: String -> HtmlWriter () -> HtmlWriter () +writeHtmlDocumentWithTitle title inner = + do writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtmlText title + writeHtml "" + writeHtmlCss + writeHtml "" + writeHtml "" + writeHtmlHeader1 $ + writeHtmlText title + writeHtml "" + inner + writeHtml "

    Automatically generated by " + writeHtml "" + writeHtml "Aivika" + writeHtml "

    " + writeHtml "" + writeHtml "" + +-- | Escape special HTML characters in the 'String'. +-- It is based on one function from package Web-Encodings, +-- which is licensed under BSD3 but obsolete now. +encodeHtmlText :: String -> String +encodeHtmlText x = join $ map encodeHtmlChar x + +-- | Escape a character. +encodeHtmlChar :: Char -> String +encodeHtmlChar '<' = "<" +encodeHtmlChar '>' = ">" +encodeHtmlChar '&' = "&" +encodeHtmlChar '"' = """ +encodeHtmlChar '\'' = "'" +encodeHtmlChar c = [c] + +-- | Write the CSS styles +writeHtmlCss :: HtmlWriter () +writeHtmlCss = + do writeHtmlLn "" diff --git a/Simulation/Aivika/Experiment/Base/InfoView.hs b/Simulation/Aivika/Experiment/Base/InfoView.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Experiment/Base/InfoView.hs @@ -0,0 +1,175 @@ + +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Simulation.Aivika.Experiment.Base.InfoView +-- Copyright : Copyright (c) 2012-2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 8.0.1 +-- +-- The module defines 'InfoView' that shows the description of series. +-- + +module Simulation.Aivika.Experiment.Base.InfoView + (InfoView(..), + defaultInfoView) where + +import Control.Monad +import Control.Monad.Trans +import Control.Concurrent.MVar + +import Data.IORef +import Data.Maybe +import Data.Monoid + +import Simulation.Aivika +import Simulation.Aivika.Experiment.Types +import Simulation.Aivika.Experiment.Base.WebPageRenderer +import Simulation.Aivika.Experiment.Base.ExperimentWriter +import Simulation.Aivika.Experiment.Base.HtmlWriter +import Simulation.Aivika.Experiment.Concurrent.MVar + +-- | Defines the 'View' that shows the description of series. +data InfoView = + InfoView { infoTitle :: String, + -- ^ This is a title for the view. + infoDescription :: String, + -- ^ This is a text description used in HTML. + infoTransform :: ResultTransform, + -- ^ The transform applied to the results before receiving series. + infoSeries :: ResultTransform, + -- ^ It defines the series for which the description is shown. + infoLocalisation :: ResultLocalisation + -- ^ It specifies the localisation. + } + +-- | The default description view. +defaultInfoView :: InfoView +defaultInfoView = + InfoView { infoTitle = "Information", + infoDescription = "It shows the information about simulation entities:", + infoTransform = id, + infoSeries = id, + infoLocalisation = englishResultLocalisation } + +instance ExperimentView InfoView (WebPageRenderer a) where + + outputView v = + let reporter exp renderer dir = + do st <- newInfo v exp dir + let context = + WebPageContext $ + WebPageWriter { reporterWriteTOCHtml = infoTOCHtml st, + reporterWriteHtml = infoHtml st } + return ExperimentReporter { reporterInitialise = return (), + reporterFinalise = return (), + reporterSimulate = simulateInfo st, + reporterContext = context } + in ExperimentGenerator { generateReporter = reporter } + +-- | The state of the view. +data InfoViewState = + InfoViewState { infoView :: InfoView, + infoExperiment :: Experiment, + infoResults :: MVar (Maybe InfoResults) } + +-- | The information table. +data InfoResults = + InfoResults { infoNames :: [String], + infoValues :: [String] } + +-- | Create a new state of the view. +newInfo :: InfoView -> Experiment -> FilePath -> ExperimentWriter InfoViewState +newInfo view exp dir = + do r <- liftIO $ newMVar Nothing + return InfoViewState { infoView = view, + infoExperiment = exp, + infoResults = r } + +-- | Create a new information table. +newInfoResults :: [ResultSource] -> ResultLocalisation -> Experiment -> IO InfoResults +newInfoResults sources loc exp = + do let xs = + flip map sources $ \source -> + case source of + ResultItemSource (ResultItem x) -> + [(resultItemName x, loc $ resultItemId x)] + ResultObjectSource x -> + [(resultObjectName x, loc $ resultObjectId x)] + ResultVectorSource x -> + [(resultVectorName x, loc $ resultVectorId x)] + ResultSeparatorSource x -> + [] + (names, values) = unzip $ concat xs + return InfoResults { infoNames = names, + infoValues = values } + +-- | Require to return the unique information table associated with the specified state. +requireInfoResults :: InfoViewState -> [ResultSource] -> IO InfoResults +requireInfoResults st sources = + let view = infoView st + loc = infoLocalisation view + exp = infoExperiment st + in maybePutMVar (infoResults st) + (newInfoResults sources loc exp) $ \results -> + do let xs = + flip map sources $ \source -> + case source of + ResultItemSource (ResultItem x) -> + [resultItemName x] + ResultObjectSource x -> + [resultObjectName x] + ResultVectorSource x -> + [resultVectorName x] + ResultSeparatorSource x -> + [] + let names = concat xs + if (names /= infoNames results) + then error "Series with different names are returned for different runs: requireInfoResults" + else return results + +-- | Simulate the specified series. +simulateInfo :: InfoViewState -> ExperimentData -> Composite () +simulateInfo st expdata = + do let view = infoView st + rs = infoSeries view $ + infoTransform view $ + experimentResults expdata + sources = resultSourceList rs + liftIO $ requireInfoResults st sources + return () + +-- | Get the HTML code. +infoHtml :: InfoViewState -> Int -> HtmlWriter () +infoHtml st index = + do header st index + results <- liftIO $ readMVar (infoResults st) + case results of + Nothing -> return () + Just results -> + do let names = infoNames results + values = infoValues results + writeHtmlList $ + forM_ (zip names values) $ \(name, value) -> + writeHtmlListItem $ + do writeHtmlText name + writeHtmlText " - " + writeHtmlText value + +header :: InfoViewState -> Int -> HtmlWriter () +header st index = + do writeHtmlHeader3WithId ("id" ++ show index) $ + writeHtmlText (infoTitle $ infoView st) + let description = infoDescription $ infoView st + unless (null description) $ + writeHtmlParagraph $ + writeHtmlText description + +-- | Get the TOC item. +infoTOCHtml :: InfoViewState -> Int -> HtmlWriter () +infoTOCHtml st index = + writeHtmlListItem $ + writeHtmlLink ("#id" ++ show index) $ + writeHtmlText (infoTitle $ infoView st) diff --git a/Simulation/Aivika/Experiment/Base/LastValueView.hs b/Simulation/Aivika/Experiment/Base/LastValueView.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Experiment/Base/LastValueView.hs @@ -0,0 +1,174 @@ + +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Simulation.Aivika.Experiment.Base.LastValueView +-- Copyright : Copyright (c) 2012-2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 8.0.1 +-- +-- The module defines 'LastValueView' that shows the last values +-- for the simulation variables. +-- + +module Simulation.Aivika.Experiment.Base.LastValueView + (LastValueView(..), + defaultLastValueView) where + +import Control.Monad +import Control.Monad.Trans + +import qualified Data.Map as M +import Data.IORef +import Data.Maybe + +import Simulation.Aivika +import Simulation.Aivika.Experiment.Types +import Simulation.Aivika.Experiment.Base.WebPageRenderer +import Simulation.Aivika.Experiment.Base.ExperimentWriter +import Simulation.Aivika.Experiment.Base.HtmlWriter +import Simulation.Aivika.Experiment.Utils (replace) + +-- | Defines the 'View' that shows the last values of the simulation +-- variables. +data LastValueView = + LastValueView { lastValueTitle :: String, + -- ^ The title for the view. + lastValueRunTitle :: String, + -- ^ The run title for the view. It may include + -- special variables @$RUN_INDEX@, @$RUN_COUNT@ and + -- @$TITLE@. + -- + -- An example is + -- + -- @ + -- lastValueRunTitle = \"$TITLE / Run $RUN_INDEX of $RUN_COUNT\" + -- @ + lastValueDescription :: String, + -- ^ The description for the view. + lastValueFormatter :: ShowS, + -- ^ It transforms data before they will be shown. + lastValueTransform :: ResultTransform, + -- ^ The transform applied to the results before receiving series. + lastValueSeries :: ResultTransform + -- ^ It defines the series for which the last values to be shown. + } + +-- | This is the default view. +defaultLastValueView :: LastValueView +defaultLastValueView = + LastValueView { lastValueTitle = "Last Values", + lastValueRunTitle = "$TITLE / Run $RUN_INDEX of $RUN_COUNT", + lastValueDescription = "It shows the values in the final time point(s).", + lastValueFormatter = id, + lastValueTransform = id, + lastValueSeries = id } + +instance ExperimentView LastValueView (WebPageRenderer a) where + + outputView v = + let reporter exp renderer dir = + do st <- newLastValues v exp + let context = + WebPageContext $ + WebPageWriter { reporterWriteTOCHtml = lastValueTOCHtml st, + reporterWriteHtml = lastValueHtml st } + return ExperimentReporter { reporterInitialise = return (), + reporterFinalise = return (), + reporterSimulate = simulateLastValues st, + reporterContext = context } + in ExperimentGenerator { generateReporter = reporter } + +-- | The state of the view. +data LastValueViewState = + LastValueViewState { lastValueView :: LastValueView, + lastValueExperiment :: Experiment, + lastValueMap :: M.Map Int (IORef [(String, String)]) } + +-- | Create a new state of the view. +newLastValues :: LastValueView -> Experiment -> ExperimentWriter LastValueViewState +newLastValues view exp = + do let n = experimentRunCount exp + rs <- forM [0..(n - 1)] $ \i -> liftIO $ newIORef [] + let m = M.fromList $ zip [0..(n - 1)] rs + return LastValueViewState { lastValueView = view, + lastValueExperiment = exp, + lastValueMap = m } + +-- | Get the last values during the simulation. +simulateLastValues :: LastValueViewState -> ExperimentData -> Composite () +simulateLastValues st expdata = + do let view = lastValueView st + rs = lastValueSeries view $ + lastValueTransform view $ + experimentResults expdata + exts = resultsToStringValues rs + signals = experimentPredefinedSignals expdata + signal = resultSignalInStopTime signals + i <- liftParameter simulationIndex + handleSignalComposite signal $ \t -> + do let r = fromJust $ M.lookup (i - 1) (lastValueMap st) + output <- forM exts $ \ext -> + do x <- resultValueData ext + return (resultValueName ext, x) + liftIO $ writeIORef r output + +-- | Get the HTML code. +lastValueHtml :: LastValueViewState -> Int -> HtmlWriter () +lastValueHtml st index = + let n = experimentRunCount $ lastValueExperiment st + in if n == 1 + then lastValueHtmlSingle st index + else lastValueHtmlMultiple st index + +-- | Get the HTML code for a single run. +lastValueHtmlSingle :: LastValueViewState -> Int -> HtmlWriter () +lastValueHtmlSingle st index = + do header st index + let r = fromJust $ M.lookup 0 (lastValueMap st) + pairs <- liftIO $ readIORef r + forM_ pairs $ \pair -> + formatPair pair (lastValueFormatter $ lastValueView st) + +-- | Get the HTML code for multiple runs +lastValueHtmlMultiple :: LastValueViewState -> Int -> HtmlWriter () +lastValueHtmlMultiple st index = + do header st index + let n = experimentRunCount $ lastValueExperiment st + forM_ [0..(n - 1)] $ \i -> + do let subtitle = + replace "$RUN_INDEX" (show $ i + 1) $ + replace "$RUN_COUNT" (show n) $ + replace "$TITLE" (lastValueTitle $ lastValueView st) + (lastValueRunTitle $ lastValueView st) + writeHtmlHeader4 $ + writeHtmlText subtitle + let r = fromJust $ M.lookup i (lastValueMap st) + pairs <- liftIO $ readIORef r + forM_ pairs $ \pair -> + formatPair pair (lastValueFormatter $ lastValueView st) + +header :: LastValueViewState -> Int -> HtmlWriter () +header st index = + do writeHtmlHeader3WithId ("id" ++ show index) $ + writeHtmlText (lastValueTitle $ lastValueView st) + let description = lastValueDescription $ lastValueView st + unless (null description) $ + writeHtmlParagraph $ + writeHtmlText description + +formatPair :: (String, String) -> ShowS -> HtmlWriter () +formatPair (name, value) formatter = + writeHtmlParagraph $ + do writeHtmlText name + writeHtmlText " = " + writeHtmlText $ formatter value + +-- | Get the TOC item +lastValueTOCHtml :: LastValueViewState -> Int -> HtmlWriter () +lastValueTOCHtml st index = + writeHtmlListItem $ + writeHtmlLink ("#id" ++ show index) $ + writeHtmlText (lastValueTitle $ lastValueView st) diff --git a/Simulation/Aivika/Experiment/Base/SamplingStatsWriter.hs b/Simulation/Aivika/Experiment/Base/SamplingStatsWriter.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Experiment/Base/SamplingStatsWriter.hs @@ -0,0 +1,112 @@ + +-- | +-- Module : Simulation.Aivika.Experiment.Base.SamplingStatsWriter +-- Copyright : Copyright (c) 2012-2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 8.0.1 +-- +-- The module defines 'SamplingStatsWriter' that knows how to write +-- the sampling statistics in HTML. +-- + +module Simulation.Aivika.Experiment.Base.SamplingStatsWriter + (SamplingStatsWriter(..), + defaultSamplingStatsWriter) where + +import Simulation.Aivika.Experiment.Types +import Simulation.Aivika.Experiment.Base.HtmlWriter + +import Simulation.Aivika.Statistics + +-- | Defines a writer that knows how to represent the 'SamplingStats' +-- as the HTML table. +data SamplingStatsWriter a = + SamplingStatsWriter { samplingStatsWidth :: Int, + -- ^ The width of the HTML table. + samplingStatsMeanText :: String, + -- ^ Translated text \"mean\". + samplingStatsDeviationText :: String, + -- ^ Translated text \"deviation\". + samplingStatsMinText :: String, + -- ^ Translated text \"minimum\". + samplingStatsMaxText :: String, + -- ^ Translated text \"maximum\". + samplingStatsCountText :: String, + -- ^ Translated text \"count\". + samplingStatsFormatter :: ShowS, + -- ^ The formatter of numbers. + samplingStatsWrite :: SamplingStatsWriter a -> String -> + SamplingStats a -> HtmlWriter () + -- ^ This function reprensents the named statistics + -- as the HTML table. + } + +-- | The default writer. +defaultSamplingStatsWriter :: Show a => SamplingStatsWriter a +defaultSamplingStatsWriter = + SamplingStatsWriter { + samplingStatsWidth = 400, + samplingStatsMeanText = "mean", + samplingStatsDeviationText = "deviation", + samplingStatsMinText = "minimum", + samplingStatsMaxText = "maximum", + samplingStatsCountText = "count", + samplingStatsFormatter = id, + samplingStatsWrite = \writer name stats -> + do let format x = samplingStatsFormatter writer x + writeHtml "

    " + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "
    " + writeHtml "

    " + writeHtmlText name + writeHtml "" + writeHtml "

    " + writeHtmlText $ samplingStatsMeanText writer + writeHtml "" + writeHtmlText $ format $ show $ samplingStatsMean stats + writeHtml "
    " + writeHtmlText $ samplingStatsDeviationText writer + writeHtml "" + writeHtmlText $ format $ show $ samplingStatsDeviation stats + writeHtml "
    " + writeHtmlText $ samplingStatsMinText writer + writeHtml "" + writeHtmlText $ format $ show $ samplingStatsMin stats + writeHtml "
    " + writeHtmlText $ samplingStatsMaxText writer + writeHtml "" + writeHtmlText $ format $ show $ samplingStatsMax stats + writeHtml "
    " + writeHtmlText $ samplingStatsCountText writer + writeHtml "" + writeHtml $ format $ show $ samplingStatsCount stats + writeHtml "
    " + writeHtml "

    " + } diff --git a/Simulation/Aivika/Experiment/Base/TableView.hs b/Simulation/Aivika/Experiment/Base/TableView.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Experiment/Base/TableView.hs @@ -0,0 +1,258 @@ + +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Simulation.Aivika.Experiment.Base.TableView +-- Copyright : Copyright (c) 2012-2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 8.0.1 +-- +-- The module defines 'TableView' that saves the simulation +-- results in the CSV file(s). +-- + +module Simulation.Aivika.Experiment.Base.TableView + (TableView(..), + defaultTableView) where + +import Control.Monad +import Control.Monad.Trans + +import qualified Data.Map as M +import Data.IORef +import Data.Maybe +import Data.Monoid + +import System.IO +import System.FilePath + +import Simulation.Aivika +import Simulation.Aivika.Experiment.Types +import Simulation.Aivika.Experiment.Base.WebPageRenderer +import Simulation.Aivika.Experiment.Base.FileRenderer +import Simulation.Aivika.Experiment.Base.ExperimentWriter +import Simulation.Aivika.Experiment.Base.HtmlWriter +import Simulation.Aivika.Experiment.Utils (replace) + +-- | Defines the 'View' that saves the simulation results +-- in the CSV file(s). +data TableView = + TableView { tableTitle :: String, + -- ^ This is a title used in HTML. + tableDescription :: String, + -- ^ This is a description in the HTML. + tableLinkText :: String, + -- ^ It specifies the text for the link + -- which is displayed in the HTML page + -- if there is only one simulation run. + -- The link downloads the corresponded + -- CSV file in the browser. If there are + -- more simulation runs, then this link + -- is not shown. + -- + -- An example is + -- + -- @ + -- tableLinkText = \"Download the CSV file\" + -- @ + tableRunLinkText :: String, + -- ^ It specifies the link text which is + -- displayed in the HTML page if there are + -- many simulation runs. Such a link downloads + -- the CSV file for the corresponded run. + -- To define the text, you can use special + -- variables @$LINK@, @$RUN_INDEX@ and @$RUN_COUNT@. + -- + -- An example is + -- + -- @ + -- tableRunLinkText = \"$LINK / Run $RUN_INDEX of $RUN_COUNT\" + -- @ + -- + -- If there is only one run, then the link of + -- this kind is not displayed. Instead, only one + -- link is shown, which text is defined by the + -- 'tableLinkText' field. + tableFileName :: ExperimentFilePath, + -- ^ It defines the file name for each CSV file. + -- It may include special variables @$TITLE@, + -- @$RUN_INDEX@ and @$RUN_COUNT@. + -- + -- An example is + -- + -- @ + -- tableFileName = UniqueFilePath \"$TITLE - $RUN_INDEX.csv\" + -- @ + tableSeparator :: String, + -- ^ It defines the separator for the view. + -- It delimits the cells in the rows of the CSV file. + tableFormatter :: ShowS, + -- ^ It defines the formatter which is applied + -- to all values before they will be written + -- in the CSV file(s). + tablePredicate :: Event Bool, + -- ^ It specifies the predicate that defines + -- when we can save data in the table. + tableTransform :: ResultTransform, + -- ^ The transform applied to the results before receiving series. + tableSeries :: ResultTransform + -- ^ It defines the series to save in the CSV file(s). + } + +-- | The default table view. +defaultTableView :: TableView +defaultTableView = + TableView { tableTitle = "Table", + tableDescription = "This section contains the CSV file(s) with the simulation results.", + tableLinkText = "Download the CSV file", + tableRunLinkText = "$LINK / Run $RUN_INDEX of $RUN_COUNT", + tableFileName = UniqueFilePath "Table($RUN_INDEX).csv", + tableSeparator = ",", + tableFormatter = id, + tablePredicate = return True, + tableTransform = expandResults, + tableSeries = id } + +instance ExperimentView TableView (WebPageRenderer a) where + + outputView v = + let reporter exp renderer dir = + do st <- newTable v exp dir + let context = + WebPageContext $ + WebPageWriter { reporterWriteTOCHtml = tableTOCHtml st, + reporterWriteHtml = tableHtml st } + return ExperimentReporter { reporterInitialise = return (), + reporterFinalise = return (), + reporterSimulate = simulateTable st, + reporterContext = context } + in ExperimentGenerator { generateReporter = reporter } + +instance ExperimentView TableView (FileRenderer a) where + + outputView v = + let reporter exp renderer dir = + do st <- newTable v exp dir + return ExperimentReporter { reporterInitialise = return (), + reporterFinalise = return (), + reporterSimulate = simulateTable st, + reporterContext = FileContext } + in ExperimentGenerator { generateReporter = reporter } + +-- | The state of the view. +data TableViewState = + TableViewState { tableView :: TableView, + tableExperiment :: Experiment, + tableDir :: FilePath, + tableMap :: M.Map Int FilePath } + +-- | Create a new state of the view. +newTable :: TableView -> Experiment -> FilePath -> ExperimentWriter TableViewState +newTable view exp dir = + do let n = experimentRunCount exp + fs <- forM [0..(n - 1)] $ \i -> + resolveFilePath dir $ + mapFilePath (flip replaceExtension ".csv") $ + expandFilePath (tableFileName view) $ + M.fromList [("$TITLE", tableTitle view), + ("$RUN_INDEX", show $ i + 1), + ("$RUN_COUNT", show n)] + liftIO $ forM_ fs $ flip writeFile [] -- reserve the file names + let m = M.fromList $ zip [0..(n - 1)] fs + return TableViewState { tableView = view, + tableExperiment = exp, + tableDir = dir, + tableMap = m } + +-- | Write the tables during the simulation. +simulateTable :: TableViewState -> ExperimentData -> Composite () +simulateTable st expdata = + do let view = tableView st + rs = tableSeries view $ + tableTransform view $ + experimentResults expdata + exts = resultsToStringValues rs + signals = experimentPredefinedSignals expdata + signal = pureResultSignal signals $ + resultSignal rs + separator = tableSeparator view + formatter = tableFormatter view + predicate = tablePredicate view + i <- liftParameter simulationIndex + -- create a new file + let f = fromJust $ M.lookup (i - 1) (tableMap st) + h <- liftIO $ openFile f WriteMode + -- write a header + liftIO $ + do forM_ (zip [0..] exts) $ \(column, ext) -> + do when (column > 0) $ + hPutStr h separator + hPutStr h $ show $ resultValueName ext + hPutStrLn h "" + handleSignalComposite signal $ \t -> + do p <- predicate + when p $ + do forM_ (zip [0..] exts) $ \(column, ext) -> -- write the row + do x <- resultValueData ext -- write the column + liftIO $ + do when (column > 0) $ + hPutStr h separator + hPutStr h $ formatter x + liftIO $ hPutStrLn h "" + disposableComposite $ + DisposableEvent $ + liftIO $ + do when (experimentVerbose $ tableExperiment st) $ + putStr "Generated file " >> putStrLn f + hClose h -- close the file + +-- | Get the HTML code. +tableHtml :: TableViewState -> Int -> HtmlWriter () +tableHtml st index = + let n = experimentRunCount $ tableExperiment st + in if n == 1 + then tableHtmlSingle st index + else tableHtmlMultiple st index + +-- | Get the HTML code for a single run. +tableHtmlSingle :: TableViewState -> Int -> HtmlWriter () +tableHtmlSingle st index = + do header st index + let f = fromJust $ M.lookup 0 (tableMap st) + writeHtmlParagraph $ + writeHtmlLink (makeRelative (tableDir st) f) $ + writeHtmlText (tableLinkText $ tableView st) + +-- | Get the HTML code for multiple runs +tableHtmlMultiple :: TableViewState -> Int -> HtmlWriter () +tableHtmlMultiple st index = + do header st index + let n = experimentRunCount $ tableExperiment st + forM_ [0..(n - 1)] $ \i -> + do let f = fromJust $ M.lookup i (tableMap st) + sublink = + replace "$RUN_INDEX" (show $ i + 1) $ + replace "$RUN_COUNT" (show n) $ + replace "$LINK" (tableLinkText $ tableView st) + (tableRunLinkText $ tableView st) + writeHtmlParagraph $ + writeHtmlLink (makeRelative (tableDir st) f) $ + writeHtmlText sublink + +header :: TableViewState -> Int -> HtmlWriter () +header st index = + do writeHtmlHeader3WithId ("id" ++ show index) $ + writeHtmlText (tableTitle $ tableView st) + let description = tableDescription $ tableView st + unless (null description) $ + writeHtmlParagraph $ + writeHtmlText description + +-- | Get the TOC item +tableTOCHtml :: TableViewState -> Int -> HtmlWriter () +tableTOCHtml st index = + writeHtmlListItem $ + writeHtmlLink ("#id" ++ show index) $ + writeHtmlText (tableTitle $ tableView st) diff --git a/Simulation/Aivika/Experiment/Base/TimingStatsView.hs b/Simulation/Aivika/Experiment/Base/TimingStatsView.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Experiment/Base/TimingStatsView.hs @@ -0,0 +1,187 @@ + +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Simulation.Aivika.Experiment.Base.TimingStatsView +-- Copyright : Copyright (c) 2012-2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 8.0.1 +-- +-- The module defines 'TimingStatsView' that shows the timing statistics +-- for the variables for every simulation run separately. +-- + +module Simulation.Aivika.Experiment.Base.TimingStatsView + (TimingStatsView(..), + defaultTimingStatsView) where + +import Control.Monad +import Control.Monad.Trans + +import qualified Data.Map as M +import Data.IORef +import Data.Maybe +import Data.Monoid + +import Simulation.Aivika +import Simulation.Aivika.Experiment.Types +import Simulation.Aivika.Experiment.Base.WebPageRenderer +import Simulation.Aivika.Experiment.Base.ExperimentWriter +import Simulation.Aivika.Experiment.Base.HtmlWriter +import Simulation.Aivika.Experiment.Base.TimingStatsWriter +import Simulation.Aivika.Experiment.Utils (replace) + +-- | Defines the 'View' that shows the timing statistics +-- for variables for every simulation run separately. +data TimingStatsView = + TimingStatsView { timingStatsTitle :: String, + -- ^ The title for the view. + timingStatsRunTitle :: String, + -- ^ The run title for the view. It may include + -- special variables @$RUN_INDEX@, @$RUN_COUNT@ and + -- @$TITLE@. + -- + -- An example is + -- + -- @ + -- timingStatsRunTitle = \"$TITLE / Run $RUN_INDEX of $RUN_COUNT\" + -- @ + timingStatsDescription :: String, + -- ^ The description for the view. + timingStatsWriter :: TimingStatsWriter Double, + -- ^ It shows the timing statistics. + timingStatsPredicate :: Event Bool, + -- ^ Specifies when gathering the statistics. + timingStatsTransform :: ResultTransform, + -- ^ The transform applied to the results before receiving series. + timingStatsSeries :: ResultTransform + -- ^ It defines the series for which the statistics to be collected. + } + +-- | This is the default view. +defaultTimingStatsView :: TimingStatsView +defaultTimingStatsView = + TimingStatsView { timingStatsTitle = "Statistics for Time-Persistent Variables", + timingStatsRunTitle = "$TITLE / Run $RUN_INDEX of $RUN_COUNT", + timingStatsDescription = "The statistical data are gathered in the time points.", + timingStatsWriter = defaultTimingStatsWriter, + timingStatsPredicate = return True, + timingStatsTransform = id, + timingStatsSeries = id } + +instance ExperimentView TimingStatsView (WebPageRenderer a) where + + outputView v = + let reporter exp renderer dir = + do st <- newTimingStats v exp + let context = + WebPageContext $ + WebPageWriter { reporterWriteTOCHtml = timingStatsTOCHtml st, + reporterWriteHtml = timingStatsHtml st } + return ExperimentReporter { reporterInitialise = return (), + reporterFinalise = return (), + reporterSimulate = simulateTimingStats st, + reporterContext = context } + in ExperimentGenerator { generateReporter = reporter } + +-- | The state of the view. +data TimingStatsViewState = + TimingStatsViewState { timingStatsView :: TimingStatsView, + timingStatsExperiment :: Experiment, + timingStatsMap :: M.Map Int (IORef [(String, IORef (TimingStats Double))]) } + +-- | Create a new state of the view. +newTimingStats :: TimingStatsView -> Experiment -> ExperimentWriter TimingStatsViewState +newTimingStats view exp = + do let n = experimentRunCount exp + rs <- forM [0..(n - 1)] $ \i -> liftIO $ newIORef [] + let m = M.fromList $ zip [0..(n - 1)] rs + return TimingStatsViewState { timingStatsView = view, + timingStatsExperiment = exp, + timingStatsMap = m } + +-- | Get the timing statistics during the simulation. +simulateTimingStats :: TimingStatsViewState -> ExperimentData -> Composite () +simulateTimingStats st expdata = + do let view = timingStatsView st + rs = timingStatsSeries view $ + timingStatsTransform view $ + experimentResults expdata + exts = resultsToDoubleValues rs + signals = experimentPredefinedSignals expdata + signal = filterSignalM (const predicate) $ + pureResultSignal signals $ + resultSignal rs + predicate = timingStatsPredicate view + i <- liftParameter simulationIndex + let r = fromJust $ M.lookup (i - 1) $ timingStatsMap st + forM_ exts $ \ext -> + do stats <- liftIO $ newIORef emptyTimingStats + let name = resultValueName ext + liftIO $ modifyIORef r ((:) (name, stats)) + handleSignalComposite signal $ \_ -> + do t <- liftDynamics time + x <- resultValueData ext + liftIO $ + do y <- readIORef stats + let y' = addTimingStats t x y + y' `seq` writeIORef stats y' + +-- | Get the HTML code. +timingStatsHtml :: TimingStatsViewState -> Int -> HtmlWriter () +timingStatsHtml st index = + let n = experimentRunCount $ timingStatsExperiment st + in if n == 1 + then timingStatsHtmlSingle st index + else timingStatsHtmlMultiple st index + +-- | Get the HTML code for a single run. +timingStatsHtmlSingle :: TimingStatsViewState -> Int -> HtmlWriter () +timingStatsHtmlSingle st index = + do header st index + let r = fromJust $ M.lookup 0 (timingStatsMap st) + pairs <- liftIO $ readIORef r + forM_ (reverse pairs) $ \(name, r) -> + do stats <- liftIO $ readIORef r + let writer = timingStatsWriter (timingStatsView st) + write = timingStatsWrite writer + write writer name stats + +-- | Get the HTML code for multiple runs +timingStatsHtmlMultiple :: TimingStatsViewState -> Int -> HtmlWriter () +timingStatsHtmlMultiple st index = + do header st index + let n = experimentRunCount $ timingStatsExperiment st + forM_ [0..(n - 1)] $ \i -> + do let subtitle = + replace "$RUN_INDEX" (show $ i + 1) $ + replace "$RUN_COUNT" (show n) $ + replace "$TITLE" (timingStatsTitle $ timingStatsView st) + (timingStatsRunTitle $ timingStatsView st) + writeHtmlHeader4 $ + writeHtmlText subtitle + let r = fromJust $ M.lookup i (timingStatsMap st) + pairs <- liftIO $ readIORef r + forM_ (reverse pairs) $ \(name, r) -> + do stats <- liftIO $ readIORef r + let writer = timingStatsWriter (timingStatsView st) + write = timingStatsWrite writer + write writer name stats + +header :: TimingStatsViewState -> Int -> HtmlWriter () +header st index = + do writeHtmlHeader3WithId ("id" ++ show index) $ + writeHtmlText (timingStatsTitle $ timingStatsView st) + let description = timingStatsDescription $ timingStatsView st + unless (null description) $ + writeHtmlParagraph $ + writeHtmlText description + +-- | Get the TOC item +timingStatsTOCHtml :: TimingStatsViewState -> Int -> HtmlWriter () +timingStatsTOCHtml st index = + writeHtmlListItem $ + writeHtmlLink ("#id" ++ show index) $ + writeHtmlText (timingStatsTitle $ timingStatsView st) diff --git a/Simulation/Aivika/Experiment/Base/TimingStatsWriter.hs b/Simulation/Aivika/Experiment/Base/TimingStatsWriter.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Experiment/Base/TimingStatsWriter.hs @@ -0,0 +1,130 @@ + +-- | +-- Module : Simulation.Aivika.Experiment.Base.TimingStatsWriter +-- Copyright : Copyright (c) 2012-2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 8.0.1 +-- +-- The module defines 'TimingStatsWriter' that knows how to write +-- the timing statistics in HTML. +-- + +module Simulation.Aivika.Experiment.Base.TimingStatsWriter + (TimingStatsWriter(..), + defaultTimingStatsWriter) where + +import Simulation.Aivika.Experiment.Types +import Simulation.Aivika.Experiment.Base.HtmlWriter + +import Simulation.Aivika.Statistics + +-- | Defines a writer that knows how to represent the 'TimingStats' +-- as the HTML table. +data TimingStatsWriter a = + TimingStatsWriter { timingStatsWidth :: Int, + -- ^ The width of the HTML table. + timingStatsTimeText :: String, + -- ^ Translated text \"time\". + timingStatsMeanText :: String, + -- ^ Translated text \"mean\". + timingStatsDeviationText :: String, + -- ^ Translated text \"deviation\". + timingStatsMinText :: String, + -- ^ Translated text \"minimum\". + timingStatsMaxText :: String, + -- ^ Translated text \"maximum\". + timingStatsFormatter :: ShowS, + -- ^ The formatter of numbers. + timingStatsWrite :: TimingStatsWriter a -> String -> + TimingStats a -> HtmlWriter () + -- ^ This function reprensents the named statistics + -- as the HTML table. + } + +-- | The default writer. +defaultTimingStatsWriter :: (Show a, TimingData a) => TimingStatsWriter a +defaultTimingStatsWriter = + TimingStatsWriter { + timingStatsWidth = 400, + timingStatsMeanText = "mean", + timingStatsTimeText = "time", + timingStatsDeviationText = "deviation", + timingStatsMinText = "minimum", + timingStatsMaxText = "maximum", + timingStatsFormatter = id, + timingStatsWrite = \writer name stats -> + do let format x = timingStatsFormatter writer x + writeHtml "

    " + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "" + writeHtml "
    " + writeHtml "

    " + writeHtmlText name + writeHtml "" + writeHtml "

    " + writeHtmlText $ timingStatsMeanText writer + writeHtml "" + writeHtmlText $ format $ show $ timingStatsMean stats + writeHtml "
    " + writeHtmlText $ timingStatsDeviationText writer + writeHtml "" + writeHtmlText $ format $ show $ timingStatsDeviation stats + writeHtml "
    " + writeHtmlText $ timingStatsMinText writer + writeHtml "" + writeHtmlText $ format $ show $ timingStatsMin stats + writeHtml "" + writeHtmlText "(" + writeHtmlText $ timingStatsTimeText writer + writeHtmlText " = " + writeHtmlText $ format $ show $ timingStatsMinTime stats + writeHtmlText ")" + writeHtml "
    " + writeHtmlText $ timingStatsMaxText writer + writeHtml "" + writeHtmlText $ format $ show $ timingStatsMax stats + writeHtml "" + writeHtmlText "(" + writeHtmlText $ timingStatsTimeText writer + writeHtmlText " = " + writeHtmlText $ format $ show $ timingStatsMaxTime stats + writeHtmlText ")" + writeHtml "
    " + writeHtmlText $ timingStatsTimeText writer + writeHtml "" + writeHtml "[" + writeHtml $ format $ show $ timingStatsStartTime stats + writeHtml "; " + writeHtml $ format $ show $ timingStatsLastTime stats + writeHtml "]" + writeHtml "
    " + writeHtml "

    " + } diff --git a/Simulation/Aivika/Experiment/Base/WebPageRenderer.hs b/Simulation/Aivika/Experiment/Base/WebPageRenderer.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Experiment/Base/WebPageRenderer.hs @@ -0,0 +1,108 @@ + +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Simulation.Aivika.Experiment.Base.WebPageRenderer +-- Copyright : Copyright (c) 2012-2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 8.0.1 +-- +-- It defines a renderer that creates a web page when running the simulation experiment. +-- + +module Simulation.Aivika.Experiment.Base.WebPageRenderer where + +import Control.Monad +import Control.Monad.Trans + +import System.IO +import System.Directory +import System.FilePath + +import Simulation.Aivika +import Simulation.Aivika.Trans.Exception +import Simulation.Aivika.Experiment.Types +import Simulation.Aivika.Experiment.Base.HtmlWriter +import Simulation.Aivika.Experiment.Base.ExperimentWriter + +-- | It defines the web page renderer for simulation 'Experiment'. +data WebPageRenderer a = WebPageRenderer a ExperimentFilePath + -- ^ A renderer that depends on the provided parameter and + -- a directory path, where the simulation results are saved in. + +-- | It replies to the requests made by the web page renderer. +data WebPageWriter = + WebPageWriter { reporterWriteTOCHtml :: Int -> HtmlWriter (), + -- ^ Return a TOC (Table of Contents) item for + -- the HTML index file after the finalisation + -- function is called, i.e. in the very end. + -- The agument specifies the ordered number of + -- the item. + -- + -- You should wrap your HTML in 'writeHtmlListItem'. + reporterWriteHtml :: Int -> HtmlWriter () + -- ^ Return an HTML code for the index file + -- after the finalisation function is called, + -- i.e. in the very end. The agument specifies + -- the ordered number of the item. + } + +-- | A convenient type synonym for describing a web page generator. +type WebPageGenerator a = ExperimentGenerator (WebPageRenderer a) + +-- | Rendering a web page with results when running the simulation experiment. +instance ExperimentRendering (WebPageRenderer a) where + + -- | A web page context. + newtype ExperimentContext (WebPageRenderer a) = + WebPageContext { runWebPageContext :: WebPageWriter + -- ^ Run the web page context. + } + + -- | A web page environment. + type ExperimentEnvironment (WebPageRenderer a) = FilePath + + -- | A web page rendering monad. + type ExperimentMonad (WebPageRenderer a) = ExperimentWriter + + liftExperiment r = runExperimentWriter + + prepareExperiment e (WebPageRenderer _ path0) = + do path <- resolveFilePath "" path0 + liftIO $ do + when (experimentVerbose e) $ + do putStr "Updating directory " + putStrLn path + createDirectoryIfMissing True path + return path + + renderExperiment e r reporters path = + do let html :: HtmlWriter () + html = + writeHtmlDocumentWithTitle (experimentTitle e) $ + do writeHtmlList $ + forM_ (zip [1..] reporters) $ \(i, reporter) -> + reporterWriteTOCHtml (runWebPageContext $ + reporterContext reporter) i + writeHtmlBreak + unless (null $ experimentDescription e) $ + writeHtmlParagraph $ + writeHtmlText $ experimentDescription e + forM_ (zip [1..] reporters) $ \(i, reporter) -> + reporterWriteHtml (runWebPageContext $ + reporterContext reporter) i + file = combine path "index.html" + ((), contents) <- runHtmlWriter html id + liftIO $ + withFile file WriteMode $ \h -> + do hSetEncoding h utf8 + hPutStr h (contents []) + when (experimentVerbose e) $ + do putStr "Generated file " + putStrLn file + + onExperimentCompleted e r path = return () + + onExperimentFailed e r path e' = throwComp e' diff --git a/Simulation/Aivika/Experiment/Concurrent/MVar.hs b/Simulation/Aivika/Experiment/Concurrent/MVar.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Experiment/Concurrent/MVar.hs @@ -0,0 +1,46 @@ + +-- | +-- Module : Simulation.Aivika.Experiment.Concurrent.MVar +-- Copyright : Copyright (c) 2012-2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 8.0.1 +-- +-- The module defines helper functions for working with synchronized variable 'MVar'. +-- + +module Simulation.Aivika.Experiment.Concurrent.MVar + (maybeReadMVar, + maybePutMVar) where + +import Control.Exception +import Control.Concurrent.MVar + +import Data.Maybe + +-- | Like 'maybe' but for the synchronized variable. +maybeReadMVar :: b -> (a -> IO b) -> MVar (Maybe a) -> IO b +maybeReadMVar b0 f x = + do a <- readMVar x + case a of + Just a -> f a + Nothing -> return b0 + +-- | Update the contents if the variable was empty and then return a result of +-- applying the specified function to either the initial or current value. +maybePutMVar :: MVar (Maybe a) -> IO a -> (a -> IO b) -> IO b +maybePutMVar x m0 f = + mask_ $ + do a <- takeMVar x + case a of + Just a -> + do putMVar x (Just a) + f a + Nothing -> + do let handle :: SomeException -> IO a + handle e = do putMVar x Nothing + throw e + a0 <- catch m0 handle + putMVar x (Just a0) + f a0 diff --git a/Simulation/Aivika/Experiment/ExperimentSpecsView.hs b/Simulation/Aivika/Experiment/ExperimentSpecsView.hs deleted file mode 100644 --- a/Simulation/Aivika/Experiment/ExperimentSpecsView.hs +++ /dev/null @@ -1,97 +0,0 @@ - -{-# LANGUAGE MultiParamTypeClasses #-} - --- | --- Module : Simulation.Aivika.Experiment.ExperimentSpecsView --- Copyright : Copyright (c) 2012-2015, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.10.1 --- --- The module defines 'ExperimentSpecsView' that shows the --- experiment specs. --- - -module Simulation.Aivika.Experiment.ExperimentSpecsView - (ExperimentSpecsView(..), - defaultExperimentSpecsView) where - -import Control.Monad -import Control.Monad.Trans - -import Data.Monoid - -import Simulation.Aivika.Experiment.Types -import Simulation.Aivika.Experiment.WebPageRenderer -import Simulation.Aivika.Experiment.HtmlWriter -import Simulation.Aivika.Experiment.ExperimentWriter -import Simulation.Aivika.Experiment.ExperimentSpecsWriter - --- | Defines the 'View' that shows the experiment specs. -data ExperimentSpecsView = - ExperimentSpecsView { experimentSpecsTitle :: String, - -- ^ The title for the view. - experimentSpecsDescription :: String, - -- ^ The description for the view. - experimentSpecsWriter :: ExperimentSpecsWriter - -- ^ It shows the specs. - } - --- | This is the default view. -defaultExperimentSpecsView :: ExperimentSpecsView -defaultExperimentSpecsView = - ExperimentSpecsView { experimentSpecsTitle = "Experiment Specs", - experimentSpecsDescription = "It shows the experiment specs.", - experimentSpecsWriter = defaultExperimentSpecsWriter } - -instance ExperimentView ExperimentSpecsView (WebPageRenderer a) where - - outputView v = - let reporter exp renderer dir = - do st <- newExperimentSpecs v exp - let context = - WebPageContext $ - WebPageWriter { reporterWriteTOCHtml = experimentSpecsTOCHtml st, - reporterWriteHtml = experimentSpecsHtml st } - return ExperimentReporter { reporterInitialise = return (), - reporterFinalise = return (), - reporterSimulate = const $ return mempty, - reporterContext = context } - in ExperimentGenerator { generateReporter = reporter } - --- | The state of the view. -data ExperimentSpecsViewState = - ExperimentSpecsViewState { experimentSpecsView :: ExperimentSpecsView, - experimentSpecsExperiment :: Experiment } - --- | Create a new state of the view. -newExperimentSpecs :: ExperimentSpecsView -> Experiment -> ExperimentWriter ExperimentSpecsViewState -newExperimentSpecs view exp = - return ExperimentSpecsViewState { experimentSpecsView = view, - experimentSpecsExperiment = exp } - --- | Get the HTML code. -experimentSpecsHtml :: ExperimentSpecsViewState -> Int -> HtmlWriter () -experimentSpecsHtml st index = - do header st index - let writer = experimentSpecsWriter (experimentSpecsView st) - write = experimentSpecsWrite writer - exp = experimentSpecsExperiment st - write writer exp - -header :: ExperimentSpecsViewState -> Int -> HtmlWriter () -header st index = - do writeHtmlHeader3WithId ("id" ++ show index) $ - writeHtmlText (experimentSpecsTitle $ experimentSpecsView st) - let description = experimentSpecsDescription $ experimentSpecsView st - unless (null description) $ - writeHtmlParagraph $ - writeHtmlText description - --- | Get the TOC item -experimentSpecsTOCHtml :: ExperimentSpecsViewState -> Int -> HtmlWriter () -experimentSpecsTOCHtml st index = - writeHtmlListItem $ - writeHtmlLink ("#id" ++ show index) $ - writeHtmlText (experimentSpecsTitle $ experimentSpecsView st) diff --git a/Simulation/Aivika/Experiment/ExperimentSpecsWriter.hs b/Simulation/Aivika/Experiment/ExperimentSpecsWriter.hs deleted file mode 100644 --- a/Simulation/Aivika/Experiment/ExperimentSpecsWriter.hs +++ /dev/null @@ -1,131 +0,0 @@ - --- | --- Module : Simulation.Aivika.Experiment.ExperimentSpecsWriter --- Copyright : Copyright (c) 2012-2015, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.10.1 --- --- The module defines 'ExperimentSpecsWriter' that knows how to write --- in HTML the experiment specs which include the simulation specs and --- the number of simulation runs. --- - -module Simulation.Aivika.Experiment.ExperimentSpecsWriter - (ExperimentSpecsWriter(..), - defaultExperimentSpecsWriter) where - -import Simulation.Aivika -import Simulation.Aivika.Experiment.Types -import Simulation.Aivika.Experiment.HtmlWriter - --- | Defines a writer that knows how to represent the --- experiment specs as the HTML table. -data ExperimentSpecsWriter = - ExperimentSpecsWriter { experimentSpecsWidth :: Int, - -- ^ The width of the HTML table. - experimentSpecsNameText :: String, - -- ^ Translated text \"Experiment Specs\". - experimentSpecsStartTimeText :: String, - -- ^ Translated text \"start time\". - experimentSpecsStopTimeText :: String, - -- ^ Translated text \"stop time\". - experimentSpecsDTText :: String, - -- ^ Translated text \"time step\". - experimentSpecsRunCountText :: String, - -- ^ Translated text \"run count\". - experimentSpecsIntegMethodText :: String, - -- ^ Translated text \"integration method\". - experimentSpecsEulerText :: String, - -- ^ Translated text \"Euler's\". - experimentSpecsRungeKutta2Text :: String, - -- ^ Translated text \"the 2-nd order Runge-Kutta\". - experimentSpecsRungeKutta4Text :: String, - -- ^ Translated text \"the 4-th order Runge-Kutta\". - experimentSpecsFormatter :: ShowS, - -- ^ The formatter of numbers. - experimentSpecsWrite :: ExperimentSpecsWriter - -> Experiment - -> HtmlWriter () - -- ^ This function creates HTML. - } - --- | The default writer. -defaultExperimentSpecsWriter :: ExperimentSpecsWriter -defaultExperimentSpecsWriter = - ExperimentSpecsWriter { - experimentSpecsWidth = 400, - experimentSpecsNameText = "Experiment Specs", - experimentSpecsStartTimeText = "start time", - experimentSpecsStopTimeText = "stop time", - experimentSpecsDTText = "time step", - experimentSpecsRunCountText = "run count", - experimentSpecsIntegMethodText = "integration method", - experimentSpecsEulerText = "Euler's", - experimentSpecsRungeKutta2Text = "the 2-nd order Runge-Kutta", - experimentSpecsRungeKutta4Text = "the 4-th order Runge-Kutta", - experimentSpecsFormatter = id, - experimentSpecsWrite = \writer exp -> - do let format x = experimentSpecsFormatter writer x - writeHtml "

    " - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "
    " - writeHtml "

    " - writeHtmlText $ experimentSpecsNameText writer - writeHtml "

    " - writeHtml "
    " - writeHtmlText $ experimentSpecsStartTimeText writer - writeHtml "" - writeHtmlText $ format $ show $ spcStartTime $ experimentSpecs exp - writeHtml "
    " - writeHtmlText $ experimentSpecsStopTimeText writer - writeHtml "" - writeHtmlText $ format $ show $ spcStopTime $ experimentSpecs exp - writeHtml "
    " - writeHtmlText $ experimentSpecsDTText writer - writeHtml "" - writeHtmlText $ format $ show $ spcDT $ experimentSpecs exp - writeHtml "
    " - writeHtmlText $ experimentSpecsRunCountText writer - writeHtml "" - writeHtmlText $ format $ show $ experimentRunCount exp - writeHtml "
    " - writeHtmlText $ experimentSpecsIntegMethodText writer - writeHtml "" - let method = spcMethod $ experimentSpecs exp - writeHtml $ methodName method writer - writeHtml "
    " - writeHtml "

    " - } - --- | Return the method name. -methodName :: Method -> ExperimentSpecsWriter -> String -methodName Euler = experimentSpecsEulerText -methodName RungeKutta2 = experimentSpecsRungeKutta2Text -methodName RungeKutta4 = experimentSpecsRungeKutta4Text diff --git a/Simulation/Aivika/Experiment/ExperimentWriter.hs b/Simulation/Aivika/Experiment/ExperimentWriter.hs deleted file mode 100644 --- a/Simulation/Aivika/Experiment/ExperimentWriter.hs +++ /dev/null @@ -1,129 +0,0 @@ - --- | --- Module : Simulation.Aivika.Experiment.ExperimentWriter --- Copyright : Copyright (c) 2012-2015, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.10.1 --- --- It defines the 'Exp' monad that allows providing computation with --- an ability to resolve file paths. --- -module Simulation.Aivika.Experiment.ExperimentWriter - (ExperimentWriter, - runExperimentWriter, - ExperimentFilePath(..), - resolveFilePath, - expandFilePath, - mapFilePath) where - -import Control.Applicative -import Control.Monad -import Control.Monad.Trans -import Control.Monad.State - -import qualified Data.Map as M -import qualified Data.Set as S - -import System.Directory -import System.FilePath - -import Simulation.Aivika.Experiment.MRef -import Simulation.Aivika.Experiment.Utils (replace) - --- | Specifies the file name, unique or writable, which can be appended with extension if required. -data ExperimentFilePath = WritableFilePath FilePath - -- ^ The file which is overwritten in - -- case if it existed before. - | UniqueFilePath FilePath - -- ^ The file which is always unique, - -- when an automatically generated suffix - -- is added to the name in case of need. - --- | Resolve the file path relative to the specified directory passed in the first argument --- and taking into account a possible requirement to have an unique file name. -resolveFilePath :: FilePath -> ExperimentFilePath -> ExperimentWriter FilePath -resolveFilePath dir (WritableFilePath path) = - return $ dir path -resolveFilePath dir (UniqueFilePath path) = - ExperimentWriter $ \r -> - let (name, ext) = splitExtension path - loop y i = - do let n = dir addExtension y ext - y' = name ++ "(" ++ show i ++ ")" - f1 <- doesFileExist n - f2 <- doesDirectoryExist n - if f1 || f2 - then loop y' (i + 1) - else do n' <- liftIO $ - modifyMRef r $ \s -> - if S.member n s - then return (s, Nothing) - else return (S.insert n s, Just n) - case n' of - Nothing -> loop y' (i + 1) - Just n' -> return n' - in loop name 2 - --- | Expand the file path using the specified table of substitutions. -expandFilePath :: ExperimentFilePath -> M.Map String String -> ExperimentFilePath -expandFilePath (WritableFilePath path) map = WritableFilePath (expandTemplates path map) -expandFilePath (UniqueFilePath path) map = UniqueFilePath (expandTemplates path map) - --- | Expand the string templates using the specified table of substitutions. -expandTemplates :: String -> M.Map String String -> String -expandTemplates name map = name' where - ((), name') = flip runState name $ - forM_ (M.assocs map) $ \(k, v) -> - do a <- get - put $ replace k v a - --- | Transform the file path using the specified function. -mapFilePath :: (FilePath -> FilePath) -> ExperimentFilePath -> ExperimentFilePath -mapFilePath f (WritableFilePath path) = WritableFilePath (f path) -mapFilePath f (UniqueFilePath path) = UniqueFilePath (f path) - - --- | Defines an 'IO' derived computation whithin which we can resolve the unique file paths. -newtype ExperimentWriter a = ExperimentWriter (MRef (S.Set String) -> IO a) - -instance Functor ExperimentWriter where - - {-# INLINE fmap #-} - fmap f (ExperimentWriter m) = - ExperimentWriter $ \r -> fmap f (m r) - -instance Applicative ExperimentWriter where - - {-# INLINE pure #-} - pure a = - ExperimentWriter $ \r -> return a - - {-# INLINE (<*>) #-} - (ExperimentWriter f) <*> (ExperimentWriter m) = - ExperimentWriter $ \r -> f r <*> m r - -instance Monad ExperimentWriter where - - {-# INLINE return #-} - return a = - ExperimentWriter $ \r -> return a - - {-# INLINE (>>=) #-} - (ExperimentWriter m) >>= k = - ExperimentWriter $ \r -> - do a <- m r - let ExperimentWriter b = k a - b r - -instance MonadIO ExperimentWriter where - - {-# INLINE liftIO #-} - liftIO m = ExperimentWriter $ \r -> liftIO m - --- | Run the 'ExperimentWriter' computation. -runExperimentWriter :: ExperimentWriter a -> IO a -runExperimentWriter (ExperimentWriter m) = - do r <- newMRef S.empty - m r diff --git a/Simulation/Aivika/Experiment/FileRenderer.hs b/Simulation/Aivika/Experiment/FileRenderer.hs deleted file mode 100644 --- a/Simulation/Aivika/Experiment/FileRenderer.hs +++ /dev/null @@ -1,33 +0,0 @@ - -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Simulation.Aivika.Experiment.Types --- Copyright : Copyright (c) 2012-2015, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.10.1 --- --- It defines a renderer that saves the results in files when running the simulation experiment. --- - -module Simulation.Aivika.Experiment.FileRenderer where - -import Simulation.Aivika.Experiment.Types - --- | It defines a simulation 'Experiment' renderer that saves the results in files. -data FileRenderer a = FileRenderer a - -- ^ A file renderer that depends on the provided parameter. - --- | A convenient type synonym for describing a file generator. -type FileGenerator a = ExperimentGenerator (FileRenderer a) - --- | Saving the results of simulation in files when running the experiment. -instance ExperimentRendering (FileRenderer a) where - - -- | A file rendering context. - data ExperimentContext (FileRenderer a) = FileContext - -- ^ A file context constructor. - - renderExperiment e r reporters path = return () diff --git a/Simulation/Aivika/Experiment/FinalStatsView.hs b/Simulation/Aivika/Experiment/FinalStatsView.hs deleted file mode 100644 --- a/Simulation/Aivika/Experiment/FinalStatsView.hs +++ /dev/null @@ -1,166 +0,0 @@ - -{-# LANGUAGE MultiParamTypeClasses #-} - --- | --- Module : Simulation.Aivika.Experiment.FinalStatsView --- Copyright : Copyright (c) 2012-2015, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.10.1 --- --- The module defines 'FinalStatsView' gathers the statistics --- in the final time points for different simulation runs. --- - -module Simulation.Aivika.Experiment.FinalStatsView - (FinalStatsView(..), - defaultFinalStatsView) where - -import Control.Monad -import Control.Monad.Trans -import Control.Concurrent.MVar - -import Data.IORef -import Data.Maybe - -import Simulation.Aivika -import Simulation.Aivika.Experiment.Types -import Simulation.Aivika.Experiment.WebPageRenderer -import Simulation.Aivika.Experiment.ExperimentWriter -import Simulation.Aivika.Experiment.HtmlWriter -import Simulation.Aivika.Experiment.SamplingStatsWriter -import Simulation.Aivika.Experiment.MRef - --- | Defines the 'View' that gathers the statistics --- in the final time points. -data FinalStatsView = - FinalStatsView { finalStatsTitle :: String, - -- ^ This is a title for the view. - finalStatsDescription :: String, - -- ^ This is a description used in HTML. - finalStatsWriter :: SamplingStatsWriter Double, - -- ^ It shows the sampling statistics. - finalStatsPredicate :: Event Bool, - -- ^ It specifies the predicate that defines - -- when we count data when gathering the statistics. - finalStatsTransform :: ResultTransform, - -- ^ The transform applied to the results before receiving series. - finalStatsSeries :: ResultTransform - -- ^ It defines the series for which the statistics to be collected. - } - --- | The default statistics view. -defaultFinalStatsView :: FinalStatsView -defaultFinalStatsView = - FinalStatsView { finalStatsTitle = "Final Statistics", - finalStatsDescription = "Statistics is gathered in final time points for all runs.", - finalStatsWriter = defaultSamplingStatsWriter, - finalStatsPredicate = return True, - finalStatsTransform = id, - finalStatsSeries = id } - -instance ExperimentView FinalStatsView (WebPageRenderer a) where - - outputView v = - let reporter exp renderer dir = - do st <- newFinalStats v exp dir - let context = - WebPageContext $ - WebPageWriter { reporterWriteTOCHtml = finalStatsTOCHtml st, - reporterWriteHtml = finalStatsHtml st } - return ExperimentReporter { reporterInitialise = return (), - reporterFinalise = return (), - reporterSimulate = simulateFinalStats st, - reporterContext = context } - in ExperimentGenerator { generateReporter = reporter } - --- | The state of the view. -data FinalStatsViewState = - FinalStatsViewState { finalStatsView :: FinalStatsView, - finalStatsExperiment :: Experiment, - finalStatsResults :: MRef (Maybe FinalStatsResults) } - --- | The statistics results. -data FinalStatsResults = - FinalStatsResults { finalStatsNames :: [String], - finalStatsValues :: [IORef (SamplingStats Double)] } - --- | Create a new state of the view. -newFinalStats :: FinalStatsView -> Experiment -> FilePath -> ExperimentWriter FinalStatsViewState -newFinalStats view exp dir = - do r <- liftIO $ newMRef Nothing - return FinalStatsViewState { finalStatsView = view, - finalStatsExperiment = exp, - finalStatsResults = r } - --- | Create new statistics results. -newFinalStatsResults :: [String] -> Experiment -> IO FinalStatsResults -newFinalStatsResults names exp = - do values <- forM names $ \_ -> liftIO $ newIORef emptySamplingStats - return FinalStatsResults { finalStatsNames = names, - finalStatsValues = values } - --- | Require to return unique final statistics results associated with the specified state. -requireFinalStatsResults :: FinalStatsViewState -> [String] -> IO FinalStatsResults -requireFinalStatsResults st names = - maybeWriteMRef (finalStatsResults st) - (newFinalStatsResults names (finalStatsExperiment st)) $ \results -> - if (names /= finalStatsNames results) - then error "Series with different names are returned for different runs: requireFinalStatsResults" - else return results - --- | Simulate the specified series. -simulateFinalStats :: FinalStatsViewState -> ExperimentData -> Event DisposableEvent -simulateFinalStats st expdata = - do let view = finalStatsView st - rs = finalStatsSeries view $ - finalStatsTransform view $ - experimentResults expdata - exts = resultsToDoubleStatsEitherValues rs - signals = experimentPredefinedSignals expdata - signal = filterSignalM (const predicate) $ - resultSignalInStopTime signals - names = map resultValueName exts - predicate = finalStatsPredicate view - results <- liftIO $ requireFinalStatsResults st names - let values = finalStatsValues results - handleSignal signal $ \_ -> - forM_ (zip exts values) $ \(ext, value) -> - do x <- resultValueData ext - liftIO $ - do y <- readIORef value - let y' = combineSamplingStatsEither x y - y' `seq` writeIORef value y' - --- | Get the HTML code. -finalStatsHtml :: FinalStatsViewState -> Int -> HtmlWriter () -finalStatsHtml st index = - do header st index - results <- liftIO $ readMRef (finalStatsResults st) - case results of - Nothing -> return () - Just results -> - do let names = finalStatsNames results - values = finalStatsValues results - writer = finalStatsWriter (finalStatsView st) - write = samplingStatsWrite writer - forM_ (zip names values) $ \(name, value) -> - do stats <- liftIO $ readIORef value - write writer name stats - -header :: FinalStatsViewState -> Int -> HtmlWriter () -header st index = - do writeHtmlHeader3WithId ("id" ++ show index) $ - writeHtmlText (finalStatsTitle $ finalStatsView st) - let description = finalStatsDescription $ finalStatsView st - unless (null description) $ - writeHtmlParagraph $ - writeHtmlText description - --- | Get the TOC item. -finalStatsTOCHtml :: FinalStatsViewState -> Int -> HtmlWriter () -finalStatsTOCHtml st index = - writeHtmlListItem $ - writeHtmlLink ("#id" ++ show index) $ - writeHtmlText (finalStatsTitle $ finalStatsView st) diff --git a/Simulation/Aivika/Experiment/FinalTableView.hs b/Simulation/Aivika/Experiment/FinalTableView.hs deleted file mode 100644 --- a/Simulation/Aivika/Experiment/FinalTableView.hs +++ /dev/null @@ -1,253 +0,0 @@ - -{-# LANGUAGE MultiParamTypeClasses #-} - --- | --- Module : Simulation.Aivika.Experiment.FinalTableView --- Copyright : Copyright (c) 2012-2015, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.10.1 --- --- The module defines 'FinalTableView' that saves the simulation --- results in the final time points for all simulation runs in --- the CSV file. --- - -module Simulation.Aivika.Experiment.FinalTableView - (FinalTableView(..), - defaultFinalTableView) where - -import Control.Monad -import Control.Monad.Trans -import Control.Concurrent.MVar - -import qualified Data.Map as M -import Data.IORef -import Data.Maybe - -import System.IO -import System.FilePath - -import Simulation.Aivika -import Simulation.Aivika.Experiment.Types -import Simulation.Aivika.Experiment.WebPageRenderer -import Simulation.Aivika.Experiment.FileRenderer -import Simulation.Aivika.Experiment.ExperimentWriter -import Simulation.Aivika.Experiment.HtmlWriter -import Simulation.Aivika.Experiment.MRef - --- | Defines the 'View' that saves the simulation --- results in the final time points for all --- simulation runs in the CSV file. -data FinalTableView = - FinalTableView { finalTableTitle :: String, - -- ^ This is a title used in HTML. - finalTableDescription :: String, - -- ^ This is a description used in HTML. - finalTableRunText :: String, - -- ^ Translated text \"Run\". - finalTableLinkText :: String, - -- ^ It specifies the text for the link - -- which is displayed in the HTML page. - -- The link downloads the corresponded - -- CSV file in the browser. - -- - -- An example is - -- - -- @ - -- finalTableLinkText = \"Download the CSV file\" - -- @ - finalTableFileName :: ExperimentFilePath, - -- ^ It defines the file name for the CSV file. - -- It may include special variable @$TITLE@. - -- - -- An example is - -- - -- @ - -- finalTableFileName = UniqueFilePath \"$TITLE.csv\" - -- @ - finalTableSeparator :: String, - -- ^ It defines the separator for the view. - -- It delimits the cells in the rows of the CSV file. - finalTableFormatter :: ShowS, - -- ^ It defines the formatter which is applied - -- to all values before they will be written - -- in the CSV file. - finalTablePredicate :: Event Bool, - -- ^ It specifies the predicate that defines - -- when we can save data in the table. - finalTableTransform :: ResultTransform, - -- ^ The transform applied to the results before receiving series. - finalTableSeries :: ResultTransform - -- ^ It defines the series to save in the CSV file. - } - --- | The default table view. -defaultFinalTableView :: FinalTableView -defaultFinalTableView = - FinalTableView { finalTableTitle = "Final Table", - finalTableDescription = "It refers to the CSV file with the results in the final time points.", - finalTableRunText = "Run", - finalTableLinkText = "Download the CSV file", - finalTableFileName = UniqueFilePath "FinalTable.csv", - finalTableSeparator = ",", - finalTableFormatter = id, - finalTablePredicate = return True, - finalTableTransform = expandResults, - finalTableSeries = id } - -instance ExperimentView FinalTableView (WebPageRenderer a) where - - outputView v = - let reporter exp renderer dir = - do st <- newFinalTable v exp dir - let context = - WebPageContext - WebPageWriter { reporterWriteTOCHtml = finalTableTOCHtml st, - reporterWriteHtml = finalTableHtml st } - return ExperimentReporter { reporterInitialise = return (), - reporterFinalise = finaliseFinalTable st, - reporterSimulate = simulateFinalTable st, - reporterContext = context } - in ExperimentGenerator { generateReporter = reporter } - -instance ExperimentView FinalTableView (FileRenderer a) where - - outputView v = - let reporter exp renderer dir = - do st <- newFinalTable v exp dir - return ExperimentReporter { reporterInitialise = return (), - reporterFinalise = finaliseFinalTable st, - reporterSimulate = simulateFinalTable st, - reporterContext = FileContext } - in ExperimentGenerator { generateReporter = reporter } - --- | The state of the view. -data FinalTableViewState = - FinalTableViewState { finalTableView :: FinalTableView, - finalTableExperiment :: Experiment, - finalTableDir :: FilePath, - finalTableFile :: IORef (Maybe FilePath), - finalTableResults :: MRef (Maybe FinalTableResults) } - --- | The table results. -data FinalTableResults = - FinalTableResults { finalTableNames :: [String], - finalTableValues :: MRef (M.Map Int [String]) } - --- | Create a new state of the view. -newFinalTable :: FinalTableView -> Experiment -> FilePath -> ExperimentWriter FinalTableViewState -newFinalTable view exp dir = - do f <- liftIO $ newIORef Nothing - r <- liftIO $ newMRef Nothing - return FinalTableViewState { finalTableView = view, - finalTableExperiment = exp, - finalTableDir = dir, - finalTableFile = f, - finalTableResults = r } - --- | Create new table results. -newFinalTableResults :: [String] -> Experiment -> IO FinalTableResults -newFinalTableResults names exp = - do values <- newMRef M.empty - return FinalTableResults { finalTableNames = names, - finalTableValues = values } - --- | Require to return unique final tables results associated with the specified state. -requireFinalTableResults :: FinalTableViewState -> [String] -> IO FinalTableResults -requireFinalTableResults st names = - maybeWriteMRef (finalTableResults st) - (newFinalTableResults names (finalTableExperiment st)) $ \results -> - if (names /= finalTableNames results) - then error "Series with different names are returned for different runs: requireFinalTableResults" - else return results - --- | Simulation of the specified series. -simulateFinalTable :: FinalTableViewState -> ExperimentData -> Event DisposableEvent -simulateFinalTable st expdata = - do let view = finalTableView st - rs = finalTableSeries view $ - finalTableTransform view $ - experimentResults expdata - exts = resultsToStringValues rs - signals = experimentPredefinedSignals expdata - signal = filterSignalM (const predicate) $ - resultSignalInStopTime signals - names = map resultValueName exts - predicate = finalTablePredicate view - results <- liftIO $ requireFinalTableResults st names - let values = finalTableValues results - handleSignal signal $ \_ -> - do xs <- mapM resultValueData exts - i <- liftParameter simulationIndex - liftIO $ modifyMRef_ values $ return . M.insert i xs - --- | Save the results in the CSV file after the simulation is complete. -finaliseFinalTable :: FinalTableViewState -> ExperimentWriter () -finaliseFinalTable st = - do let view = finalTableView st - run = finalTableRunText view - formatter = finalTableFormatter view - title = finalTableTitle view - separator = finalTableSeparator view - results <- liftIO $ readMRef $ finalTableResults st - case results of - Nothing -> return () - Just results -> - do let names = finalTableNames results - values = finalTableValues results - m <- liftIO $ readMRef values - file <- resolveFilePath (finalTableDir st) $ - mapFilePath (flip replaceExtension ".csv") $ - expandFilePath (finalTableFileName $ finalTableView st) $ - M.fromList [("$TITLE", title)] - liftIO $ do - -- create a new file - h <- openFile file WriteMode - -- write a header - hPutStr h $ show run - forM_ names $ \name -> - do hPutStr h separator - hPutStr h $ show name - hPutStrLn h "" - -- write data - forM_ (M.assocs m) $ \(i, xs) -> - do hPutStr h $ show i - forM_ xs $ \x -> - do hPutStr h separator - hPutStr h $ formatter x - hPutStrLn h "" - -- close file - hClose h - when (experimentVerbose $ finalTableExperiment st) $ - putStr "Generated file " >> putStrLn file - writeIORef (finalTableFile st) $ Just file - --- | Get the HTML code. -finalTableHtml :: FinalTableViewState -> Int -> HtmlWriter () -finalTableHtml st index = - do header st index - file <- liftIO $ readIORef (finalTableFile st) - case file of - Nothing -> return () - Just f -> - writeHtmlParagraph $ - writeHtmlLink (makeRelative (finalTableDir st) f) $ - writeHtmlText (finalTableLinkText $ finalTableView st) - -header :: FinalTableViewState -> Int -> HtmlWriter () -header st index = - do writeHtmlHeader3WithId ("id" ++ show index) $ - writeHtmlText (finalTableTitle $ finalTableView st) - let description = finalTableDescription $ finalTableView st - unless (null description) $ - writeHtmlParagraph $ - writeHtmlText description - --- | Get the TOC item. -finalTableTOCHtml :: FinalTableViewState -> Int -> HtmlWriter () -finalTableTOCHtml st index = - writeHtmlListItem $ - writeHtmlLink ("#id" ++ show index) $ - writeHtmlText (finalTableTitle $ finalTableView st) diff --git a/Simulation/Aivika/Experiment/Histogram.hs b/Simulation/Aivika/Experiment/Histogram.hs --- a/Simulation/Aivika/Experiment/Histogram.hs +++ b/Simulation/Aivika/Experiment/Histogram.hs @@ -1,11 +1,11 @@ -- | -- Module : Simulation.Aivika.Experiment.Histogram --- Copyright : Copyright (c) 2012-2015, David Sorokin +-- Copyright : Copyright (c) 2012-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental --- Tested with: GHC 7.10.1 +-- Tested with: GHC 8.0.1 -- -- | This module computes the histogram by the -- specified data and strategy applied for such computing. diff --git a/Simulation/Aivika/Experiment/HtmlWriter.hs b/Simulation/Aivika/Experiment/HtmlWriter.hs deleted file mode 100644 --- a/Simulation/Aivika/Experiment/HtmlWriter.hs +++ /dev/null @@ -1,397 +0,0 @@ - --- | --- Module : Simulation.Aivika.Experiment.HtmlWriter --- Copyright : Copyright (c) 2012-2015, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.10.1 --- --- This is an utility module that provides an HTML writer. --- - -module Simulation.Aivika.Experiment.HtmlWriter - (HtmlWriter, - runHtmlWriter, - composeHtml, - writeHtml, - writeHtmlLn, - writeHtmlText, - writeHtmlParagraph, - writeHtmlParagraphWithId, - writeHtmlHeader1, - writeHtmlHeader1WithId, - writeHtmlHeader2, - writeHtmlHeader2WithId, - writeHtmlHeader3, - writeHtmlHeader3WithId, - writeHtmlHeader4, - writeHtmlHeader4WithId, - writeHtmlHeader5, - writeHtmlHeader5WithId, - writeHtmlHeader6, - writeHtmlHeader6WithId, - writeHtmlBreak, - writeHtmlLink, - writeHtmlImage, - writeHtmlList, - writeHtmlListItem, - writeHtmlDocumentWithTitle, - encodeHtmlText) where - -import Control.Monad -import Control.Monad.Trans -import Control.Applicative - -import Network.URI - -import Simulation.Aivika.Experiment.ExperimentWriter - --- | It writes fast an HTML code. -newtype HtmlWriter a = - HtmlWriter { runHtmlWriter :: ShowS -> ExperimentWriter (a, ShowS) - -- ^ Run the HTML writer monad. - } - -instance Monad HtmlWriter where - - return a = HtmlWriter $ \f -> return (a, f) - - (HtmlWriter m) >>= k = HtmlWriter $ \f -> - do (a, f') <- m f - let HtmlWriter m' = k a - m' f' - -instance MonadIO HtmlWriter where - - liftIO m = HtmlWriter $ \f -> - do x <- liftIO m - return (x, f) - -instance Functor HtmlWriter where - - fmap f m = m >>= \a -> return (f a) - -instance Applicative HtmlWriter where - - pure = return - (<*>) = ap - --- | Write the HTML code. -writeHtml :: String -> HtmlWriter () -writeHtml code = - HtmlWriter $ \f -> return ((), f . (code ++)) - --- | Write the HTML code. -writeHtmlLn :: String -> HtmlWriter () -writeHtmlLn code = - do writeHtml code - writeHtml "\n" - --- | Write the text in HTML. -writeHtmlText :: String -> HtmlWriter () -writeHtmlText text = - HtmlWriter $ \f -> return ((), f . (encodeHtmlText text ++)) - --- | Compose the HTML applying the corresponded transformation. -composeHtml :: ShowS -> HtmlWriter () -composeHtml g = - HtmlWriter $ \f -> return ((), f . g) - --- | Write the HTML link with the specified URI and contents. -writeHtmlLink :: String -> HtmlWriter () -> HtmlWriter () -writeHtmlLink uri inner = - do writeHtml "" - inner - writeHtml "" - --- | Write the HTML image with the specified URI. -writeHtmlImage :: String -> HtmlWriter () -writeHtmlImage uri = - do writeHtml "" - --- | Write the @\@ element with the specified contents. -writeHtmlParagraph :: HtmlWriter () -> HtmlWriter () -writeHtmlParagraph inner = - do writeHtml "

    " - inner - writeHtml "

    " - --- | Write the @\@ element with the specified contents. -writeHtmlHeader1 :: HtmlWriter () -> HtmlWriter () -writeHtmlHeader1 inner = - do writeHtml "

    " - inner - writeHtml "

    " - --- | Write the @\@ element with the specified contents. -writeHtmlHeader2 :: HtmlWriter () -> HtmlWriter () -writeHtmlHeader2 inner = - do writeHtml "

    " - inner - writeHtml "

    " - --- | Write the @\@ element with the specified contents. -writeHtmlHeader3 :: HtmlWriter () -> HtmlWriter () -writeHtmlHeader3 inner = - do writeHtml "

    " - inner - writeHtml "

    " - --- | Write the @\@ element with the specified contents. -writeHtmlHeader4 :: HtmlWriter () -> HtmlWriter () -writeHtmlHeader4 inner = - do writeHtml "

    " - inner - writeHtml "

    " - --- | Write the @\@ element with the specified contents. -writeHtmlHeader5 :: HtmlWriter () -> HtmlWriter () -writeHtmlHeader5 inner = - do writeHtml "
    " - inner - writeHtml "
    " - --- | Write the @\@ element with the specified contents. -writeHtmlHeader6 :: HtmlWriter () -> HtmlWriter () -writeHtmlHeader6 inner = - do writeHtml "
    " - inner - writeHtml "
    " - --- | Write the @\@ element with the specified id and contents. -writeHtmlParagraphWithId :: String -> HtmlWriter () -> HtmlWriter () -writeHtmlParagraphWithId id inner = - do writeHtml "

    " - inner - writeHtml "

    " - --- | Write the @\@ element with the specified id and contents. -writeHtmlHeader1WithId :: String -> HtmlWriter () -> HtmlWriter () -writeHtmlHeader1WithId id inner = - do writeHtml "

    " - inner - writeHtml "

    " - --- | Write the @\@ element with the specified id and contents. -writeHtmlHeader2WithId :: String -> HtmlWriter () -> HtmlWriter () -writeHtmlHeader2WithId id inner = - do writeHtml "

    " - inner - writeHtml "

    " - --- | Write the @\@ element with the specified id and contents. -writeHtmlHeader3WithId :: String -> HtmlWriter () -> HtmlWriter () -writeHtmlHeader3WithId id inner = - do writeHtml "

    " - inner - writeHtml "

    " - --- | Write the @\@ element with the specified id and contents. -writeHtmlHeader4WithId :: String -> HtmlWriter () -> HtmlWriter () -writeHtmlHeader4WithId id inner = - do writeHtml "

    " - inner - writeHtml "

    " - --- | Write the @\@ element with the specified id and contents. -writeHtmlHeader5WithId :: String -> HtmlWriter () -> HtmlWriter () -writeHtmlHeader5WithId id inner = - do writeHtml "
    " - inner - writeHtml "
    " - --- | Write the @\@ element with the specified id and contents. -writeHtmlHeader6WithId :: String -> HtmlWriter () -> HtmlWriter () -writeHtmlHeader6WithId id inner = - do writeHtml "
    " - inner - writeHtml "
    " - --- | Write the @\@ element. -writeHtmlBreak :: HtmlWriter () -writeHtmlBreak = - writeHtml "
    " - --- | Write the list of items wrapped in @\@. -writeHtmlList :: HtmlWriter () -> HtmlWriter () -writeHtmlList inner = - do writeHtml "
      " - inner - writeHtml "
    " - --- | Write the item list wrapped in @\@. -writeHtmlListItem :: HtmlWriter () -> HtmlWriter () -writeHtmlListItem inner = - do writeHtml "
  • " - inner - writeHtml "
    • " - --- | Write the HTML document with the specified title and contents -writeHtmlDocumentWithTitle :: String -> HtmlWriter () -> HtmlWriter () -writeHtmlDocumentWithTitle title inner = - do writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtmlText title - writeHtml "" - writeHtmlCss - writeHtml "" - writeHtml "" - writeHtmlHeader1 $ - writeHtmlText title - writeHtml "" - inner - writeHtml "

    Automatically generated by " - writeHtml "" - writeHtml "Aivika Experiment" - writeHtml "

    " - writeHtml "" - writeHtml "" - --- | Escape special HTML characters in the 'String'. --- It is based on one function from package Web-Encodings, --- which is licensed under BSD3 but obsolete now. -encodeHtmlText :: String -> String -encodeHtmlText x = join $ map encodeHtmlChar x - --- | Escape a character. -encodeHtmlChar :: Char -> String -encodeHtmlChar '<' = "<" -encodeHtmlChar '>' = ">" -encodeHtmlChar '&' = "&" -encodeHtmlChar '"' = """ -encodeHtmlChar '\'' = "'" -encodeHtmlChar c = [c] - --- | Write the CSS styles -writeHtmlCss :: HtmlWriter () -writeHtmlCss = - do writeHtmlLn "" diff --git a/Simulation/Aivika/Experiment/InfoView.hs b/Simulation/Aivika/Experiment/InfoView.hs deleted file mode 100644 --- a/Simulation/Aivika/Experiment/InfoView.hs +++ /dev/null @@ -1,175 +0,0 @@ - -{-# LANGUAGE MultiParamTypeClasses #-} - --- | --- Module : Simulation.Aivika.Experiment.InfoView --- Copyright : Copyright (c) 2012-2015, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.10.1 --- --- The module defines 'InfoView' that shows the description of series. --- - -module Simulation.Aivika.Experiment.InfoView - (InfoView(..), - defaultInfoView) where - -import Control.Monad -import Control.Monad.Trans -import Control.Concurrent.MVar - -import Data.IORef -import Data.Maybe -import Data.Monoid - -import Simulation.Aivika -import Simulation.Aivika.Experiment.Types -import Simulation.Aivika.Experiment.WebPageRenderer -import Simulation.Aivika.Experiment.ExperimentWriter -import Simulation.Aivika.Experiment.HtmlWriter -import Simulation.Aivika.Experiment.MRef - --- | Defines the 'View' that shows the description of series. -data InfoView = - InfoView { infoTitle :: String, - -- ^ This is a title for the view. - infoDescription :: String, - -- ^ This is a text description used in HTML. - infoTransform :: ResultTransform, - -- ^ The transform applied to the results before receiving series. - infoSeries :: ResultTransform, - -- ^ It defines the series for which the description is shown. - infoLocalisation :: ResultLocalisation - -- ^ It specifies the localisation. - } - --- | The default description view. -defaultInfoView :: InfoView -defaultInfoView = - InfoView { infoTitle = "Information", - infoDescription = "It shows the information about simulation entities:", - infoTransform = id, - infoSeries = id, - infoLocalisation = englishResultLocalisation } - -instance ExperimentView InfoView (WebPageRenderer a) where - - outputView v = - let reporter exp renderer dir = - do st <- newInfo v exp dir - let context = - WebPageContext $ - WebPageWriter { reporterWriteTOCHtml = infoTOCHtml st, - reporterWriteHtml = infoHtml st } - return ExperimentReporter { reporterInitialise = return (), - reporterFinalise = return (), - reporterSimulate = simulateInfo st, - reporterContext = context } - in ExperimentGenerator { generateReporter = reporter } - --- | The state of the view. -data InfoViewState = - InfoViewState { infoView :: InfoView, - infoExperiment :: Experiment, - infoResults :: MRef (Maybe InfoResults) } - --- | The information table. -data InfoResults = - InfoResults { infoNames :: [String], - infoValues :: [String] } - --- | Create a new state of the view. -newInfo :: InfoView -> Experiment -> FilePath -> ExperimentWriter InfoViewState -newInfo view exp dir = - do r <- liftIO $ newMRef Nothing - return InfoViewState { infoView = view, - infoExperiment = exp, - infoResults = r } - --- | Create a new information table. -newInfoResults :: [ResultSource] -> ResultLocalisation -> Experiment -> IO InfoResults -newInfoResults sources loc exp = - do let xs = - flip map sources $ \source -> - case source of - ResultItemSource (ResultItem x) -> - [(resultItemName x, loc $ resultItemId x)] - ResultObjectSource x -> - [(resultObjectName x, loc $ resultObjectId x)] - ResultVectorSource x -> - [(resultVectorName x, loc $ resultVectorId x)] - ResultSeparatorSource x -> - [] - (names, values) = unzip $ concat xs - return InfoResults { infoNames = names, - infoValues = values } - --- | Require to return the unique information table associated with the specified state. -requireInfoResults :: InfoViewState -> [ResultSource] -> IO InfoResults -requireInfoResults st sources = - let view = infoView st - loc = infoLocalisation view - exp = infoExperiment st - in maybeWriteMRef (infoResults st) - (newInfoResults sources loc exp) $ \results -> - do let xs = - flip map sources $ \source -> - case source of - ResultItemSource (ResultItem x) -> - [resultItemName x] - ResultObjectSource x -> - [resultObjectName x] - ResultVectorSource x -> - [resultVectorName x] - ResultSeparatorSource x -> - [] - let names = concat xs - if (names /= infoNames results) - then error "Series with different names are returned for different runs: requireInfoResults" - else return results - --- | Simulate the specified series. -simulateInfo :: InfoViewState -> ExperimentData -> Event DisposableEvent -simulateInfo st expdata = - do let view = infoView st - rs = infoSeries view $ - infoTransform view $ - experimentResults expdata - sources = resultSourceList rs - liftIO $ requireInfoResults st sources - return mempty - --- | Get the HTML code. -infoHtml :: InfoViewState -> Int -> HtmlWriter () -infoHtml st index = - do header st index - results <- liftIO $ readMRef (infoResults st) - case results of - Nothing -> return () - Just results -> - do let names = infoNames results - values = infoValues results - writeHtmlList $ - forM_ (zip names values) $ \(name, value) -> - writeHtmlListItem $ - do writeHtmlText name - writeHtmlText " - " - writeHtmlText value - -header :: InfoViewState -> Int -> HtmlWriter () -header st index = - do writeHtmlHeader3WithId ("id" ++ show index) $ - writeHtmlText (infoTitle $ infoView st) - let description = infoDescription $ infoView st - unless (null description) $ - writeHtmlParagraph $ - writeHtmlText description - --- | Get the TOC item. -infoTOCHtml :: InfoViewState -> Int -> HtmlWriter () -infoTOCHtml st index = - writeHtmlListItem $ - writeHtmlLink ("#id" ++ show index) $ - writeHtmlText (infoTitle $ infoView st) diff --git a/Simulation/Aivika/Experiment/LastValueView.hs b/Simulation/Aivika/Experiment/LastValueView.hs deleted file mode 100644 --- a/Simulation/Aivika/Experiment/LastValueView.hs +++ /dev/null @@ -1,174 +0,0 @@ - -{-# LANGUAGE MultiParamTypeClasses #-} - --- | --- Module : Simulation.Aivika.Experiment.LastValueView --- Copyright : Copyright (c) 2012-2015, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.10.1 --- --- The module defines 'LastValueView' that shows the last values --- for the simulation variables. --- - -module Simulation.Aivika.Experiment.LastValueView - (LastValueView(..), - defaultLastValueView) where - -import Control.Monad -import Control.Monad.Trans - -import qualified Data.Map as M -import Data.IORef -import Data.Maybe - -import Simulation.Aivika -import Simulation.Aivika.Experiment.Types -import Simulation.Aivika.Experiment.WebPageRenderer -import Simulation.Aivika.Experiment.ExperimentWriter -import Simulation.Aivika.Experiment.HtmlWriter -import Simulation.Aivika.Experiment.Utils (replace) - --- | Defines the 'View' that shows the last values of the simulation --- variables. -data LastValueView = - LastValueView { lastValueTitle :: String, - -- ^ The title for the view. - lastValueRunTitle :: String, - -- ^ The run title for the view. It may include - -- special variables @$RUN_INDEX@, @$RUN_COUNT@ and - -- @$TITLE@. - -- - -- An example is - -- - -- @ - -- lastValueRunTitle = \"$TITLE / Run $RUN_INDEX of $RUN_COUNT\" - -- @ - lastValueDescription :: String, - -- ^ The description for the view. - lastValueFormatter :: ShowS, - -- ^ It transforms data before they will be shown. - lastValueTransform :: ResultTransform, - -- ^ The transform applied to the results before receiving series. - lastValueSeries :: ResultTransform - -- ^ It defines the series for which the last values to be shown. - } - --- | This is the default view. -defaultLastValueView :: LastValueView -defaultLastValueView = - LastValueView { lastValueTitle = "The Last Values", - lastValueRunTitle = "$TITLE / Run $RUN_INDEX of $RUN_COUNT", - lastValueDescription = "It shows the values in the final time point(s).", - lastValueFormatter = id, - lastValueTransform = id, - lastValueSeries = id } - -instance ExperimentView LastValueView (WebPageRenderer a) where - - outputView v = - let reporter exp renderer dir = - do st <- newLastValues v exp - let context = - WebPageContext $ - WebPageWriter { reporterWriteTOCHtml = lastValueTOCHtml st, - reporterWriteHtml = lastValueHtml st } - return ExperimentReporter { reporterInitialise = return (), - reporterFinalise = return (), - reporterSimulate = simulateLastValues st, - reporterContext = context } - in ExperimentGenerator { generateReporter = reporter } - --- | The state of the view. -data LastValueViewState = - LastValueViewState { lastValueView :: LastValueView, - lastValueExperiment :: Experiment, - lastValueMap :: M.Map Int (IORef [(String, String)]) } - --- | Create a new state of the view. -newLastValues :: LastValueView -> Experiment -> ExperimentWriter LastValueViewState -newLastValues view exp = - do let n = experimentRunCount exp - rs <- forM [0..(n - 1)] $ \i -> liftIO $ newIORef [] - let m = M.fromList $ zip [0..(n - 1)] rs - return LastValueViewState { lastValueView = view, - lastValueExperiment = exp, - lastValueMap = m } - --- | Get the last values during the simulation. -simulateLastValues :: LastValueViewState -> ExperimentData -> Event DisposableEvent -simulateLastValues st expdata = - do let view = lastValueView st - rs = lastValueSeries view $ - lastValueTransform view $ - experimentResults expdata - exts = resultsToStringValues rs - signals = experimentPredefinedSignals expdata - signal = resultSignalInStopTime signals - i <- liftParameter simulationIndex - handleSignal signal $ \t -> - do let r = fromJust $ M.lookup (i - 1) (lastValueMap st) - output <- forM exts $ \ext -> - do x <- resultValueData ext - return (resultValueName ext, x) - liftIO $ writeIORef r output - --- | Get the HTML code. -lastValueHtml :: LastValueViewState -> Int -> HtmlWriter () -lastValueHtml st index = - let n = experimentRunCount $ lastValueExperiment st - in if n == 1 - then lastValueHtmlSingle st index - else lastValueHtmlMultiple st index - --- | Get the HTML code for a single run. -lastValueHtmlSingle :: LastValueViewState -> Int -> HtmlWriter () -lastValueHtmlSingle st index = - do header st index - let r = fromJust $ M.lookup 0 (lastValueMap st) - pairs <- liftIO $ readIORef r - forM_ pairs $ \pair -> - formatPair pair (lastValueFormatter $ lastValueView st) - --- | Get the HTML code for multiple runs -lastValueHtmlMultiple :: LastValueViewState -> Int -> HtmlWriter () -lastValueHtmlMultiple st index = - do header st index - let n = experimentRunCount $ lastValueExperiment st - forM_ [0..(n - 1)] $ \i -> - do let subtitle = - replace "$RUN_INDEX" (show $ i + 1) $ - replace "$RUN_COUNT" (show n) $ - replace "$TITLE" (lastValueTitle $ lastValueView st) - (lastValueRunTitle $ lastValueView st) - writeHtmlHeader4 $ - writeHtmlText subtitle - let r = fromJust $ M.lookup i (lastValueMap st) - pairs <- liftIO $ readIORef r - forM_ pairs $ \pair -> - formatPair pair (lastValueFormatter $ lastValueView st) - -header :: LastValueViewState -> Int -> HtmlWriter () -header st index = - do writeHtmlHeader3WithId ("id" ++ show index) $ - writeHtmlText (lastValueTitle $ lastValueView st) - let description = lastValueDescription $ lastValueView st - unless (null description) $ - writeHtmlParagraph $ - writeHtmlText description - -formatPair :: (String, String) -> ShowS -> HtmlWriter () -formatPair (name, value) formatter = - writeHtmlParagraph $ - do writeHtmlText name - writeHtmlText " = " - writeHtmlText $ formatter value - --- | Get the TOC item -lastValueTOCHtml :: LastValueViewState -> Int -> HtmlWriter () -lastValueTOCHtml st index = - writeHtmlListItem $ - writeHtmlLink ("#id" ++ show index) $ - writeHtmlText (lastValueTitle $ lastValueView st) diff --git a/Simulation/Aivika/Experiment/MRef.hs b/Simulation/Aivika/Experiment/MRef.hs deleted file mode 100644 --- a/Simulation/Aivika/Experiment/MRef.hs +++ /dev/null @@ -1,107 +0,0 @@ - --- | --- Module : Simulation.Aivika.Experiment.MRef --- Copyright : Copyright (c) 2012-2015, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.10.1 --- --- The module defines a shared mutable reference accessible from different threads. --- - -module Simulation.Aivika.Experiment.MRef - (MRef, - newMRef, - readMRef, - maybeReadMRef, - writeMRef, - maybeWriteMRef, - modifyMRef_, - modifyMRef, - withMRef) where - -import Control.Concurrent.MVar - -import Data.Maybe -import Data.IORef - --- | This is a shared mutable reference accessible from different threads. -data MRef a = - MRef { mrefLock :: MVar (), - -- ^ A reference lock. - mrefData :: IORef a - -- ^ The reference itself. - } - --- | Create a new shared reference with the specified initial value. -newMRef :: a -> IO (MRef a) -newMRef a = - do v <- newMVar () - r <- newIORef a - return MRef { mrefLock = v, - mrefData = r } - --- | Read the contents of the shared reference. -readMRef :: MRef a -> IO a -readMRef = readIORef . mrefData - --- | Like 'maybe' but for the shared reference under assumption --- that the reference is updated only once by its initial value. -maybeReadMRef :: b -> (a -> IO b) -> MRef (Maybe a) -> IO b -maybeReadMRef b0 f x = - do a <- readIORef (mrefData x) - case a of - Just a -> f a - Nothing -> - withMVar (mrefLock x) $ \() -> - do a <- readIORef (mrefData x) - case a of - Just a -> f a - Nothing -> return b0 - --- | Update the contents of the shared reference. -writeMRef :: MRef a -> a -> IO () -writeMRef x a = - withMVar (mrefLock x) $ \() -> - writeIORef (mrefData x) a - --- | Update the contents if the reference was empty and then return a result of --- applying the specified function to either the initial or current value. -maybeWriteMRef :: MRef (Maybe a) -> IO a -> (a -> IO b) -> IO b -maybeWriteMRef x m0 f = - do a <- readIORef (mrefData x) - case a of - Just a -> f a - Nothing -> - withMVar (mrefLock x) $ \() -> - do a <- readIORef (mrefData x) - case a of - Just a -> f a - Nothing -> - do a0 <- m0 - writeIORef (mrefData x) (Just a0) - f a0 - --- | Modify the contents of the shared reference. -modifyMRef_ :: MRef a -> (a -> IO a) -> IO () -modifyMRef_ x f = - withMVar (mrefLock x) $ \() -> - do a <- readIORef (mrefData x) - a' <- f a - writeIORef (mrefData x) a' - --- | Modify the contents of the shared reference but allow returning the result. -modifyMRef :: MRef a -> (a -> IO (a, b)) -> IO b -modifyMRef x f = - withMVar (mrefLock x) $ \() -> - do a <- readIORef (mrefData x) - (a', b) <- f a - writeIORef (mrefData x) a' - return b - --- | A safe wrapper for operating with the contents of shared reference. -withMRef :: MRef a -> (a -> IO b) -> IO b -withMRef x f = - withMVar (mrefLock x) $ \() -> - readIORef (mrefData x) >>= f diff --git a/Simulation/Aivika/Experiment/SamplingStatsWriter.hs b/Simulation/Aivika/Experiment/SamplingStatsWriter.hs deleted file mode 100644 --- a/Simulation/Aivika/Experiment/SamplingStatsWriter.hs +++ /dev/null @@ -1,112 +0,0 @@ - --- | --- Module : Simulation.Aivika.Experiment.SamplingStatsWriter --- Copyright : Copyright (c) 2012-2015, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.10.1 --- --- The module defines 'SamplingStatsWriter' that knows how to write --- the sampling statistics in HTML. --- - -module Simulation.Aivika.Experiment.SamplingStatsWriter - (SamplingStatsWriter(..), - defaultSamplingStatsWriter) where - -import Simulation.Aivika.Experiment.Types -import Simulation.Aivika.Experiment.HtmlWriter - -import Simulation.Aivika.Statistics - --- | Defines a writer that knows how to represent the 'SamplingStats' --- as the HTML table. -data SamplingStatsWriter a = - SamplingStatsWriter { samplingStatsWidth :: Int, - -- ^ The width of the HTML table. - samplingStatsMeanText :: String, - -- ^ Translated text \"mean\". - samplingStatsDeviationText :: String, - -- ^ Translated text \"deviation\". - samplingStatsMinText :: String, - -- ^ Translated text \"minimum\". - samplingStatsMaxText :: String, - -- ^ Translated text \"maximum\". - samplingStatsCountText :: String, - -- ^ Translated text \"count\". - samplingStatsFormatter :: ShowS, - -- ^ The formatter of numbers. - samplingStatsWrite :: SamplingStatsWriter a -> String -> - SamplingStats a -> HtmlWriter () - -- ^ This function reprensents the named statistics - -- as the HTML table. - } - --- | The default writer. -defaultSamplingStatsWriter :: Show a => SamplingStatsWriter a -defaultSamplingStatsWriter = - SamplingStatsWriter { - samplingStatsWidth = 400, - samplingStatsMeanText = "mean", - samplingStatsDeviationText = "deviation", - samplingStatsMinText = "minimum", - samplingStatsMaxText = "maximum", - samplingStatsCountText = "count", - samplingStatsFormatter = id, - samplingStatsWrite = \writer name stats -> - do let format x = samplingStatsFormatter writer x - writeHtml "

    " - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "
    " - writeHtml "

    " - writeHtmlText name - writeHtml "" - writeHtml "

    " - writeHtmlText $ samplingStatsMeanText writer - writeHtml "" - writeHtmlText $ format $ show $ samplingStatsMean stats - writeHtml "
    " - writeHtmlText $ samplingStatsDeviationText writer - writeHtml "" - writeHtmlText $ format $ show $ samplingStatsDeviation stats - writeHtml "
    " - writeHtmlText $ samplingStatsMinText writer - writeHtml "" - writeHtmlText $ format $ show $ samplingStatsMin stats - writeHtml "
    " - writeHtmlText $ samplingStatsMaxText writer - writeHtml "" - writeHtmlText $ format $ show $ samplingStatsMax stats - writeHtml "
    " - writeHtmlText $ samplingStatsCountText writer - writeHtml "" - writeHtml $ format $ show $ samplingStatsCount stats - writeHtml "
    " - writeHtml "

    " - } diff --git a/Simulation/Aivika/Experiment/TableView.hs b/Simulation/Aivika/Experiment/TableView.hs deleted file mode 100644 --- a/Simulation/Aivika/Experiment/TableView.hs +++ /dev/null @@ -1,259 +0,0 @@ - -{-# LANGUAGE MultiParamTypeClasses #-} - --- | --- Module : Simulation.Aivika.Experiment.TableView --- Copyright : Copyright (c) 2012-2015, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.10.1 --- --- The module defines 'TableView' that saves the simulation --- results in the CSV file(s). --- - -module Simulation.Aivika.Experiment.TableView - (TableView(..), - defaultTableView) where - -import Control.Monad -import Control.Monad.Trans - -import qualified Data.Map as M -import Data.IORef -import Data.Maybe -import Data.Monoid - -import System.IO -import System.FilePath - -import Simulation.Aivika -import Simulation.Aivika.Experiment.Types -import Simulation.Aivika.Experiment.WebPageRenderer -import Simulation.Aivika.Experiment.FileRenderer -import Simulation.Aivika.Experiment.ExperimentWriter -import Simulation.Aivika.Experiment.HtmlWriter -import Simulation.Aivika.Experiment.Utils (replace) - --- | Defines the 'View' that saves the simulation results --- in the CSV file(s). -data TableView = - TableView { tableTitle :: String, - -- ^ This is a title used in HTML. - tableDescription :: String, - -- ^ This is a description in the HTML. - tableLinkText :: String, - -- ^ It specifies the text for the link - -- which is displayed in the HTML page - -- if there is only one simulation run. - -- The link downloads the corresponded - -- CSV file in the browser. If there are - -- more simulation runs, then this link - -- is not shown. - -- - -- An example is - -- - -- @ - -- tableLinkText = \"Download the CSV file\" - -- @ - tableRunLinkText :: String, - -- ^ It specifies the link text which is - -- displayed in the HTML page if there are - -- many simulation runs. Such a link downloads - -- the CSV file for the corresponded run. - -- To define the text, you can use special - -- variables @$LINK@, @$RUN_INDEX@ and @$RUN_COUNT@. - -- - -- An example is - -- - -- @ - -- tableRunLinkText = \"$LINK / Run $RUN_INDEX of $RUN_COUNT\" - -- @ - -- - -- If there is only one run, then the link of - -- this kind is not displayed. Instead, only one - -- link is shown, which text is defined by the - -- 'tableLinkText' field. - tableFileName :: ExperimentFilePath, - -- ^ It defines the file name for each CSV file. - -- It may include special variables @$TITLE@, - -- @$RUN_INDEX@ and @$RUN_COUNT@. - -- - -- An example is - -- - -- @ - -- tableFileName = UniqueFilePath \"$TITLE - $RUN_INDEX.csv\" - -- @ - tableSeparator :: String, - -- ^ It defines the separator for the view. - -- It delimits the cells in the rows of the CSV file. - tableFormatter :: ShowS, - -- ^ It defines the formatter which is applied - -- to all values before they will be written - -- in the CSV file(s). - tablePredicate :: Event Bool, - -- ^ It specifies the predicate that defines - -- when we can save data in the table. - tableTransform :: ResultTransform, - -- ^ The transform applied to the results before receiving series. - tableSeries :: ResultTransform - -- ^ It defines the series to save in the CSV file(s). - } - --- | The default table view. -defaultTableView :: TableView -defaultTableView = - TableView { tableTitle = "Table", - tableDescription = "This section contains the CSV file(s) with the simulation results.", - tableLinkText = "Download the CSV file", - tableRunLinkText = "$LINK / Run $RUN_INDEX of $RUN_COUNT", - tableFileName = UniqueFilePath "Table($RUN_INDEX).csv", - tableSeparator = ",", - tableFormatter = id, - tablePredicate = return True, - tableTransform = expandResults, - tableSeries = id } - -instance ExperimentView TableView (WebPageRenderer a) where - - outputView v = - let reporter exp renderer dir = - do st <- newTable v exp dir - let context = - WebPageContext $ - WebPageWriter { reporterWriteTOCHtml = tableTOCHtml st, - reporterWriteHtml = tableHtml st } - return ExperimentReporter { reporterInitialise = return (), - reporterFinalise = return (), - reporterSimulate = simulateTable st, - reporterContext = context } - in ExperimentGenerator { generateReporter = reporter } - -instance ExperimentView TableView (FileRenderer a) where - - outputView v = - let reporter exp renderer dir = - do st <- newTable v exp dir - return ExperimentReporter { reporterInitialise = return (), - reporterFinalise = return (), - reporterSimulate = simulateTable st, - reporterContext = FileContext } - in ExperimentGenerator { generateReporter = reporter } - --- | The state of the view. -data TableViewState = - TableViewState { tableView :: TableView, - tableExperiment :: Experiment, - tableDir :: FilePath, - tableMap :: M.Map Int FilePath } - --- | Create a new state of the view. -newTable :: TableView -> Experiment -> FilePath -> ExperimentWriter TableViewState -newTable view exp dir = - do let n = experimentRunCount exp - fs <- forM [0..(n - 1)] $ \i -> - resolveFilePath dir $ - mapFilePath (flip replaceExtension ".csv") $ - expandFilePath (tableFileName view) $ - M.fromList [("$TITLE", tableTitle view), - ("$RUN_INDEX", show $ i + 1), - ("$RUN_COUNT", show n)] - liftIO $ forM_ fs $ flip writeFile [] -- reserve the file names - let m = M.fromList $ zip [0..(n - 1)] fs - return TableViewState { tableView = view, - tableExperiment = exp, - tableDir = dir, - tableMap = m } - --- | Write the tables during the simulation. -simulateTable :: TableViewState -> ExperimentData -> Event DisposableEvent -simulateTable st expdata = - do let view = tableView st - rs = tableSeries view $ - tableTransform view $ - experimentResults expdata - exts = resultsToStringValues rs - signals = experimentPredefinedSignals expdata - signal = pureResultSignal signals $ - resultSignal rs - separator = tableSeparator view - formatter = tableFormatter view - predicate = tablePredicate view - i <- liftParameter simulationIndex - -- create a new file - let f = fromJust $ M.lookup (i - 1) (tableMap st) - h <- liftIO $ openFile f WriteMode - -- write a header - liftIO $ - do forM_ (zip [0..] exts) $ \(column, ext) -> - do when (column > 0) $ - hPutStr h separator - hPutStr h $ show $ resultValueName ext - hPutStrLn h "" - d1 <- handleSignal signal $ \t -> - do p <- predicate - when p $ - do forM_ (zip [0..] exts) $ \(column, ext) -> -- write the row - do x <- resultValueData ext -- write the column - liftIO $ - do when (column > 0) $ - hPutStr h separator - hPutStr h $ formatter x - liftIO $ hPutStrLn h "" - let d2 = - DisposableEvent $ - liftIO $ - do when (experimentVerbose $ tableExperiment st) $ - putStr "Generated file " >> putStrLn f - hClose h -- close the file - return $ d1 <> d2 - --- | Get the HTML code. -tableHtml :: TableViewState -> Int -> HtmlWriter () -tableHtml st index = - let n = experimentRunCount $ tableExperiment st - in if n == 1 - then tableHtmlSingle st index - else tableHtmlMultiple st index - --- | Get the HTML code for a single run. -tableHtmlSingle :: TableViewState -> Int -> HtmlWriter () -tableHtmlSingle st index = - do header st index - let f = fromJust $ M.lookup 0 (tableMap st) - writeHtmlParagraph $ - writeHtmlLink (makeRelative (tableDir st) f) $ - writeHtmlText (tableLinkText $ tableView st) - --- | Get the HTML code for multiple runs -tableHtmlMultiple :: TableViewState -> Int -> HtmlWriter () -tableHtmlMultiple st index = - do header st index - let n = experimentRunCount $ tableExperiment st - forM_ [0..(n - 1)] $ \i -> - do let f = fromJust $ M.lookup i (tableMap st) - sublink = - replace "$RUN_INDEX" (show $ i + 1) $ - replace "$RUN_COUNT" (show n) $ - replace "$LINK" (tableLinkText $ tableView st) - (tableRunLinkText $ tableView st) - writeHtmlParagraph $ - writeHtmlLink (makeRelative (tableDir st) f) $ - writeHtmlText sublink - -header :: TableViewState -> Int -> HtmlWriter () -header st index = - do writeHtmlHeader3WithId ("id" ++ show index) $ - writeHtmlText (tableTitle $ tableView st) - let description = tableDescription $ tableView st - unless (null description) $ - writeHtmlParagraph $ - writeHtmlText description - --- | Get the TOC item -tableTOCHtml :: TableViewState -> Int -> HtmlWriter () -tableTOCHtml st index = - writeHtmlListItem $ - writeHtmlLink ("#id" ++ show index) $ - writeHtmlText (tableTitle $ tableView st) diff --git a/Simulation/Aivika/Experiment/TimingStatsView.hs b/Simulation/Aivika/Experiment/TimingStatsView.hs deleted file mode 100644 --- a/Simulation/Aivika/Experiment/TimingStatsView.hs +++ /dev/null @@ -1,188 +0,0 @@ - -{-# LANGUAGE MultiParamTypeClasses #-} - --- | --- Module : Simulation.Aivika.Experiment.TimingStatsView --- Copyright : Copyright (c) 2012-2015, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.10.1 --- --- The module defines 'TimingStatsView' that shows the timing statistics --- for the variables for every simulation run separately. --- - -module Simulation.Aivika.Experiment.TimingStatsView - (TimingStatsView(..), - defaultTimingStatsView) where - -import Control.Monad -import Control.Monad.Trans - -import qualified Data.Map as M -import Data.IORef -import Data.Maybe -import Data.Monoid - -import Simulation.Aivika -import Simulation.Aivika.Experiment.Types -import Simulation.Aivika.Experiment.WebPageRenderer -import Simulation.Aivika.Experiment.ExperimentWriter -import Simulation.Aivika.Experiment.HtmlWriter -import Simulation.Aivika.Experiment.TimingStatsWriter -import Simulation.Aivika.Experiment.Utils (replace) - --- | Defines the 'View' that shows the timing statistics --- for variables for every simulation run separately. -data TimingStatsView = - TimingStatsView { timingStatsTitle :: String, - -- ^ The title for the view. - timingStatsRunTitle :: String, - -- ^ The run title for the view. It may include - -- special variables @$RUN_INDEX@, @$RUN_COUNT@ and - -- @$TITLE@. - -- - -- An example is - -- - -- @ - -- timingStatsRunTitle = \"$TITLE / Run $RUN_INDEX of $RUN_COUNT\" - -- @ - timingStatsDescription :: String, - -- ^ The description for the view. - timingStatsWriter :: TimingStatsWriter Double, - -- ^ It shows the timing statistics. - timingStatsPredicate :: Event Bool, - -- ^ Specifies when gathering the statistics. - timingStatsTransform :: ResultTransform, - -- ^ The transform applied to the results before receiving series. - timingStatsSeries :: ResultTransform - -- ^ It defines the series for which the statistics to be collected. - } - --- | This is the default view. -defaultTimingStatsView :: TimingStatsView -defaultTimingStatsView = - TimingStatsView { timingStatsTitle = "Timing Statistics", - timingStatsRunTitle = "$TITLE / Run $RUN_INDEX of $RUN_COUNT", - timingStatsDescription = "The statistical data are gathered in the time points.", - timingStatsWriter = defaultTimingStatsWriter, - timingStatsPredicate = return True, - timingStatsTransform = id, - timingStatsSeries = id } - -instance ExperimentView TimingStatsView (WebPageRenderer a) where - - outputView v = - let reporter exp renderer dir = - do st <- newTimingStats v exp - let context = - WebPageContext $ - WebPageWriter { reporterWriteTOCHtml = timingStatsTOCHtml st, - reporterWriteHtml = timingStatsHtml st } - return ExperimentReporter { reporterInitialise = return (), - reporterFinalise = return (), - reporterSimulate = simulateTimingStats st, - reporterContext = context } - in ExperimentGenerator { generateReporter = reporter } - --- | The state of the view. -data TimingStatsViewState = - TimingStatsViewState { timingStatsView :: TimingStatsView, - timingStatsExperiment :: Experiment, - timingStatsMap :: M.Map Int (IORef [(String, IORef (TimingStats Double))]) } - --- | Create a new state of the view. -newTimingStats :: TimingStatsView -> Experiment -> ExperimentWriter TimingStatsViewState -newTimingStats view exp = - do let n = experimentRunCount exp - rs <- forM [0..(n - 1)] $ \i -> liftIO $ newIORef [] - let m = M.fromList $ zip [0..(n - 1)] rs - return TimingStatsViewState { timingStatsView = view, - timingStatsExperiment = exp, - timingStatsMap = m } - --- | Get the timing statistics during the simulation. -simulateTimingStats :: TimingStatsViewState -> ExperimentData -> Event DisposableEvent -simulateTimingStats st expdata = - do let view = timingStatsView st - rs = timingStatsSeries view $ - timingStatsTransform view $ - experimentResults expdata - exts = resultsToDoubleValues rs - signals = experimentPredefinedSignals expdata - signal = filterSignalM (const predicate) $ - pureResultSignal signals $ - resultSignal rs - predicate = timingStatsPredicate view - i <- liftParameter simulationIndex - let r = fromJust $ M.lookup (i - 1) $ timingStatsMap st - ds <- forM exts $ \ext -> - do stats <- liftIO $ newIORef emptyTimingStats - let name = resultValueName ext - liftIO $ modifyIORef r ((:) (name, stats)) - handleSignal signal $ \_ -> - do t <- liftDynamics time - x <- resultValueData ext - liftIO $ - do y <- readIORef stats - let y' = addTimingStats t x y - y' `seq` writeIORef stats y' - return $ mconcat ds - --- | Get the HTML code. -timingStatsHtml :: TimingStatsViewState -> Int -> HtmlWriter () -timingStatsHtml st index = - let n = experimentRunCount $ timingStatsExperiment st - in if n == 1 - then timingStatsHtmlSingle st index - else timingStatsHtmlMultiple st index - --- | Get the HTML code for a single run. -timingStatsHtmlSingle :: TimingStatsViewState -> Int -> HtmlWriter () -timingStatsHtmlSingle st index = - do header st index - let r = fromJust $ M.lookup 0 (timingStatsMap st) - pairs <- liftIO $ readIORef r - forM_ (reverse pairs) $ \(name, r) -> - do stats <- liftIO $ readIORef r - let writer = timingStatsWriter (timingStatsView st) - write = timingStatsWrite writer - write writer name stats - --- | Get the HTML code for multiple runs -timingStatsHtmlMultiple :: TimingStatsViewState -> Int -> HtmlWriter () -timingStatsHtmlMultiple st index = - do header st index - let n = experimentRunCount $ timingStatsExperiment st - forM_ [0..(n - 1)] $ \i -> - do let subtitle = - replace "$RUN_INDEX" (show $ i + 1) $ - replace "$RUN_COUNT" (show n) $ - replace "$TITLE" (timingStatsTitle $ timingStatsView st) - (timingStatsRunTitle $ timingStatsView st) - writeHtmlHeader4 $ - writeHtmlText subtitle - let r = fromJust $ M.lookup i (timingStatsMap st) - pairs <- liftIO $ readIORef r - forM_ (reverse pairs) $ \(name, r) -> - do stats <- liftIO $ readIORef r - let writer = timingStatsWriter (timingStatsView st) - write = timingStatsWrite writer - write writer name stats - -header :: TimingStatsViewState -> Int -> HtmlWriter () -header st index = - do writeHtmlHeader3WithId ("id" ++ show index) $ - writeHtmlText (timingStatsTitle $ timingStatsView st) - let description = timingStatsDescription $ timingStatsView st - unless (null description) $ - writeHtmlParagraph $ - writeHtmlText description - --- | Get the TOC item -timingStatsTOCHtml :: TimingStatsViewState -> Int -> HtmlWriter () -timingStatsTOCHtml st index = - writeHtmlListItem $ - writeHtmlLink ("#id" ++ show index) $ - writeHtmlText (timingStatsTitle $ timingStatsView st) diff --git a/Simulation/Aivika/Experiment/TimingStatsWriter.hs b/Simulation/Aivika/Experiment/TimingStatsWriter.hs deleted file mode 100644 --- a/Simulation/Aivika/Experiment/TimingStatsWriter.hs +++ /dev/null @@ -1,130 +0,0 @@ - --- | --- Module : Simulation.Aivika.Experiment.TimingStatsWriter --- Copyright : Copyright (c) 2012-2015, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.10.1 --- --- The module defines 'TimingStatsWriter' that knows how to write --- the timing statistics in HTML. --- - -module Simulation.Aivika.Experiment.TimingStatsWriter - (TimingStatsWriter(..), - defaultTimingStatsWriter) where - -import Simulation.Aivika.Experiment.Types -import Simulation.Aivika.Experiment.HtmlWriter - -import Simulation.Aivika.Statistics - --- | Defines a writer that knows how to represent the 'TimingStats' --- as the HTML table. -data TimingStatsWriter a = - TimingStatsWriter { timingStatsWidth :: Int, - -- ^ The width of the HTML table. - timingStatsTimeText :: String, - -- ^ Translated text \"time\". - timingStatsMeanText :: String, - -- ^ Translated text \"mean\". - timingStatsDeviationText :: String, - -- ^ Translated text \"deviation\". - timingStatsMinText :: String, - -- ^ Translated text \"minimum\". - timingStatsMaxText :: String, - -- ^ Translated text \"maximum\". - timingStatsFormatter :: ShowS, - -- ^ The formatter of numbers. - timingStatsWrite :: TimingStatsWriter a -> String -> - TimingStats a -> HtmlWriter () - -- ^ This function reprensents the named statistics - -- as the HTML table. - } - --- | The default writer. -defaultTimingStatsWriter :: (Show a, TimingData a) => TimingStatsWriter a -defaultTimingStatsWriter = - TimingStatsWriter { - timingStatsWidth = 400, - timingStatsMeanText = "mean", - timingStatsTimeText = "time", - timingStatsDeviationText = "deviation", - timingStatsMinText = "minimum", - timingStatsMaxText = "maximum", - timingStatsFormatter = id, - timingStatsWrite = \writer name stats -> - do let format x = timingStatsFormatter writer x - writeHtml "

    " - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "" - writeHtml "
    " - writeHtml "

    " - writeHtmlText name - writeHtml "" - writeHtml "

    " - writeHtmlText $ timingStatsMeanText writer - writeHtml "" - writeHtmlText $ format $ show $ timingStatsMean stats - writeHtml "
    " - writeHtmlText $ timingStatsDeviationText writer - writeHtml "" - writeHtmlText $ format $ show $ timingStatsDeviation stats - writeHtml "
    " - writeHtmlText $ timingStatsMinText writer - writeHtml "" - writeHtmlText $ format $ show $ timingStatsMin stats - writeHtml "" - writeHtmlText "(" - writeHtmlText $ timingStatsTimeText writer - writeHtmlText " = " - writeHtmlText $ format $ show $ timingStatsMinTime stats - writeHtmlText ")" - writeHtml "
    " - writeHtmlText $ timingStatsMaxText writer - writeHtml "" - writeHtmlText $ format $ show $ timingStatsMax stats - writeHtml "" - writeHtmlText "(" - writeHtmlText $ timingStatsTimeText writer - writeHtmlText " = " - writeHtmlText $ format $ show $ timingStatsMaxTime stats - writeHtmlText ")" - writeHtml "
    " - writeHtmlText $ timingStatsTimeText writer - writeHtml "" - writeHtml "[" - writeHtml $ format $ show $ timingStatsStartTime stats - writeHtml "; " - writeHtml $ format $ show $ timingStatsLastTime stats - writeHtml "]" - writeHtml "
    " - writeHtml "

    " - } diff --git a/Simulation/Aivika/Experiment/Types.hs b/Simulation/Aivika/Experiment/Types.hs --- a/Simulation/Aivika/Experiment/Types.hs +++ b/Simulation/Aivika/Experiment/Types.hs @@ -1,13 +1,13 @@ -{-# LANGUAGE TypeFamilies, MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleContexts #-} -- | -- Module : Simulation.Aivika.Experiment.Types --- Copyright : Copyright (c) 2012-2015, David Sorokin +-- Copyright : Copyright (c) 2012-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental --- Tested with: GHC 7.10.1 +-- Tested with: GHC 8.0.1 -- -- The module defines the simulation experiments. They automate -- the process of generating and analyzing the results. Moreover, @@ -22,19 +22,18 @@ module Simulation.Aivika.Experiment.Types where import Control.Monad -import Control.Monad.State +import Control.Monad.Trans +import Control.Exception import Control.Concurrent.ParallelIO.Local import Data.Maybe import Data.Monoid - -import System.Directory -import System.FilePath +import Data.Either import GHC.Conc (getNumCapabilities) import Simulation.Aivika -import Simulation.Aivika.Experiment.ExperimentWriter +import Simulation.Aivika.Trans.Exception -- | It defines the simulation experiment with the specified rendering backend and its bound data. data Experiment = @@ -46,8 +45,6 @@ -- ^ Specifies a localisation applied when rendering the experiment. experimentRunCount :: Int, -- ^ How many simulation runs should be launched. - experimentDirectoryName :: ExperimentFilePath, - -- ^ The directory in which the output results should be saved. experimentTitle :: String, -- ^ The experiment title. experimentDescription :: String, @@ -66,7 +63,6 @@ experimentTransform = id, experimentLocalisation = englishResultLocalisation, experimentRunCount = 1, - experimentDirectoryName = UniqueFilePath "experiment", experimentTitle = "Simulation Experiment", experimentDescription = "", experimentVerbose = True, @@ -78,14 +74,32 @@ -- | Defines a context used when rendering the experiment. data ExperimentContext r :: * + -- | Defines the experiment environment. + type ExperimentEnvironment r :: * + + -- | Defines the experiment monad type. + type ExperimentMonad r :: * -> * + + -- | Lift the experiment computation. + liftExperiment :: r -> ExperimentMonad r a -> IO a + + -- | Prepare before rendering the experiment. + prepareExperiment :: Experiment -> r -> ExperimentMonad r (ExperimentEnvironment r) + -- | Render the experiment after the simulation is finished, for example, -- creating the @index.html@ file in the specified directory. - renderExperiment :: Experiment -> r -> [ExperimentReporter r] -> FilePath -> ExperimentWriter () + renderExperiment :: Experiment -> r -> [ExperimentReporter r] -> ExperimentEnvironment r -> ExperimentMonad r () + -- | It is called when the experiment has been completed. + onExperimentCompleted :: Experiment -> r -> ExperimentEnvironment r -> ExperimentMonad r () + + -- | It is called when the experiment rendering has failed. + onExperimentFailed :: Exception e => Experiment -> r -> ExperimentEnvironment r -> e -> ExperimentMonad r () + -- | This is a generator of the reporter with the specified rendering backend. data ExperimentGenerator r = - ExperimentGenerator { generateReporter :: Experiment -> r -> FilePath -> ExperimentWriter (ExperimentReporter r) - -- ^ Generate a reporter bound up with the specified directory. + ExperimentGenerator { generateReporter :: Experiment -> r -> ExperimentEnvironment r -> ExperimentMonad r (ExperimentReporter r) + -- ^ Generate a reporter. } -- | Defines a view in which the simulation results should be saved. @@ -106,17 +120,14 @@ -- | Defines what creates the simulation reports by the specified renderer. data ExperimentReporter r = - ExperimentReporter { reporterInitialise :: ExperimentWriter (), + ExperimentReporter { reporterInitialise :: ExperimentMonad r (), -- ^ Initialise the reporting before -- the simulation runs are started. - reporterFinalise :: ExperimentWriter (), + reporterFinalise :: ExperimentMonad r (), -- ^ Finalise the reporting after -- all simulation runs are finished. - reporterSimulate :: ExperimentData -> Event DisposableEvent, - -- ^ Start the simulation run in the start time - -- and return a finalizer that will be called - -- in the stop time after the last signal is - -- triggered and processed. + reporterSimulate :: ExperimentData -> Composite (), + -- ^ Start the simulation run in the start time. reporterContext :: ExperimentContext r -- ^ Return a context used by the renderer. } @@ -124,7 +135,10 @@ -- | Run the simulation experiment sequentially. For example, -- it can be a Monte-Carlo simulation dependentent on the external -- 'Parameter' values. -runExperiment :: ExperimentRendering r +runExperiment :: (ExperimentRendering r, + Monad (ExperimentMonad r), + MonadIO (ExperimentMonad r), + MonadException (ExperimentMonad r)) => Experiment -- ^ the simulation experiment to run -> [ExperimentGenerator r] @@ -133,8 +147,10 @@ -- ^ the rendering backend -> Simulation Results -- ^ the simulation results received from the model - -> IO () -runExperiment = runExperimentWithExecutor sequence_ + -> IO (Either SomeException ()) +{-# INLINABLE runExperiment #-} +runExperiment e generators r simulation = + runExperimentWithExecutor sequence_ e generators r simulation -- | Run the simulation experiment in parallel. -- @@ -148,7 +164,10 @@ -- threads directly with help of 'experimentNumCapabilities', -- although the real number of parallel threads can depend on many -- factors. -runExperimentParallel :: ExperimentRendering r +runExperimentParallel :: (ExperimentRendering r, + Monad (ExperimentMonad r), + MonadIO (ExperimentMonad r), + MonadException (ExperimentMonad r)) => Experiment -- ^ the simulation experiment to run -> [ExperimentGenerator r] @@ -157,16 +176,22 @@ -- ^ the rendering backend -> Simulation Results -- ^ the simulation results received from the model - -> IO () -runExperimentParallel e = runExperimentWithExecutor executor e - where executor tasks = - do n <- experimentNumCapabilities e - withPool n $ \pool -> - parallel_ pool tasks + -> IO (Either SomeException ()) +{-# INLINABLE runExperimentParallel #-} +runExperimentParallel e generators r simulation = + do x <- runExperimentWithExecutor executor e generators r simulation + return (x >> return ()) + where executor tasks = + do n <- experimentNumCapabilities e + withPool n $ \pool -> + parallel_ pool tasks -- | Run the simulation experiment with the specified executor. -runExperimentWithExecutor :: ExperimentRendering r - => ([IO ()] -> IO ()) +runExperimentWithExecutor :: (ExperimentRendering r, + Monad (ExperimentMonad r), + MonadIO (ExperimentMonad r), + MonadException (ExperimentMonad r)) + => ([IO ()] -> IO a) -- ^ an executor that allows parallelizing the simulation if required -> Experiment -- ^ the simulation experiment to run @@ -176,45 +201,44 @@ -- ^ the rendering backend -> Simulation Results -- ^ the simulation results received from the model - -> IO () + -> IO (Either SomeException a) +{-# INLINABLE runExperimentWithExecutor #-} runExperimentWithExecutor executor e generators r simulation = - runExperimentWriter $ + liftExperiment r $ do let specs = experimentSpecs e runCount = experimentRunCount e - dirName = experimentDirectoryName e - path <- resolveFilePath "" dirName - liftIO $ do - when (experimentVerbose e) $ - do putStr "Updating directory " - putStrLn path - createDirectoryIfMissing True path - reporters <- mapM (\x -> generateReporter x e r path) - generators - forM_ reporters reporterInitialise - let simulate :: Simulation () - simulate = - do signals <- newResultPredefinedSignals - results <- simulation - let d = ExperimentData { experimentResults = experimentTransform e results, - experimentPredefinedSignals = signals } - fs <- runDynamicsInStartTime $ - runEventWith EarlierEvents $ - forM reporters $ \reporter -> - reporterSimulate reporter d - let m1 = - runEventInStopTime $ - return () - m2 = - runEventInStopTime $ - disposeEvent $ mconcat fs - mh (SimulationException e') = - when (experimentVerbose e) $ - liftIO $ - do putStr "A simulation exception has been raised when running: " - putStrLn $ show e' - finallySimulation (catchSimulation m1 mh) m2 - liftIO $ - executor $ runSimulations simulate specs runCount - forM_ reporters reporterFinalise - renderExperiment e r reporters path - return () + env <- prepareExperiment e r + let c1 = + do reporters <- mapM (\x -> generateReporter x e r env) + generators + forM_ reporters reporterInitialise + let simulate :: Simulation () + simulate = + do signals <- newResultPredefinedSignals + results <- simulation + let d = ExperimentData { experimentResults = experimentTransform e results, + experimentPredefinedSignals = signals } + ((), fs) <- runDynamicsInStartTime $ + runEventWith EarlierEvents $ + flip runComposite mempty $ + forM_ reporters $ \reporter -> + reporterSimulate reporter d + let m1 = + runEventInStopTime $ + return () + m2 = + runEventInStopTime $ + disposeEvent fs + mh (SimulationAbort e') = + return () + finallySimulation (catchSimulation m1 mh) m2 + a <- liftIO $ + executor $ runSimulations simulate specs runCount + forM_ reporters reporterFinalise + renderExperiment e r reporters env + onExperimentCompleted e r env + return (Right a) + ch z@(SomeException e') = + do onExperimentFailed e r env e' + return (Left z) + catchComp c1 ch diff --git a/Simulation/Aivika/Experiment/Utils.hs b/Simulation/Aivika/Experiment/Utils.hs --- a/Simulation/Aivika/Experiment/Utils.hs +++ b/Simulation/Aivika/Experiment/Utils.hs @@ -1,11 +1,11 @@ -- | -- Module : Simulation.Aivika.Experiment.Utils --- Copyright : Copyright (c) 2012-2015, David Sorokin +-- Copyright : Copyright (c) 2012-2017, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental --- Tested with: GHC 7.10.1 +-- Tested with: GHC 8.0.1 -- -- It defines utility functions missed in the standard library. -- diff --git a/Simulation/Aivika/Experiment/WebPageRenderer.hs b/Simulation/Aivika/Experiment/WebPageRenderer.hs deleted file mode 100644 --- a/Simulation/Aivika/Experiment/WebPageRenderer.hs +++ /dev/null @@ -1,85 +0,0 @@ - -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Simulation.Aivika.Experiment.Types --- Copyright : Copyright (c) 2012-2015, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.10.1 --- --- It defines a renderer that creates a web page when running the simulation experiment. --- - -module Simulation.Aivika.Experiment.WebPageRenderer where - -import Control.Monad -import Control.Monad.Trans - -import System.IO -import System.Directory -import System.FilePath - -import Simulation.Aivika -import Simulation.Aivika.Experiment.Types -import Simulation.Aivika.Experiment.HtmlWriter -import Simulation.Aivika.Experiment.ExperimentWriter - --- | It defines the web page renderer for simulation 'Experiment'. -data WebPageRenderer a = WebPageRenderer a - -- ^ A renderer that depends on the provided parameter. - --- | It replies to the requests made by the web page renderer. -data WebPageWriter = - WebPageWriter { reporterWriteTOCHtml :: Int -> HtmlWriter (), - -- ^ Return a TOC (Table of Contents) item for - -- the HTML index file after the finalisation - -- function is called, i.e. in the very end. - -- The agument specifies the ordered number of - -- the item. - -- - -- You should wrap your HTML in 'writeHtmlListItem'. - reporterWriteHtml :: Int -> HtmlWriter () - -- ^ Return an HTML code for the index file - -- after the finalisation function is called, - -- i.e. in the very end. The agument specifies - -- the ordered number of the item. - } - --- | A convenient type synonym for describing a web page generator. -type WebPageGenerator a = ExperimentGenerator (WebPageRenderer a) - --- | Rending a web page with results when running the simulation experiment. -instance ExperimentRendering (WebPageRenderer a) where - - -- | A web page context. - newtype ExperimentContext (WebPageRenderer a) = - WebPageContext { runWebPageContext :: WebPageWriter - -- ^ Run the web page context. - } - - renderExperiment e r reporters path = - do let html :: HtmlWriter () - html = - writeHtmlDocumentWithTitle (experimentTitle e) $ - do writeHtmlList $ - forM_ (zip [1..] reporters) $ \(i, reporter) -> - reporterWriteTOCHtml (runWebPageContext $ - reporterContext reporter) i - writeHtmlBreak - unless (null $ experimentDescription e) $ - writeHtmlParagraph $ - writeHtmlText $ experimentDescription e - forM_ (zip [1..] reporters) $ \(i, reporter) -> - reporterWriteHtml (runWebPageContext $ - reporterContext reporter) i - file = combine path "index.html" - ((), contents) <- runHtmlWriter html id - liftIO $ - withFile file WriteMode $ \h -> - do hSetEncoding h utf8 - hPutStr h (contents []) - when (experimentVerbose e) $ - do putStr "Generated file " - putStrLn file diff --git a/Simulation/Aivika/Trans/Experiment.hs b/Simulation/Aivika/Trans/Experiment.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/Experiment.hs @@ -0,0 +1,17 @@ + +-- | +-- Module : Simulation.Aivika.Trans.Experiment +-- Copyright : Copyright (c) 2012-2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 8.0.1 +-- +-- This module re-exports the library functionality. +-- + +module Simulation.Aivika.Trans.Experiment + (-- * Modules + module Simulation.Aivika.Trans.Experiment.Types) where + +import Simulation.Aivika.Trans.Experiment.Types diff --git a/Simulation/Aivika/Trans/Experiment/Concurrent/MVar.hs b/Simulation/Aivika/Trans/Experiment/Concurrent/MVar.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/Experiment/Concurrent/MVar.hs @@ -0,0 +1,197 @@ + +-- | +-- Module : Simulation.Aivika.Trans.Experiment.Concurrent.MVar +-- Copyright : Copyright (c) 2012-2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 8.0.1 +-- +-- The module defines helper functions for working with synchronized variable 'MVar'. +-- + +module Simulation.Aivika.Trans.Experiment.Concurrent.MVar + (maybeReadMVarComp, + maybeReadMVarParameter, + maybeReadMVarSimulation, + maybeReadMVarDynamics, + maybeReadMVarEvent, + maybeReadMVarProcess, + maybePutMVarComp, + maybePutMVarParameter, + maybePutMVarSimulation, + maybePutMVarDynamics, + maybePutMVarEvent, + maybePutMVarProcess) where + +import Control.Exception +import Control.Concurrent.MVar +import Control.Monad +import Control.Monad.Trans + +import Data.Maybe + +import Simulation.Aivika.Trans + +-- | Like 'maybe' but for the synchronized variable. +maybeReadMVarComp :: (MonadComp m, MonadIO m) => b -> (a -> m b) -> MVar (Maybe a) -> m b +{-# INLINABLE maybeReadMVarComp #-} +maybeReadMVarComp b0 f x = + do a <- liftIO $ readMVar x + case a of + Just a -> f a + Nothing -> return b0 + +-- | Like 'maybeReadMVarComp' but within the 'Parameter' computation. +maybeReadMVarParameter :: (MonadComp m, MonadIO m) => b -> (a -> Parameter m b) -> MVar (Maybe a) -> Parameter m b +{-# INLINABLE maybeReadMVarParameter #-} +maybeReadMVarParameter b0 f x = + do a <- liftIO $ readMVar x + case a of + Just a -> f a + Nothing -> return b0 + +-- | Like 'maybeReadMVarComp' but within the 'Simulation' computation. +maybeReadMVarSimulation :: (MonadComp m, MonadIO m) => b -> (a -> Simulation m b) -> MVar (Maybe a) -> Simulation m b +{-# INLINABLE maybeReadMVarSimulation #-} +maybeReadMVarSimulation b0 f x = + do a <- liftIO $ readMVar x + case a of + Just a -> f a + Nothing -> return b0 + +-- | Like 'maybeReadMVarComp' but within the 'Dynamics' computation. +maybeReadMVarDynamics :: (MonadComp m, MonadIO m) => b -> (a -> Dynamics m b) -> MVar (Maybe a) -> Dynamics m b +{-# INLINABLE maybeReadMVarDynamics #-} +maybeReadMVarDynamics b0 f x = + do a <- liftIO $ readMVar x + case a of + Just a -> f a + Nothing -> return b0 + +-- | Like 'maybeReadMVarComp' but within the 'Event' computation. +maybeReadMVarEvent :: (MonadComp m, MonadIO m) => b -> (a -> Event m b) -> MVar (Maybe a) -> Event m b +{-# INLINABLE maybeReadMVarEvent #-} +maybeReadMVarEvent b0 f x = + do a <- liftIO $ readMVar x + case a of + Just a -> f a + Nothing -> return b0 + +-- | Like 'maybeReadMVarComp' but within the 'Process' computation. +maybeReadMVarProcess :: (MonadDES m, MonadIO m) => b -> (a -> Process m b) -> MVar (Maybe a) -> Process m b +{-# INLINABLE maybeReadMVarProcess #-} +maybeReadMVarProcess b0 f x = + do a <- liftIO $ readMVar x + case a of + Just a -> f a + Nothing -> return b0 + +-- | Update the contents if the variable was empty and then return a result of +-- applying the specified function to either the initial or current value. +maybePutMVarComp :: (MonadComp m, MonadIO m) => MVar (Maybe a) -> m a -> (a -> m b) -> m b +{-# INLINABLE maybePutMVarComp #-} +maybePutMVarComp x m0 f = + -- N.B. it should be actually masked to be protected from the asynchronous exceptions + do a <- liftIO $ takeMVar x + case a of + Just a -> + do liftIO $ putMVar x (Just a) + f a + Nothing -> + do let handle :: (MonadComp m, MonadIO m) => SomeException -> m a + handle e = do liftIO $ putMVar x Nothing + throwComp e + a0 <- catchComp m0 handle + liftIO $ putMVar x (Just a0) + f a0 + +-- | Like 'maybePutMVarComp' but within the 'Parameter' computation. +maybePutMVarParameter :: (MonadComp m, MonadIO m) => MVar (Maybe a) -> Parameter m a -> (a -> Parameter m b) -> Parameter m b +{-# INLINABLE maybePutMVarParameter #-} +maybePutMVarParameter x m0 f = + -- N.B. it should be actually masked to be protected from the asynchronous exceptions + do a <- liftIO $ takeMVar x + case a of + Just a -> + do liftIO $ putMVar x (Just a) + f a + Nothing -> + do let handle :: (MonadComp m, MonadIO m) => SomeException -> Parameter m a + handle e = do liftIO $ putMVar x Nothing + throwParameter e + a0 <- catchParameter m0 handle + liftIO $ putMVar x (Just a0) + f a0 + +-- | Like 'maybePutMVarComp' but within the 'Simulation' computation. +maybePutMVarSimulation :: (MonadComp m, MonadIO m) => MVar (Maybe a) -> Simulation m a -> (a -> Simulation m b) -> Simulation m b +{-# INLINABLE maybePutMVarSimulation #-} +maybePutMVarSimulation x m0 f = + -- N.B. it should be actually masked to be protected from the asynchronous exceptions + do a <- liftIO $ takeMVar x + case a of + Just a -> + do liftIO $ putMVar x (Just a) + f a + Nothing -> + do let handle :: (MonadComp m, MonadIO m) => SomeException -> Simulation m a + handle e = do liftIO $ putMVar x Nothing + throwSimulation e + a0 <- catchSimulation m0 handle + liftIO $ putMVar x (Just a0) + f a0 + +-- | Like 'maybePutMVarComp' but within the 'Dynamics' computation. +maybePutMVarDynamics :: (MonadComp m, MonadIO m) => MVar (Maybe a) -> Dynamics m a -> (a -> Dynamics m b) -> Dynamics m b +{-# INLINABLE maybePutMVarDynamics #-} +maybePutMVarDynamics x m0 f = + -- N.B. it should be actually masked to be protected from the asynchronous exceptions + do a <- liftIO $ takeMVar x + case a of + Just a -> + do liftIO $ putMVar x (Just a) + f a + Nothing -> + do let handle :: (MonadComp m, MonadIO m) => SomeException -> Dynamics m a + handle e = do liftIO $ putMVar x Nothing + throwDynamics e + a0 <- catchDynamics m0 handle + liftIO $ putMVar x (Just a0) + f a0 + +-- | Like 'maybePutMVarComp' but within the 'Event' computation. +maybePutMVarEvent :: (MonadComp m, MonadIO m) => MVar (Maybe a) -> Event m a -> (a -> Event m b) -> Event m b +{-# INLINABLE maybePutMVarEvent #-} +maybePutMVarEvent x m0 f = + -- N.B. it should be actually masked to be protected from the asynchronous exceptions + do a <- liftIO $ takeMVar x + case a of + Just a -> + do liftIO $ putMVar x (Just a) + f a + Nothing -> + do let handle :: (MonadComp m, MonadIO m) => SomeException -> Event m a + handle e = do liftIO $ putMVar x Nothing + throwEvent e + a0 <- catchEvent m0 handle + liftIO $ putMVar x (Just a0) + f a0 + +-- | Like 'maybePutMVarComp' but within the 'Process' computation. +maybePutMVarProcess :: (MonadDES m, MonadIO m) => MVar (Maybe a) -> Process m a -> (a -> Process m b) -> Process m b +{-# INLINABLE maybePutMVarProcess #-} +maybePutMVarProcess x m0 f = + -- N.B. it should be actually masked to be protected from the asynchronous exceptions + do a <- liftIO $ takeMVar x + case a of + Just a -> + do liftIO $ putMVar x (Just a) + f a + Nothing -> + do let handle :: (MonadDES m, MonadIO m) => SomeException -> Process m a + handle e = do liftIO $ putMVar x Nothing + throwProcess e + a0 <- catchProcess m0 handle + liftIO $ putMVar x (Just a0) + f a0 diff --git a/Simulation/Aivika/Trans/Experiment/Types.hs b/Simulation/Aivika/Trans/Experiment/Types.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Trans/Experiment/Types.hs @@ -0,0 +1,402 @@ + +{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleContexts #-} + +-- | +-- Module : Simulation.Aivika.Trans.Experiment.Types +-- Copyright : Copyright (c) 2012-2017, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 8.0.1 +-- +-- The module defines the simulation experiments. They automate +-- the process of generating and analyzing the results. Moreover, +-- this module is open to extensions, allowing you to define +-- your own output views for the simulation results, for example, +-- such views that would allow saving the results in PDF or as +-- charts. To decrease the number of dependencies, such possible +-- extenstions are not included in this package, although simple +-- views are provided. +-- + +module Simulation.Aivika.Trans.Experiment.Types where + +import Control.Monad +import Control.Exception + +import Data.Maybe +import Data.Monoid +import Data.Either + +import GHC.Conc (getNumCapabilities) + +import Simulation.Aivika.Trans + +-- | It defines the simulation experiment with the specified rendering backend and its bound data. +data Experiment m = + Experiment { experimentSpecs :: Specs m, + -- ^ The simulation specs for the experiment. + experimentTransform :: ResultTransform m, + -- ^ How the results must be transformed before rendering. + experimentLocalisation :: ResultLocalisation, + -- ^ Specifies a localisation applied when rendering the experiment. + experimentRunCount :: Int, + -- ^ How many simulation runs should be launched. + experimentTitle :: String, + -- ^ The experiment title. + experimentDescription :: String, + -- ^ The experiment description. + experimentVerbose :: Bool, + -- ^ Whether the process of generating the results is verbose. + experimentNumCapabilities :: IO Int + -- ^ The number of threads used for the Monte-Carlo simulation + -- if the executable was compiled with the support of multi-threading. + } + +-- | The default experiment. +defaultExperiment :: Experiment m +defaultExperiment = + Experiment { experimentSpecs = Specs 0 10 0.01 RungeKutta4 SimpleGenerator, + experimentTransform = id, + experimentLocalisation = englishResultLocalisation, + experimentRunCount = 1, + experimentTitle = "Simulation Experiment", + experimentDescription = "", + experimentVerbose = True, + experimentNumCapabilities = getNumCapabilities } + +-- | Allows specifying the experiment monad. +class ExperimentMonadProviding r (m :: * -> *) where + + -- | Defines the experiment monad type. + type ExperimentMonad r m :: * -> * + +-- | Defines the experiment computation that tries to perform the calculation. +type ExperimentMonadTry r m a = ExperimentMonad r m (Either SomeException a) + +-- | It allows rendering the simulation results in an arbitrary way. +class ExperimentMonadProviding r m => ExperimentRendering r m where + + -- | Defines a context used when rendering the experiment. + data ExperimentContext r m :: * + + -- | Defines the experiment environment. + type ExperimentEnvironment r m :: * + + -- | Prepare before rendering the experiment. + prepareExperiment :: Experiment m -> r -> ExperimentMonad r m (ExperimentEnvironment r m) + + -- | Render the experiment after the simulation is finished, for example, + -- creating the @index.html@ file in the specified directory. + renderExperiment :: Experiment m -> r -> [ExperimentReporter r m] -> ExperimentEnvironment r m -> ExperimentMonad r m () + + -- | It is called when the experiment has been completed. + onExperimentCompleted :: Experiment m -> r -> ExperimentEnvironment r m -> ExperimentMonad r m () + + -- | It is called when the experiment rendering has failed. + onExperimentFailed :: Exception e => Experiment m -> r -> ExperimentEnvironment r m -> e -> ExperimentMonad r m () + +-- | This is a generator of the reporter with the specified rendering backend. +data ExperimentGenerator r m = + ExperimentGenerator { generateReporter :: Experiment m -> r -> ExperimentEnvironment r m -> ExperimentMonad r m (ExperimentReporter r m) + -- ^ Generate a reporter. + } + +-- | Defines a view in which the simulation results should be saved. +-- You should extend this type class to define your own views such +-- as the PDF document. +class ExperimentRendering r m => ExperimentView v r m where + + -- | Create a generator of the reporter. + outputView :: v m -> ExperimentGenerator r m + +-- | It describes the source simulation data used in the experiment. +data ExperimentData m = + ExperimentData { experimentResults :: Results m, + -- ^ The simulation results used in the experiment. + experimentPredefinedSignals :: ResultPredefinedSignals m + -- ^ The predefined signals provided by every model. + } + +-- | Defines what creates the simulation reports by the specified renderer. +data ExperimentReporter r m = + ExperimentReporter { reporterInitialise :: ExperimentMonad r m (), + -- ^ Initialise the reporting before + -- the simulation runs are started. + reporterFinalise :: ExperimentMonad r m (), + -- ^ Finalise the reporting after + -- all simulation runs are finished. + reporterSimulate :: ExperimentData m -> Composite m (), + -- ^ Start the simulation run in the start time. + reporterContext :: ExperimentContext r m + -- ^ Return a context used by the renderer. + } + +-- | Run the simulation experiment sequentially. +runExperiment_ :: (MonadDES m, + ExperimentRendering r m, + Monad (ExperimentMonad r m), + MonadException (ExperimentMonad r m)) + => (m () -> ExperimentMonad r m a) + -- ^ the function that actually starts the simulation run + -> Experiment m + -- ^ the simulation experiment to run + -> [ExperimentGenerator r m] + -- ^ generators used for rendering + -> r + -- ^ the rendering backend + -> Simulation m (Results m) + -- ^ the simulation results received from the model + -> ExperimentMonadTry r m () +{-# INLINABLE runExperiment_ #-} +runExperiment_ executor0 e generators r simulation = + do x <- runExperimentWithExecutor executor e generators r simulation + return (x >> return ()) + where executor = sequence_ . map executor0 + +-- | Run the simulation experiment sequentially. +runExperiment :: (MonadDES m, + ExperimentRendering r m, + Monad (ExperimentMonad r m), + MonadException (ExperimentMonad r m)) + => (m () -> ExperimentMonad r m a) + -- ^ the function that actually starts the simulation run + -> Experiment m + -- ^ the simulation experiment to run + -> [ExperimentGenerator r m] + -- ^ generators used for rendering + -> r + -- ^ the rendering backend + -> Simulation m (Results m) + -- ^ the simulation results received from the model + -> ExperimentMonadTry r m [a] +{-# INLINABLE runExperiment #-} +runExperiment executor0 = runExperimentWithExecutor executor + where executor = sequence . map executor0 + +-- | Run the simulation experiment with the specified executor. +runExperimentWithExecutor :: (MonadDES m, + ExperimentRendering r m, + Monad (ExperimentMonad r m), + MonadException (ExperimentMonad r m)) + => ([m ()] -> ExperimentMonad r m a) + -- ^ an executor that allows parallelizing the simulation if required + -> Experiment m + -- ^ the simulation experiment to run + -> [ExperimentGenerator r m] + -- ^ generators used for rendering + -> r + -- ^ the rendering backend + -> Simulation m (Results m) + -- ^ the simulation results received from the model + -> ExperimentMonadTry r m a +{-# INLINABLE runExperimentWithExecutor #-} +runExperimentWithExecutor executor e generators r simulation = + do let specs = experimentSpecs e + runCount = experimentRunCount e + env <- prepareExperiment e r + let c1 = + do reporters <- mapM (\x -> generateReporter x e r env) + generators + forM_ reporters reporterInitialise + let simulate = + do signals <- newResultPredefinedSignals + results <- simulation + let d = ExperimentData { experimentResults = experimentTransform e results, + experimentPredefinedSignals = signals } + ((), fs) <- runDynamicsInStartTime $ + runEventWith EarlierEvents $ + flip runComposite mempty $ + forM_ reporters $ \reporter -> + reporterSimulate reporter d + let m1 = + runEventInStopTime $ + return () + m2 = + runEventInStopTime $ + disposeEvent fs + mh (SimulationAbort e') = + return () + finallySimulation (catchSimulation m1 mh) m2 + a <- executor $ + runSimulations simulate specs runCount + forM_ reporters reporterFinalise + renderExperiment e r reporters env + onExperimentCompleted e r env + return (Right a) + ch z@(SomeException e') = + do onExperimentFailed e r env e' + return (Left z) + catchComp c1 ch + +-- | Run the simulation experiment by the specified run index in series. +runExperimentByIndex :: (MonadDES m, + ExperimentRendering r m, + Monad (ExperimentMonad r m), + MonadException (ExperimentMonad r m)) + => (m () -> ExperimentMonad r m a) + -- ^ the function that actually starts the simulation run + -> Experiment m + -- ^ the simulation experiment to run + -> [ExperimentGenerator r m] + -- ^ generators used for rendering + -> r + -- ^ the rendering backend + -> Simulation m (Results m) + -- ^ the simulation results received from the model + -> Int + -- ^ the index of the current run (started from 1) + -> ExperimentMonadTry r m a +{-# INLINABLE runExperimentByIndex #-} +runExperimentByIndex executor e generators r simulation runIndex = + do let specs = experimentSpecs e + runCount = experimentRunCount e + env <- prepareExperiment e r + let c1 = + do reporters <- mapM (\x -> generateReporter x e r env) + generators + forM_ reporters reporterInitialise + let simulate = + do signals <- newResultPredefinedSignals + results <- simulation + let d = ExperimentData { experimentResults = experimentTransform e results, + experimentPredefinedSignals = signals } + ((), fs) <- runDynamicsInStartTime $ + runEventWith EarlierEvents $ + flip runComposite mempty $ + forM_ reporters $ \reporter -> + reporterSimulate reporter d + let m1 = + runEventInStopTime $ + return () + m2 = + runEventInStopTime $ + disposeEvent fs + mh (SimulationAbort e') = + return () + finallySimulation (catchSimulation m1 mh) m2 + a <- executor $ + runSimulationByIndex simulate specs runCount runIndex + forM_ reporters reporterFinalise + renderExperiment e r reporters env + onExperimentCompleted e r env + return (Right a) + ch z@(SomeException e') = + do onExperimentFailed e r env e' + return (Left z) + catchComp c1 ch + +-- | Run the simulation experiment by the specified run index in series. +runExperimentByIndex_ :: (MonadDES m, + ExperimentRendering r m, + Monad (ExperimentMonad r m), + MonadException (ExperimentMonad r m)) + => (m () -> ExperimentMonad r m a) + -- ^ the function that actually starts the simulation run + -> Experiment m + -- ^ the simulation experiment to run + -> [ExperimentGenerator r m] + -- ^ generators used for rendering + -> r + -- ^ the rendering backend + -> Simulation m (Results m) + -- ^ the simulation results received from the model + -> Int + -- ^ the index of the current run (started from 1) + -> ExperimentMonadTry r m () +{-# INLINABLE runExperimentByIndex_ #-} +runExperimentByIndex_ executor e generators r simulation runIndex = + do x <- runExperimentByIndex executor e generators r simulation runIndex + return (x >> return ()) + +-- | Run the simulation experiment by the specified run index in series +-- returning the continuation of the actual computation. +runExperimentContByIndex :: (MonadDES m, + ExperimentRendering r m, + Monad (ExperimentMonad r m), + MonadException (ExperimentMonad r m)) + => (m () -> ExperimentMonad r m (a, ExperimentMonad r m b)) + -- ^ the function that actually starts the simulation run + -- and returns the corresponding continuation + -> Experiment m + -- ^ the simulation experiment to run + -> [ExperimentGenerator r m] + -- ^ generators used for rendering + -> r + -- ^ the rendering backend + -> Simulation m (Results m) + -- ^ the simulation results received from the model + -> Int + -- ^ the index of the current run (started from 1) + -> ExperimentMonadTry r m (a, ExperimentMonadTry r m b) +{-# INLINABLE runExperimentContByIndex #-} +runExperimentContByIndex executor e generators r simulation runIndex = + do let specs = experimentSpecs e + runCount = experimentRunCount e + env <- prepareExperiment e r + let c1 = + do reporters <- mapM (\x -> generateReporter x e r env) + generators + forM_ reporters reporterInitialise + let simulate = + do signals <- newResultPredefinedSignals + results <- simulation + let d = ExperimentData { experimentResults = experimentTransform e results, + experimentPredefinedSignals = signals } + ((), fs) <- runDynamicsInStartTime $ + runEventWith EarlierEvents $ + flip runComposite mempty $ + forM_ reporters $ \reporter -> + reporterSimulate reporter d + let m1 = + runEventInStopTime $ + return () + m2 = + runEventInStopTime $ + disposeEvent fs + mh (SimulationAbort e') = + return () + finallySimulation (catchSimulation m1 mh) m2 + (a, m) <- executor $ + runSimulationByIndex simulate specs runCount runIndex + let m2 = + do b <- m + forM_ reporters reporterFinalise + renderExperiment e r reporters env + onExperimentCompleted e r env + return (Right b) + mh z@(SomeException e') = + do onExperimentFailed e r env e' + return (Left z) + return (Right (a, catchComp m2 mh)) + ch z@(SomeException e') = + do onExperimentFailed e r env e' + return (Left z) + catchComp c1 ch + +-- | Run the simulation experiment by the specified run index in series +-- returning the continuation of the actual computation. +runExperimentContByIndex_ :: (MonadDES m, + ExperimentRendering r m, + Monad (ExperimentMonad r m), + MonadException (ExperimentMonad r m)) + => (m () -> ExperimentMonad r m (a, ExperimentMonad r m b)) + -- ^ the function that actually starts the simulation run + -- and returns the corresponding continuation + -> Experiment m + -- ^ the simulation experiment to run + -> [ExperimentGenerator r m] + -- ^ generators used for rendering + -> r + -- ^ the rendering backend + -> Simulation m (Results m) + -- ^ the simulation results received from the model + -> Int + -- ^ the index of the current run (started from 1) + -> ExperimentMonadTry r m (a, ExperimentMonadTry r m ()) +{-# INLINABLE runExperimentContByIndex_ #-} +runExperimentContByIndex_ executor e generators r simulation runIndex = + do x <- runExperimentContByIndex executor e generators r simulation runIndex + case x of + Left e -> return (Left e) + Right (a, cont) -> return $ Right (a, cont >> return (Right ())) diff --git a/aivika-experiment.cabal b/aivika-experiment.cabal --- a/aivika-experiment.cabal +++ b/aivika-experiment.cabal @@ -1,21 +1,26 @@ name: aivika-experiment -version: 4.0.3 +version: 5.0 synopsis: Simulation experiments for the Aivika library description: - This package allows defining simulation experiments for the Aivika - package. Such experiments define in declarative manner what should be - simulated and in which view the simulation results should be - generated. It can be charts, tables and so on. + This package allows defining simulation experiments based on the aivika [1] + and aivika-transformers [2] packages. Such experiments define in declarative + manner what should be simulated and in which view the simulation results should + be generated. It can directly return charts, tables and so on. Additionally, it + can save the results in SQL databases. . The library is extensible and you can add new views for the results. . + \[1] + . + \[2] + . category: Simulation license: BSD3 license-file: LICENSE -copyright: (c) 2012-2015. David Sorokin +copyright: (c) 2012-2017. David Sorokin author: David Sorokin maintainer: David Sorokin -homepage: http://github.com/dsorokin/aivika-experiment +homepage: http://www.aivikasoft.com cabal-version: >= 1.6 build-type: Simple tested-with: GHC == 7.10.1 @@ -26,24 +31,28 @@ library exposed-modules: Simulation.Aivika.Experiment + Simulation.Aivika.Experiment.Concurrent.MVar Simulation.Aivika.Experiment.Types - Simulation.Aivika.Experiment.HtmlWriter - Simulation.Aivika.Experiment.LastValueView - Simulation.Aivika.Experiment.TableView - Simulation.Aivika.Experiment.TimingStatsView - Simulation.Aivika.Experiment.TimingStatsWriter - Simulation.Aivika.Experiment.SamplingStatsWriter - Simulation.Aivika.Experiment.FinalStatsView + Simulation.Aivika.Experiment.Base + Simulation.Aivika.Experiment.Base.ExperimentSpecsView + Simulation.Aivika.Experiment.Base.ExperimentSpecsWriter + Simulation.Aivika.Experiment.Base.ExperimentWriter + Simulation.Aivika.Experiment.Base.FileRenderer + Simulation.Aivika.Experiment.Base.FinalStatsView + Simulation.Aivika.Experiment.Base.FinalTableView + Simulation.Aivika.Experiment.Base.InfoView + Simulation.Aivika.Experiment.Base.HtmlWriter + Simulation.Aivika.Experiment.Base.LastValueView + Simulation.Aivika.Experiment.Base.SamplingStatsWriter + Simulation.Aivika.Experiment.Base.TableView + Simulation.Aivika.Experiment.Base.TimingStatsView + Simulation.Aivika.Experiment.Base.TimingStatsWriter + Simulation.Aivika.Experiment.Base.WebPageRenderer Simulation.Aivika.Experiment.Histogram - Simulation.Aivika.Experiment.ExperimentSpecsView - Simulation.Aivika.Experiment.ExperimentSpecsWriter - Simulation.Aivika.Experiment.ExperimentWriter - Simulation.Aivika.Experiment.FinalTableView - Simulation.Aivika.Experiment.InfoView Simulation.Aivika.Experiment.Utils - Simulation.Aivika.Experiment.MRef - Simulation.Aivika.Experiment.WebPageRenderer - Simulation.Aivika.Experiment.FileRenderer + Simulation.Aivika.Trans.Experiment + Simulation.Aivika.Trans.Experiment.Concurrent.MVar + Simulation.Aivika.Trans.Experiment.Types build-depends: base >= 4.2 && < 6, mtl >= 1.1.0.2, @@ -53,9 +62,11 @@ split >= 0.2.2, network-uri >= 2.6, parallel-io >= 0.3.2.1, - aivika >= 4.0.3 + aivika >= 5.1, + aivika-transformers >= 5.1 extensions: MultiParamTypeClasses, + FlexibleContexts, TypeFamilies ghc-options: -O2 diff --git a/examples/LinearArray.hs b/examples/LinearArray.hs --- a/examples/LinearArray.hs +++ b/examples/LinearArray.hs @@ -19,6 +19,7 @@ import Simulation.Aivika import Simulation.Aivika.SystemDynamics import Simulation.Aivika.Experiment +import Simulation.Aivika.Experiment.Base specs = Specs { spcStartTime = 0, spcStopTime = 500, @@ -59,31 +60,22 @@ experimentDescription = "Model Linear Array as described in " ++ "the examples included in Berkeley-Madonna." } +t = resultByName "t" +m = resultByName "m" +c = resultByName "c" + generators :: [WebPageGenerator a] generators = [outputView defaultExperimentSpecsView, outputView $ defaultTableView { - tableSeries = - resultByName "t" <> - resultByName "m" <> - resultByName "c" }, + tableSeries = t <> m <> c }, outputView $ defaultFinalTableView { - finalTableSeries = - resultByName "m" <> - resultByName "c" }, + finalTableSeries = m <> c }, outputView $ defaultLastValueView { - lastValueSeries = - resultByName "t" <> - resultByName "m" <> - resultByName "c" }, + lastValueSeries = t <> m <> c }, outputView $ defaultTimingStatsView { - timingStatsSeries = - resultByName "t" <> - resultByName "m" <> - resultByName "c" }, + timingStatsSeries = t <> m <> c }, outputView $ defaultFinalStatsView { - finalStatsSeries = - resultByName "m" <> - resultByName "c" } ] + finalStatsSeries = m <> c } ] -main = runExperiment experiment generators (WebPageRenderer ()) (model 51) +main = runExperiment experiment generators (WebPageRenderer () experimentFilePath) (model 51) diff --git a/examples/MachRep3.hs b/examples/MachRep3.hs --- a/examples/MachRep3.hs +++ b/examples/MachRep3.hs @@ -18,6 +18,7 @@ import Simulation.Aivika import Simulation.Aivika.Experiment +import Simulation.Aivika.Experiment.Base meanUpTime = 1.0 meanRepairTime = 0.5 @@ -43,20 +44,23 @@ experimentRunCount = 3, experimentDescription = description } +x = resultByName "x" +t = resultByName "t" + generators :: [WebPageGenerator a] generators = [outputView defaultExperimentSpecsView, outputView defaultInfoView, outputView $ defaultLastValueView { - lastValueSeries = resultByName "x" }, + lastValueSeries = x }, outputView $ defaultTimingStatsView { - timingStatsSeries = resultByName "x" }, + timingStatsSeries = x }, outputView $ defaultFinalStatsView { - finalStatsSeries = resultByName "x" }, + finalStatsSeries = x }, outputView $ defaultTableView { - tableSeries = resultByName "x" }, + tableSeries = x }, outputView $ defaultFinalTableView { - finalTableSeries = resultByName "x" } ] + finalTableSeries = x } ] model :: Simulation Results model = @@ -116,4 +120,4 @@ [resultSource "x" "The proportion of up time" prop, resultSource "t" "Simulation time" time] -main = runExperiment experiment generators (WebPageRenderer ()) model +main = runExperiment experiment generators (WebPageRenderer () experimentFilePath) model