diff --git a/Simulation/Aivika/Experiment.hs b/Simulation/Aivika/Experiment.hs --- a/Simulation/Aivika/Experiment.hs +++ b/Simulation/Aivika/Experiment.hs @@ -5,7 +5,7 @@ -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental --- Tested with: GHC 7.6.3 +-- Tested with: GHC 7.8.3 -- -- This module re-exports the library functionality. -- @@ -13,35 +13,29 @@ module Simulation.Aivika.Experiment (-- * Modules module Simulation.Aivika.Experiment.Types, - module Simulation.Aivika.Experiment.FileRenderer, 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.SamplingStatsSource, module Simulation.Aivika.Experiment.FinalStatsView, module Simulation.Aivika.Experiment.Histogram, module Simulation.Aivika.Experiment.ExperimentSpecsView, module Simulation.Aivika.Experiment.ExperimentSpecsWriter, module Simulation.Aivika.Experiment.FinalTableView, - module Simulation.Aivika.Experiment.ListSource, module Simulation.Aivika.Experiment.Utils) where import Simulation.Aivika.Experiment.Types -import Simulation.Aivika.Experiment.FileRenderer 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.SamplingStatsSource import Simulation.Aivika.Experiment.FinalStatsView import Simulation.Aivika.Experiment.Histogram import Simulation.Aivika.Experiment.ExperimentSpecsView import Simulation.Aivika.Experiment.ExperimentSpecsWriter import Simulation.Aivika.Experiment.FinalTableView -import Simulation.Aivika.Experiment.ListSource import Simulation.Aivika.Experiment.Utils diff --git a/Simulation/Aivika/Experiment/ExperimentSpecsView.hs b/Simulation/Aivika/Experiment/ExperimentSpecsView.hs --- a/Simulation/Aivika/Experiment/ExperimentSpecsView.hs +++ b/Simulation/Aivika/Experiment/ExperimentSpecsView.hs @@ -3,11 +3,11 @@ -- | -- Module : Simulation.Aivika.Experiment.ExperimentSpecsView --- Copyright : Copyright (c) 2012, David Sorokin +-- Copyright : Copyright (c) 2012-2014, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental --- Tested with: GHC 7.4.1 +-- Tested with: GHC 7.6.3 -- -- The module defines 'ExperimentSpecsView' that shows the -- experiment specs. @@ -20,6 +20,8 @@ import Control.Monad import Control.Monad.Trans +import Data.Monoid + import Simulation.Aivika.Experiment.Types import Simulation.Aivika.Experiment.HtmlWriter import Simulation.Aivika.Experiment.ExperimentSpecsWriter @@ -41,31 +43,33 @@ experimentSpecsDescription = "It shows the experiment specs.", experimentSpecsWriter = defaultExperimentSpecsWriter } -instance ExperimentView ExperimentSpecsView r where +instance WebPageRendering r => ExperimentView ExperimentSpecsView r WebPageWriter where outputView v = let reporter exp renderer dir = do st <- newExperimentSpecs v exp + let writer = + WebPageWriter { reporterWriteTOCHtml = experimentSpecsTOCHtml st, + reporterWriteHtml = experimentSpecsHtml st } return ExperimentReporter { reporterInitialise = return (), reporterFinalise = return (), - reporterSimulate = const $ return $ return (), - reporterTOCHtml = experimentSpecsTOCHtml st, - reporterHtml = experimentSpecsHtml st } + reporterSimulate = const $ return mempty, + reporterRequest = writer } in ExperimentGenerator { generateReporter = reporter } -- | The state of the view. -data ExperimentSpecsViewState r = +data ExperimentSpecsViewState = ExperimentSpecsViewState { experimentSpecsView :: ExperimentSpecsView, - experimentSpecsExperiment :: Experiment r } + experimentSpecsExperiment :: Experiment } -- | Create a new state of the view. -newExperimentSpecs :: ExperimentSpecsView -> Experiment r -> IO (ExperimentSpecsViewState r) +newExperimentSpecs :: ExperimentSpecsView -> Experiment -> IO ExperimentSpecsViewState newExperimentSpecs view exp = return ExperimentSpecsViewState { experimentSpecsView = view, experimentSpecsExperiment = exp } -- | Get the HTML code. -experimentSpecsHtml :: ExperimentSpecsViewState r -> Int -> HtmlWriter () +experimentSpecsHtml :: ExperimentSpecsViewState -> Int -> HtmlWriter () experimentSpecsHtml st index = do header st index let writer = experimentSpecsWriter (experimentSpecsView st) @@ -73,7 +77,7 @@ exp = experimentSpecsExperiment st write writer exp -header :: ExperimentSpecsViewState r -> Int -> HtmlWriter () +header :: ExperimentSpecsViewState -> Int -> HtmlWriter () header st index = do writeHtmlHeader3WithId ("id" ++ show index) $ writeHtmlText (experimentSpecsTitle $ experimentSpecsView st) @@ -83,7 +87,7 @@ writeHtmlText description -- | Get the TOC item -experimentSpecsTOCHtml :: ExperimentSpecsViewState r -> Int -> HtmlWriter () +experimentSpecsTOCHtml :: ExperimentSpecsViewState -> Int -> HtmlWriter () experimentSpecsTOCHtml st index = writeHtmlListItem $ writeHtmlLink ("#id" ++ show index) $ diff --git a/Simulation/Aivika/Experiment/ExperimentSpecsWriter.hs b/Simulation/Aivika/Experiment/ExperimentSpecsWriter.hs --- a/Simulation/Aivika/Experiment/ExperimentSpecsWriter.hs +++ b/Simulation/Aivika/Experiment/ExperimentSpecsWriter.hs @@ -1,13 +1,11 @@ -{-# LANGUAGE RankNTypes #-} - -- | -- Module : Simulation.Aivika.Experiment.ExperimentSpecsWriter --- Copyright : Copyright (c) 2012, David Sorokin +-- Copyright : Copyright (c) 2012-2014, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental --- Tested with: GHC 7.4.1 +-- Tested with: GHC 7.6.3 -- -- The module defines 'ExperimentSpecsWriter' that knows how to write -- in HTML the experiment specs which include the simulation specs and @@ -18,11 +16,10 @@ (ExperimentSpecsWriter(..), defaultExperimentSpecsWriter) where +import Simulation.Aivika import Simulation.Aivika.Experiment.Types import Simulation.Aivika.Experiment.HtmlWriter -import Simulation.Aivika.Specs - -- | Defines a writer that knows how to represent the -- experiment specs as the HTML table. data ExperimentSpecsWriter = @@ -48,9 +45,8 @@ -- ^ Translated text \"the 4-th order Runge-Kutta\". experimentSpecsFormatter :: ShowS, -- ^ The formatter of numbers. - experimentSpecsWrite :: forall r. - ExperimentSpecsWriter - -> Experiment r + experimentSpecsWrite :: ExperimentSpecsWriter + -> Experiment -> HtmlWriter () -- ^ This function creates HTML. } 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,24 +0,0 @@ - --- | --- Module : Simulation.Aivika.Experiment.FileRenderer --- Copyright : Copyright (c) 2012, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.4.1 --- --- It defines a basic experiment renderer that allows saving the simulation results in files. --- - -module Simulation.Aivika.Experiment.FileRenderer - (FileRenderer(..), - HtmlRenderer(..)) where - --- | The experiment renderer that allows saving the simulation results in files. -class FileRenderer a - --- | The default renderer that creates an HTML page for the simulation experiment. -data HtmlRenderer = HtmlRenderer - -- ^ The default HTML renderer. - -instance FileRenderer HtmlRenderer diff --git a/Simulation/Aivika/Experiment/FinalStatsView.hs b/Simulation/Aivika/Experiment/FinalStatsView.hs --- a/Simulation/Aivika/Experiment/FinalStatsView.hs +++ b/Simulation/Aivika/Experiment/FinalStatsView.hs @@ -3,11 +3,11 @@ -- | -- Module : Simulation.Aivika.Experiment.FinalStatsView --- Copyright : Copyright (c) 2012, David Sorokin +-- Copyright : Copyright (c) 2012-2014, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental --- Tested with: GHC 7.4.1 +-- Tested with: GHC 7.8.3 -- -- The module defines 'FinalStatsView' gathers the statistics -- in the final time points for different simulation runs. @@ -24,16 +24,11 @@ import Data.IORef import Data.Maybe +import Simulation.Aivika import Simulation.Aivika.Experiment.Types import Simulation.Aivika.Experiment.HtmlWriter import Simulation.Aivika.Experiment.SamplingStatsWriter -import Simulation.Aivika.Experiment.SamplingStatsSource - -import Simulation.Aivika.Specs -import Simulation.Aivika.Simulation -import Simulation.Aivika.Event -import Simulation.Aivika.Signal -import Simulation.Aivika.Statistics +import Simulation.Aivika.Experiment.MRef -- | Defines the 'View' that gathers the statistics -- in the final time points. @@ -47,38 +42,41 @@ finalStatsPredicate :: Event Bool, -- ^ It specifies the predicate that defines -- when we count data when gathering the statistics. - finalStatsSeries :: [String] - -- ^ It contains the labels of data for which - -- the statistics is collected. + 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 = "The statistical data are gathered in the final time points for all runs.", + finalStatsDescription = "Statistics is gathered in final time points for all runs.", finalStatsWriter = defaultSamplingStatsWriter, finalStatsPredicate = return True, - finalStatsSeries = [] } + finalStatsTransform = id, + finalStatsSeries = id } -instance ExperimentView FinalStatsView r where +instance WebPageRendering r => ExperimentView FinalStatsView r WebPageWriter where outputView v = let reporter exp renderer dir = do st <- newFinalStats v exp dir + let writer = + WebPageWriter { reporterWriteTOCHtml = finalStatsTOCHtml st, + reporterWriteHtml = finalStatsHtml st } return ExperimentReporter { reporterInitialise = return (), reporterFinalise = return (), reporterSimulate = simulateFinalStats st, - reporterTOCHtml = finalStatsTOCHtml st, - reporterHtml = finalStatsHtml st } + reporterRequest = writer } in ExperimentGenerator { generateReporter = reporter } -- | The state of the view. -data FinalStatsViewState r = +data FinalStatsViewState = FinalStatsViewState { finalStatsView :: FinalStatsView, - finalStatsExperiment :: Experiment r, - finalStatsLock :: MVar (), - finalStatsResults :: IORef (Maybe FinalStatsResults) } + finalStatsExperiment :: Experiment, + finalStatsResults :: MRef (Maybe FinalStatsResults) } -- | The statistics results. data FinalStatsResults = @@ -86,68 +84,57 @@ finalStatsValues :: [IORef (SamplingStats Double)] } -- | Create a new state of the view. -newFinalStats :: FinalStatsView -> Experiment r -> FilePath -> IO (FinalStatsViewState r) +newFinalStats :: FinalStatsView -> Experiment -> FilePath -> IO FinalStatsViewState newFinalStats view exp dir = - do l <- newMVar () - r <- newIORef Nothing + do r <- newMRef Nothing return FinalStatsViewState { finalStatsView = view, finalStatsExperiment = exp, - finalStatsLock = l, finalStatsResults = r } -- | Create new statistics results. -newFinalStatsResults :: [String] -> Experiment r -> IO FinalStatsResults +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 results --- | Simulation the specified series. -simulateFinalStats :: FinalStatsViewState r -> ExperimentData -> Event (Event ()) +-- | Simulate the specified series. +simulateFinalStats :: FinalStatsViewState -> ExperimentData -> Event DisposableEvent simulateFinalStats st expdata = - do let protolabels = finalStatsSeries $ finalStatsView st - protoproviders = flip map protolabels $ \protolabel -> - experimentSeriesProviders expdata [protolabel] - providers = concat protoproviders - input = - flip map providers $ \provider -> - case providerToDoubleStatsSource provider of - Nothing -> error $ - "Cannot represent series " ++ - providerName provider ++ - " as a source of double values: simulateFinalStats" - Just input -> samplingStatsSourceData input - names = map providerName providers - predicate = finalStatsPredicate $ finalStatsView st - exp = finalStatsExperiment st - lock = finalStatsLock st - results <- liftIO $ readIORef (finalStatsResults st) - case results of - Nothing -> - liftIO $ - do results <- newFinalStatsResults names exp - writeIORef (finalStatsResults st) $ Just results - Just results -> - when (names /= finalStatsNames results) $ - error "Series with different names are returned for different runs: simulateFinalStats" - results <- liftIO $ fmap fromJust $ readIORef (finalStatsResults st) - let values = finalStatsValues results - h = filterSignalM (const predicate) $ - experimentSignalInStopTime expdata - handleSignal_ h $ \_ -> - do xs <- sequence input - liftIO $ withMVar lock $ \() -> - forM_ (zip xs values) $ \(x, values) -> - do y <- readIORef values - let y' = addDataToSamplingStats x y - y' `seq` writeIORef values y' - return $ return () + do let view = finalStatsView st + rs = finalStatsSeries view $ + finalStatsTransform view $ + experimentResults expdata + exts = extractDoubleStatsEitherResults rs + signals = experimentPredefinedSignals expdata + signal = filterSignalM (const predicate) $ + resultSignalInStopTime signals + names = map resultExtractName exts + predicate = finalStatsPredicate view + results <- liftIO $ requireFinalStatsResults st names + let values = finalStatsValues results + handleSignal signal $ \_ -> + forM_ (zip exts values) $ \(ext, value) -> + do x <- resultExtractData ext + liftIO $ + do y <- readIORef value + let y' = combineSamplingStatsEither x y + y' `seq` writeIORef value y' -- | Get the HTML code. -finalStatsHtml :: FinalStatsViewState r -> Int -> HtmlWriter () +finalStatsHtml :: FinalStatsViewState -> Int -> HtmlWriter () finalStatsHtml st index = do header st index - results <- liftIO $ readIORef (finalStatsResults st) + results <- liftIO $ readMRef (finalStatsResults st) case results of Nothing -> return () Just results -> @@ -159,7 +146,7 @@ do stats <- liftIO $ readIORef value write writer name stats -header :: FinalStatsViewState r -> Int -> HtmlWriter () +header :: FinalStatsViewState -> Int -> HtmlWriter () header st index = do writeHtmlHeader3WithId ("id" ++ show index) $ writeHtmlText (finalStatsTitle $ finalStatsView st) @@ -169,7 +156,7 @@ writeHtmlText description -- | Get the TOC item. -finalStatsTOCHtml :: FinalStatsViewState r -> Int -> HtmlWriter () +finalStatsTOCHtml :: FinalStatsViewState -> Int -> HtmlWriter () finalStatsTOCHtml st index = writeHtmlListItem $ writeHtmlLink ("#id" ++ show index) $ diff --git a/Simulation/Aivika/Experiment/FinalTableView.hs b/Simulation/Aivika/Experiment/FinalTableView.hs --- a/Simulation/Aivika/Experiment/FinalTableView.hs +++ b/Simulation/Aivika/Experiment/FinalTableView.hs @@ -3,11 +3,11 @@ -- | -- Module : Simulation.Aivika.Experiment.FinalTableView --- Copyright : Copyright (c) 2012, David Sorokin +-- Copyright : Copyright (c) 2012-2014, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental --- Tested with: GHC 7.4.1 +-- Tested with: GHC 7.8.3 -- -- The module defines 'FinalTableView' that saves the simulation -- results in the final time points for all simulation runs in @@ -29,15 +29,10 @@ import System.IO import System.FilePath +import Simulation.Aivika import Simulation.Aivika.Experiment.Types -import Simulation.Aivika.Experiment.FileRenderer import Simulation.Aivika.Experiment.HtmlWriter - -import Simulation.Aivika.Specs -import Simulation.Aivika.Parameter -import Simulation.Aivika.Simulation -import Simulation.Aivika.Event -import Simulation.Aivika.Signal +import Simulation.Aivika.Experiment.MRef -- | Defines the 'View' that saves the simulation -- results in the final time points for all @@ -79,9 +74,10 @@ finalTablePredicate :: Event Bool, -- ^ It specifies the predicate that defines -- when we can save data in the table. - finalTableSeries :: [String] - -- ^ It contains the labels of data saved - -- in the CSV file. + 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. @@ -95,105 +91,98 @@ finalTableSeparator = ",", finalTableFormatter = id, finalTablePredicate = return True, - finalTableSeries = [] } + finalTableTransform = expandResults, + finalTableSeries = id } -instance FileRenderer r => ExperimentView FinalTableView r where +instance WebPageRendering r => ExperimentView FinalTableView r WebPageWriter where outputView v = let reporter exp renderer dir = do st <- newFinalTable v exp dir + let writer = + WebPageWriter { reporterWriteTOCHtml = finalTableTOCHtml st, + reporterWriteHtml = finalTableHtml st } return ExperimentReporter { reporterInitialise = return (), reporterFinalise = finaliseFinalTable st, reporterSimulate = simulateFinalTable st, - reporterTOCHtml = finalTableTOCHtml st, - reporterHtml = finalTableHtml st } + reporterRequest = writer } in ExperimentGenerator { generateReporter = reporter } -- | The state of the view. -data FinalTableViewState r = +data FinalTableViewState = FinalTableViewState { finalTableView :: FinalTableView, - finalTableExperiment :: Experiment r, + finalTableExperiment :: Experiment, finalTableDir :: FilePath, finalTableFile :: IORef (Maybe FilePath), - finalTableLock :: MVar (), - finalTableResults :: IORef (Maybe FinalTableResults) } + finalTableResults :: MRef (Maybe FinalTableResults) } -- | The table results. data FinalTableResults = FinalTableResults { finalTableNames :: [String], - finalTableValues :: IORef (M.Map Int [String]) } + finalTableValues :: MRef (M.Map Int [String]) } -- | Create a new state of the view. -newFinalTable :: FinalTableView -> Experiment r -> FilePath -> IO (FinalTableViewState r) +newFinalTable :: FinalTableView -> Experiment -> FilePath -> IO FinalTableViewState newFinalTable view exp dir = do f <- newIORef Nothing - l <- newMVar () - r <- newIORef Nothing + r <- newMRef Nothing return FinalTableViewState { finalTableView = view, finalTableExperiment = exp, finalTableDir = dir, finalTableFile = f, - finalTableLock = l, finalTableResults = r } -- | Create new table results. -newFinalTableResults :: [String] -> Experiment r -> IO FinalTableResults +newFinalTableResults :: [String] -> Experiment -> IO FinalTableResults newFinalTableResults names exp = - do values <- newIORef M.empty + 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 results -- | Simulation of the specified series. -simulateFinalTable :: FinalTableViewState r -> ExperimentData -> Event (Event ()) +simulateFinalTable :: FinalTableViewState -> ExperimentData -> Event DisposableEvent simulateFinalTable st expdata = - do let labels = finalTableSeries $ finalTableView st - providers = experimentSeriesProviders expdata labels - input = - flip map providers $ \provider -> - case providerToString provider of - Nothing -> error $ - "Cannot represent series " ++ - providerName provider ++ - " as string values: simulateFinalTable" - Just input -> input - names = map providerName providers - predicate = finalTablePredicate $ finalTableView st - exp = finalTableExperiment st - lock = finalTableLock st - results <- liftIO $ readIORef (finalTableResults st) - case results of - Nothing -> - liftIO $ - do results <- newFinalTableResults names exp - writeIORef (finalTableResults st) $ Just results - Just results -> - when (names /= finalTableNames results) $ - error "Series with different names are returned for different runs: simulateFinalTable" - results <- liftIO $ fmap fromJust $ readIORef (finalTableResults st) - let values = finalTableValues results - h = filterSignalM (const predicate) $ - experimentSignalInStopTime expdata - handleSignal_ h $ \_ -> - do xs <- sequence input + do let view = finalTableView st + rs = finalTableSeries view $ + finalTableTransform view $ + experimentResults expdata + exts = extractStringResults rs + signals = experimentPredefinedSignals expdata + signal = filterSignalM (const predicate) $ + resultSignalInStopTime signals + names = map resultExtractName exts + predicate = finalTablePredicate view + results <- liftIO $ requireFinalTableResults st names + let values = finalTableValues results + handleSignal signal $ \_ -> + do xs <- mapM resultExtractData exts i <- liftParameter simulationIndex - liftIO $ withMVar lock $ \() -> - modifyIORef values $ M.insert i xs - return $ return () + liftIO $ modifyMRef values $ M.insert i xs -- | Save the results in the CSV file after the simulation is complete. -finaliseFinalTable :: FinalTableViewState r -> IO () +finaliseFinalTable :: FinalTableViewState -> IO () finaliseFinalTable st = - do let run = finalTableRunText $ finalTableView st - formatter = finalTableFormatter $ finalTableView st - title = finalTableTitle $ finalTableView st - separator = finalTableSeparator $ finalTableView st - results <- readIORef $ finalTableResults st + do let view = finalTableView st + run = finalTableRunText view + formatter = finalTableFormatter view + title = finalTableTitle view + separator = finalTableSeparator view + results <- readMRef $ finalTableResults st case results of Nothing -> return () Just results -> do let names = finalTableNames results values = finalTableValues results - m <- readIORef values + m <- readMRef values file <- resolveFilePath (finalTableDir st) $ mapFilePath (flip replaceExtension ".csv") $ expandFilePath (finalTableFileName $ finalTableView st) $ @@ -220,7 +209,7 @@ writeIORef (finalTableFile st) $ Just file -- | Get the HTML code. -finalTableHtml :: FinalTableViewState r -> Int -> HtmlWriter () +finalTableHtml :: FinalTableViewState -> Int -> HtmlWriter () finalTableHtml st index = do header st index file <- liftIO $ readIORef (finalTableFile st) @@ -231,7 +220,7 @@ writeHtmlLink (makeRelative (finalTableDir st) f) $ writeHtmlText (finalTableLinkText $ finalTableView st) -header :: FinalTableViewState r -> Int -> HtmlWriter () +header :: FinalTableViewState -> Int -> HtmlWriter () header st index = do writeHtmlHeader3WithId ("id" ++ show index) $ writeHtmlText (finalTableTitle $ finalTableView st) @@ -241,7 +230,7 @@ writeHtmlText description -- | Get the TOC item. -finalTableTOCHtml :: FinalTableViewState r -> Int -> HtmlWriter () +finalTableTOCHtml :: FinalTableViewState -> Int -> HtmlWriter () finalTableTOCHtml st index = writeHtmlListItem $ writeHtmlLink ("#id" ++ show index) $ 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,4 +1,12 @@ +-- | +-- Module : Simulation.Aivika.Experiment.Histogram +-- Copyright : Copyright (c) 2012-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.6.3 +-- -- | 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 --- a/Simulation/Aivika/Experiment/HtmlWriter.hs +++ b/Simulation/Aivika/Experiment/HtmlWriter.hs @@ -1,11 +1,11 @@ -- | -- Module : Simulation.Aivika.Experiment.HtmlWriter --- Copyright : Copyright (c) 2012, David Sorokin +-- Copyright : Copyright (c) 2012-2014, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental --- Tested with: GHC 7.4.1 +-- Tested with: GHC 7.8.3 -- -- This is an utility module that provides an HTML writer. -- @@ -41,6 +41,7 @@ import Control.Monad import Control.Monad.Trans +import Control.Applicative import Network.URI @@ -64,6 +65,15 @@ liftIO m = HtmlWriter $ \f -> do x <- 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 () diff --git a/Simulation/Aivika/Experiment/LastValueView.hs b/Simulation/Aivika/Experiment/LastValueView.hs --- a/Simulation/Aivika/Experiment/LastValueView.hs +++ b/Simulation/Aivika/Experiment/LastValueView.hs @@ -3,11 +3,11 @@ -- | -- Module : Simulation.Aivika.Experiment.LastValueView --- Copyright : Copyright (c) 2012, David Sorokin +-- Copyright : Copyright (c) 2012-2014, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental --- Tested with: GHC 7.4.1 +-- Tested with: GHC 7.8.3 -- -- The module defines 'LastValueView' that shows the last values -- for the simulation variables. @@ -24,16 +24,11 @@ import Data.IORef import Data.Maybe +import Simulation.Aivika import Simulation.Aivika.Experiment.Types import Simulation.Aivika.Experiment.HtmlWriter import Simulation.Aivika.Experiment.Utils (replace) -import Simulation.Aivika.Specs -import Simulation.Aivika.Parameter -import Simulation.Aivika.Simulation -import Simulation.Aivika.Event -import Simulation.Aivika.Signal - -- | Defines the 'View' that shows the last values of the simulation -- variables. data LastValueView = @@ -53,8 +48,10 @@ -- ^ The description for the view. lastValueFormatter :: ShowS, -- ^ It transforms data before they will be shown. - lastValueSeries :: [String] - -- ^ It contains the labels of the observed series. + 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. @@ -62,30 +59,33 @@ defaultLastValueView = LastValueView { lastValueTitle = "The Last Values", lastValueRunTitle = "$TITLE / Run $RUN_INDEX of $RUN_COUNT", - lastValueDescription = "It shows the values in the final time points.", + lastValueDescription = "It shows the values in the final time point(s).", lastValueFormatter = id, - lastValueSeries = [] } + lastValueTransform = id, + lastValueSeries = id } -instance ExperimentView LastValueView r where +instance WebPageRendering r => ExperimentView LastValueView r WebPageWriter where outputView v = let reporter exp renderer dir = do st <- newLastValues v exp + let writer = + WebPageWriter { reporterWriteTOCHtml = lastValueTOCHtml st, + reporterWriteHtml = lastValueHtml st } return ExperimentReporter { reporterInitialise = return (), reporterFinalise = return (), reporterSimulate = simulateLastValues st, - reporterTOCHtml = lastValueTOCHtml st, - reporterHtml = lastValueHtml st } + reporterRequest = writer } in ExperimentGenerator { generateReporter = reporter } - + -- | The state of the view. -data LastValueViewState r = +data LastValueViewState = LastValueViewState { lastValueView :: LastValueView, - lastValueExperiment :: Experiment r, + lastValueExperiment :: Experiment, lastValueMap :: M.Map Int (IORef [(String, String)]) } -- | Create a new state of the view. -newLastValues :: LastValueView -> Experiment r -> IO (LastValueViewState r) +newLastValues :: LastValueView -> Experiment -> IO LastValueViewState newLastValues view exp = do let n = experimentRunCount exp rs <- forM [0..(n - 1)] $ \i -> newIORef [] @@ -95,28 +95,25 @@ lastValueMap = m } -- | Get the last values during the simulation. -simulateLastValues :: LastValueViewState r -> ExperimentData -> Event (Event ()) +simulateLastValues :: LastValueViewState -> ExperimentData -> Event DisposableEvent simulateLastValues st expdata = - do let labels = lastValueSeries $ lastValueView st - input = - flip map (experimentSeriesProviders expdata labels) $ \provider -> - case providerToString provider of - Nothing -> error $ - "Cannot represent series " ++ - providerName provider ++ - " as a string: simulateLastValues" - Just input -> (providerName provider, input) + do let view = lastValueView st + rs = lastValueSeries view $ + lastValueTransform view $ + experimentResults expdata + exts = extractStringResults rs + signals = experimentPredefinedSignals expdata + signal = resultSignalInStopTime signals i <- liftParameter simulationIndex - handleSignal_ (experimentSignalInStopTime expdata) $ \t -> + handleSignal signal $ \t -> do let r = fromJust $ M.lookup (i - 1) (lastValueMap st) - output <- forM input $ \(name, input) -> - do x <- input - return (name, x) + output <- forM exts $ \ext -> + do x <- resultExtractData ext + return (resultExtractName ext, x) liftIO $ writeIORef r output - return $ return () -- | Get the HTML code. -lastValueHtml :: LastValueViewState r -> Int -> HtmlWriter () +lastValueHtml :: LastValueViewState -> Int -> HtmlWriter () lastValueHtml st index = let n = experimentRunCount $ lastValueExperiment st in if n == 1 @@ -124,7 +121,7 @@ else lastValueHtmlMultiple st index -- | Get the HTML code for a single run. -lastValueHtmlSingle :: LastValueViewState r -> Int -> HtmlWriter () +lastValueHtmlSingle :: LastValueViewState -> Int -> HtmlWriter () lastValueHtmlSingle st index = do header st index let r = fromJust $ M.lookup 0 (lastValueMap st) @@ -133,7 +130,7 @@ formatPair pair (lastValueFormatter $ lastValueView st) -- | Get the HTML code for multiple runs -lastValueHtmlMultiple :: LastValueViewState r -> Int -> HtmlWriter () +lastValueHtmlMultiple :: LastValueViewState -> Int -> HtmlWriter () lastValueHtmlMultiple st index = do header st index let n = experimentRunCount $ lastValueExperiment st @@ -150,7 +147,7 @@ forM_ pairs $ \pair -> formatPair pair (lastValueFormatter $ lastValueView st) -header :: LastValueViewState r -> Int -> HtmlWriter () +header :: LastValueViewState -> Int -> HtmlWriter () header st index = do writeHtmlHeader3WithId ("id" ++ show index) $ writeHtmlText (lastValueTitle $ lastValueView st) @@ -167,7 +164,7 @@ writeHtmlText $ formatter value -- | Get the TOC item -lastValueTOCHtml :: LastValueViewState r -> Int -> HtmlWriter () +lastValueTOCHtml :: LastValueViewState -> Int -> HtmlWriter () lastValueTOCHtml st index = writeHtmlListItem $ writeHtmlLink ("#id" ++ show index) $ diff --git a/Simulation/Aivika/Experiment/ListSource.hs b/Simulation/Aivika/Experiment/ListSource.hs deleted file mode 100644 --- a/Simulation/Aivika/Experiment/ListSource.hs +++ /dev/null @@ -1,88 +0,0 @@ - --- | --- Module : Simulation.Aivika.Experiment.ListSource --- Copyright : Copyright (c) 2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.6.3 --- --- It represents an optimized source of data to construct the list. --- - -module Simulation.Aivika.Experiment.ListSource - (ListSource, - providerToDoubleListSource, - providerToIntListSource, - ListData, - listSourceData, - listDataList, - ListRef, - newListRef, - addDataToListRef, - readListRef) where - -import Data.IORef -import Control.Monad - -import Simulation.Aivika.Event -import Simulation.Aivika.Statistics -import Simulation.Aivika.Experiment.Types - --- | Represents the optimized source of data for constructing the list. -data ListSource a = SingleValueSource (Event a) - | MultipleValueSource (Event [a]) - --- | Represents the optimized data by which the list will be created. -data ListData a = SingleValueData !a - | MultipleValueData [a] - --- | Try to return the source of list data by the specified provider. -providerToDoubleListSource :: SeriesProvider -> Maybe (ListSource Double) -providerToDoubleListSource provider = - case providerToDouble provider of - Just x -> Just $ SingleValueSource x - Nothing -> - case providerToDoubleList provider of - Just x -> Just $ MultipleValueSource x - Nothing -> Nothing - --- | Try to return the source of list data by the specified provider. -providerToIntListSource :: SeriesProvider -> Maybe (ListSource Int) -providerToIntListSource provider = - case providerToInt provider of - Just x -> Just $ SingleValueSource x - Nothing -> - case providerToIntList provider of - Just x -> Just $ MultipleValueSource x - Nothing -> Nothing - --- | Get data from the source in the current time point. -listSourceData :: ListSource a -> Event (ListData a) -listSourceData (SingleValueSource x) = x >>= return . SingleValueData -listSourceData (MultipleValueSource xs) = - do ys <- xs - zs <- forM ys $ \y -> return $ y `seq` y - return $ MultipleValueData ys -- it contains strict data, which is important for big models - --- | Return the list of values contained in the specified data. -listDataList :: ListData a -> [a] -listDataList (SingleValueData x) = [x] -listDataList (MultipleValueData xs) = xs - --- | Represents a reference to the list, optimized to work with the source of data. -newtype ListRef a = ListRef { listRef :: IORef [ListData a] } - --- | Create a new list reference. -newListRef :: IO (ListRef a) -newListRef = fmap ListRef $ newIORef [] - --- | Add data to the list reference. -addDataToListRef :: ListRef a -> ListData a -> IO () -addDataToListRef (ListRef r) a = modifyIORef r (a :) - --- | Read the list contained in the reference. -readListRef :: ListRef a -> IO [a] -readListRef (ListRef r) = - do x <- readIORef r - return $ concat $ map listDataList x diff --git a/Simulation/Aivika/Experiment/MRef.hs b/Simulation/Aivika/Experiment/MRef.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Experiment/MRef.hs @@ -0,0 +1,88 @@ + +-- | +-- Module : Simulation.Aivika.Experiment.MRef +-- Copyright : Copyright (c) 2012-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.8.3 +-- +-- The module defines a shared mutable reference accessible from different threads. +-- + +module Simulation.Aivika.Experiment.MRef + (MRef, + newMRef, + readMRef, + maybeReadMRef, + writeMRef, + maybeWriteMRef, + modifyMRef) 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 -> b) -> MRef (Maybe a) -> IO b +maybeReadMRef b0 f x = + do a <- readIORef (mrefData x) + case a of + Just a -> return (f a) + Nothing -> + withMVar (mrefLock x) $ \() -> + do a <- readIORef (mrefData x) + case a of + Just a -> return (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 -> b) -> IO b +maybeWriteMRef x m0 f = + do a <- readIORef (mrefData x) + case a of + Just a -> return (f a) + Nothing -> + withMVar (mrefLock x) $ \() -> + do a <- readIORef (mrefData x) + case a of + Just a -> return (f a) + Nothing -> + do a0 <- m0 + writeIORef (mrefData x) (Just a0) + return (f a0) + +-- | Modify the contents of the shared reference. +modifyMRef :: MRef a -> (a -> a) -> IO () +modifyMRef x f = + withMVar (mrefLock x) $ \() -> + modifyIORef (mrefData x) f diff --git a/Simulation/Aivika/Experiment/SamplingStatsSource.hs b/Simulation/Aivika/Experiment/SamplingStatsSource.hs deleted file mode 100644 --- a/Simulation/Aivika/Experiment/SamplingStatsSource.hs +++ /dev/null @@ -1,68 +0,0 @@ - --- | --- Module : Simulation.Aivika.Experiment.SamplingStatsSource --- Copyright : Copyright (c) 2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.6.3 --- --- It represents an optimized source of statistical data. --- - -module Simulation.Aivika.Experiment.SamplingStatsSource - (SamplingStatsSource, - providerToDoubleStatsSource, - providerToIntStatsSource, - SamplingStatsData, - samplingStatsSourceData, - addDataToSamplingStats) where - -import Simulation.Aivika.Event -import Simulation.Aivika.Statistics -import Simulation.Aivika.Experiment.Types - --- | Represents the optimized source of data for the statistics. -data SamplingStatsSource a = SingleValueSource (Event a) - | MultipleValueSource (Event (SamplingStats a)) - --- | Represents the optimized data to be included in the statistics. -data SamplingStatsData a = SingleValueData !a - | MultipleValueData (SamplingStats a) - --- | Try to return the source of statistical data by the specified provider. -providerToDoubleStatsSource :: SeriesProvider -> Maybe (SamplingStatsSource Double) -providerToDoubleStatsSource provider = - case providerToDouble provider of - Just x -> Just $ SingleValueSource x - Nothing -> - case providerToDoubleStats provider of - Just x -> Just $ MultipleValueSource x - Nothing -> Nothing - --- | Try to return the source of statistical data. -providerToIntStatsSource :: SeriesProvider -> Maybe (SamplingStatsSource Int) -providerToIntStatsSource provider = - case providerToInt provider of - Just x -> Just $ SingleValueSource x - Nothing -> - case providerToIntStats provider of - Just x -> Just $ MultipleValueSource x - Nothing -> Nothing - --- | Get data from the source in the current time point. -samplingStatsSourceData :: SamplingStatsSource a -> Event (SamplingStatsData a) -samplingStatsSourceData source = - case source of - SingleValueSource x -> x >>= return . SingleValueData - MultipleValueSource x -> x >>= return . MultipleValueData - --- | Add data from the source to the statistics. -addDataToSamplingStats :: SamplingData a - => SamplingStatsData a - -> SamplingStats a - -> SamplingStats a -addDataToSamplingStats d stats = - case d of - SingleValueData x -> addSamplingStats x stats - MultipleValueData x -> combineSamplingStats x stats diff --git a/Simulation/Aivika/Experiment/SamplingStatsWriter.hs b/Simulation/Aivika/Experiment/SamplingStatsWriter.hs --- a/Simulation/Aivika/Experiment/SamplingStatsWriter.hs +++ b/Simulation/Aivika/Experiment/SamplingStatsWriter.hs @@ -1,11 +1,11 @@ -- | -- Module : Simulation.Aivika.Experiment.SamplingStatsWriter --- Copyright : Copyright (c) 2012, David Sorokin +-- Copyright : Copyright (c) 2012-2014, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental --- Tested with: GHC 7.4.1 +-- Tested with: GHC 7.6.3 -- -- The module defines 'SamplingStatsWriter' that knows how to write -- the sampling statistics in HTML. diff --git a/Simulation/Aivika/Experiment/TableView.hs b/Simulation/Aivika/Experiment/TableView.hs --- a/Simulation/Aivika/Experiment/TableView.hs +++ b/Simulation/Aivika/Experiment/TableView.hs @@ -3,11 +3,11 @@ -- | -- Module : Simulation.Aivika.Experiment.TableView --- Copyright : Copyright (c) 2012, David Sorokin +-- Copyright : Copyright (c) 2012-2014, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental --- Tested with: GHC 7.4.1 +-- Tested with: GHC 7.8.3 -- -- The module defines 'TableView' that saves the simulation -- results in the CSV file(s). @@ -23,21 +23,16 @@ 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.FileRenderer import Simulation.Aivika.Experiment.HtmlWriter import Simulation.Aivika.Experiment.Utils (replace) -import Simulation.Aivika.Specs -import Simulation.Aivika.Parameter -import Simulation.Aivika.Simulation -import Simulation.Aivika.Event -import Simulation.Aivika.Signal - -- | Defines the 'View' that saves the simulation results -- in the CSV file(s). data TableView = @@ -97,9 +92,10 @@ tablePredicate :: Event Bool, -- ^ It specifies the predicate that defines -- when we can save data in the table. - tableSeries :: [String] - -- ^ It contains the labels of data saved - -- in the CSV file(s). + 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. @@ -113,29 +109,32 @@ tableSeparator = ",", tableFormatter = id, tablePredicate = return True, - tableSeries = [] } + tableTransform = expandResults, + tableSeries = id } -instance FileRenderer r => ExperimentView TableView r where +instance WebPageRendering r => ExperimentView TableView r WebPageWriter where outputView v = let reporter exp renderer dir = do st <- newTable v exp dir + let writer = + WebPageWriter { reporterWriteTOCHtml = tableTOCHtml st, + reporterWriteHtml = tableHtml st } return ExperimentReporter { reporterInitialise = return (), reporterFinalise = return (), reporterSimulate = simulateTable st, - reporterTOCHtml = tableTOCHtml st, - reporterHtml = tableHtml st } + reporterRequest = writer } in ExperimentGenerator { generateReporter = reporter } -- | The state of the view. -data TableViewState r = +data TableViewState = TableViewState { tableView :: TableView, - tableExperiment :: Experiment r, + tableExperiment :: Experiment, tableDir :: FilePath, tableMap :: M.Map Int FilePath } -- | Create a new state of the view. -newTable :: TableView -> Experiment r -> FilePath -> IO (TableViewState r) +newTable :: TableView -> Experiment -> FilePath -> IO TableViewState newTable view exp dir = do let n = experimentRunCount exp fs <- forM [0..(n - 1)] $ \i -> @@ -153,50 +152,50 @@ tableMap = m } -- | Write the tables during the simulation. -simulateTable :: TableViewState r -> ExperimentData -> Event (Event ()) +simulateTable :: TableViewState -> ExperimentData -> Event DisposableEvent simulateTable st expdata = - do let labels = tableSeries $ tableView st - providers = experimentSeriesProviders expdata labels - input = - flip map providers $ \provider -> - case providerToString provider of - Nothing -> error $ - "Cannot represent series " ++ - providerName provider ++ - " as a string: simulateTable" - Just input -> input - separator = tableSeparator $ tableView st - formatter = tableFormatter $ tableView st - predicate = tablePredicate $ tableView st + do let view = tableView st + rs = tableSeries view $ + tableTransform view $ + experimentResults expdata + exts = extractStringResults 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..] providers) $ \(column, provider) -> + do forM_ (zip [0..] exts) $ \(column, ext) -> do when (column > 0) $ hPutStr h separator - hPutStr h $ show $ providerName provider + hPutStr h $ show $ resultExtractName ext hPutStrLn h "" - handleSignal_ (experimentMixedSignal expdata providers) $ \t -> + d1 <- handleSignal signal $ \t -> do p <- predicate when p $ - do forM_ (zip [0..] input) $ \(column, input) -> -- write the row - do x <- input -- write the column + do forM_ (zip [0..] exts) $ \(column, ext) -> -- write the row + do x <- resultExtractData ext -- write the column liftIO $ do when (column > 0) $ hPutStr h separator hPutStr h $ formatter x liftIO $ hPutStrLn h "" - return $ - liftIO $ - do when (experimentVerbose $ tableExperiment st) $ - putStr "Generated file " >> putStrLn f - hClose h -- close the file + 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 r -> Int -> HtmlWriter () +tableHtml :: TableViewState -> Int -> HtmlWriter () tableHtml st index = let n = experimentRunCount $ tableExperiment st in if n == 1 @@ -204,7 +203,7 @@ else tableHtmlMultiple st index -- | Get the HTML code for a single run. -tableHtmlSingle :: TableViewState r -> Int -> HtmlWriter () +tableHtmlSingle :: TableViewState -> Int -> HtmlWriter () tableHtmlSingle st index = do header st index let f = fromJust $ M.lookup 0 (tableMap st) @@ -213,7 +212,7 @@ writeHtmlText (tableLinkText $ tableView st) -- | Get the HTML code for multiple runs -tableHtmlMultiple :: TableViewState r -> Int -> HtmlWriter () +tableHtmlMultiple :: TableViewState -> Int -> HtmlWriter () tableHtmlMultiple st index = do header st index let n = experimentRunCount $ tableExperiment st @@ -228,7 +227,7 @@ writeHtmlLink (makeRelative (tableDir st) f) $ writeHtmlText sublink -header :: TableViewState r -> Int -> HtmlWriter () +header :: TableViewState -> Int -> HtmlWriter () header st index = do writeHtmlHeader3WithId ("id" ++ show index) $ writeHtmlText (tableTitle $ tableView st) @@ -238,7 +237,7 @@ writeHtmlText description -- | Get the TOC item -tableTOCHtml :: TableViewState r -> Int -> HtmlWriter () +tableTOCHtml :: TableViewState -> Int -> HtmlWriter () tableTOCHtml st index = writeHtmlListItem $ writeHtmlLink ("#id" ++ show index) $ diff --git a/Simulation/Aivika/Experiment/TimingStatsView.hs b/Simulation/Aivika/Experiment/TimingStatsView.hs --- a/Simulation/Aivika/Experiment/TimingStatsView.hs +++ b/Simulation/Aivika/Experiment/TimingStatsView.hs @@ -3,11 +3,11 @@ -- | -- Module : Simulation.Aivika.Experiment.TimingStatsView --- Copyright : Copyright (c) 2012, David Sorokin +-- Copyright : Copyright (c) 2012-2014, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental --- Tested with: GHC 7.4.1 +-- Tested with: GHC 7.8.3 -- -- The module defines 'TimingStatsView' that shows the timing statistics -- for the variables for every simulation run separately. @@ -23,20 +23,14 @@ 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.HtmlWriter import Simulation.Aivika.Experiment.TimingStatsWriter import Simulation.Aivika.Experiment.Utils (replace) -import Simulation.Aivika.Specs -import Simulation.Aivika.Parameter -import Simulation.Aivika.Simulation -import Simulation.Aivika.Dynamics -import Simulation.Aivika.Event -import Simulation.Aivika.Signal -import Simulation.Aivika.Statistics - -- | Defines the 'View' that shows the timing statistics -- for variables for every simulation run separately. data TimingStatsView = @@ -58,8 +52,10 @@ -- ^ It shows the timing statistics. timingStatsPredicate :: Event Bool, -- ^ Specifies when gathering the statistics. - timingStatsSeries :: [String] - -- ^ It contains the labels of the observed series. + 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. @@ -70,28 +66,31 @@ timingStatsDescription = "The statistical data are gathered in the time points.", timingStatsWriter = defaultTimingStatsWriter, timingStatsPredicate = return True, - timingStatsSeries = [] } + timingStatsTransform = id, + timingStatsSeries = id } -instance ExperimentView TimingStatsView r where +instance WebPageRendering r => ExperimentView TimingStatsView r WebPageWriter where outputView v = let reporter exp renderer dir = do st <- newTimingStats v exp + let writer = + WebPageWriter { reporterWriteTOCHtml = timingStatsTOCHtml st, + reporterWriteHtml = timingStatsHtml st } return ExperimentReporter { reporterInitialise = return (), reporterFinalise = return (), reporterSimulate = simulateTimingStats st, - reporterTOCHtml = timingStatsTOCHtml st, - reporterHtml = timingStatsHtml st } + reporterRequest = writer } in ExperimentGenerator { generateReporter = reporter } -- | The state of the view. -data TimingStatsViewState r = +data TimingStatsViewState = TimingStatsViewState { timingStatsView :: TimingStatsView, - timingStatsExperiment :: Experiment r, + timingStatsExperiment :: Experiment, timingStatsMap :: M.Map Int (IORef [(String, IORef (TimingStats Double))]) } -- | Create a new state of the view. -newTimingStats :: TimingStatsView -> Experiment r -> IO (TimingStatsViewState r) +newTimingStats :: TimingStatsView -> Experiment -> IO TimingStatsViewState newTimingStats view exp = do let n = experimentRunCount exp rs <- forM [0..(n - 1)] $ \i -> newIORef [] @@ -101,40 +100,35 @@ timingStatsMap = m } -- | Get the timing statistics during the simulation. -simulateTimingStats :: TimingStatsViewState r -> ExperimentData -> Event (Event ()) +simulateTimingStats :: TimingStatsViewState -> ExperimentData -> Event DisposableEvent simulateTimingStats st expdata = - do let labels = timingStatsSeries $ timingStatsView st - input providers = - flip map providers $ \provider -> - case providerToDouble provider of - Nothing -> error $ - "Cannot represent series " ++ - providerName provider ++ - " as double values: simulateTimingStats" - Just input -> (provider, input) - predicate = timingStatsPredicate $ timingStatsView st + do let view = timingStatsView st + rs = timingStatsSeries view $ + timingStatsTransform view $ + experimentResults expdata + exts = extractDoubleResults 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_ labels $ \label -> - do let providers = experimentSeriesProviders expdata [label] - pairs = input providers - forM_ pairs $ \(provider, input) -> - do stats <- liftIO $ newIORef emptyTimingStats - let name = providerName provider - liftIO $ modifyIORef r ((:) (name, stats)) - let h = filterSignalM (const predicate) $ - experimentMixedSignal expdata [provider] - handleSignal_ h $ \_ -> - do t <- liftDynamics time - x <- input - liftIO $ - do y <- readIORef stats - let y' = addTimingStats t x y - y' `seq` writeIORef stats y' - return $ return () + ds <- forM exts $ \ext -> + do stats <- liftIO $ newIORef emptyTimingStats + let name = resultExtractName ext + liftIO $ modifyIORef r ((:) (name, stats)) + handleSignal signal $ \_ -> + do t <- liftDynamics time + x <- resultExtractData 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 r -> Int -> HtmlWriter () +timingStatsHtml :: TimingStatsViewState -> Int -> HtmlWriter () timingStatsHtml st index = let n = experimentRunCount $ timingStatsExperiment st in if n == 1 @@ -142,7 +136,7 @@ else timingStatsHtmlMultiple st index -- | Get the HTML code for a single run. -timingStatsHtmlSingle :: TimingStatsViewState r -> Int -> HtmlWriter () +timingStatsHtmlSingle :: TimingStatsViewState -> Int -> HtmlWriter () timingStatsHtmlSingle st index = do header st index let r = fromJust $ M.lookup 0 (timingStatsMap st) @@ -154,7 +148,7 @@ write writer name stats -- | Get the HTML code for multiple runs -timingStatsHtmlMultiple :: TimingStatsViewState r -> Int -> HtmlWriter () +timingStatsHtmlMultiple :: TimingStatsViewState -> Int -> HtmlWriter () timingStatsHtmlMultiple st index = do header st index let n = experimentRunCount $ timingStatsExperiment st @@ -174,7 +168,7 @@ write = timingStatsWrite writer write writer name stats -header :: TimingStatsViewState r -> Int -> HtmlWriter () +header :: TimingStatsViewState -> Int -> HtmlWriter () header st index = do writeHtmlHeader3WithId ("id" ++ show index) $ writeHtmlText (timingStatsTitle $ timingStatsView st) @@ -184,7 +178,7 @@ writeHtmlText description -- | Get the TOC item -timingStatsTOCHtml :: TimingStatsViewState r -> Int -> HtmlWriter () +timingStatsTOCHtml :: TimingStatsViewState -> Int -> HtmlWriter () timingStatsTOCHtml st index = writeHtmlListItem $ writeHtmlLink ("#id" ++ show index) $ diff --git a/Simulation/Aivika/Experiment/TimingStatsWriter.hs b/Simulation/Aivika/Experiment/TimingStatsWriter.hs --- a/Simulation/Aivika/Experiment/TimingStatsWriter.hs +++ b/Simulation/Aivika/Experiment/TimingStatsWriter.hs @@ -1,11 +1,11 @@ -- | -- Module : Simulation.Aivika.Experiment.TimingStatsWriter --- Copyright : Copyright (c) 2012, David Sorokin +-- Copyright : Copyright (c) 2012-2014, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental --- Tested with: GHC 7.4.1 +-- Tested with: GHC 7.6.3 -- -- The module defines 'TimingStatsWriter' that knows how to write -- the timing statistics in HTML. 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 FlexibleInstances, MultiParamTypeClasses #-} +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts #-} -- | -- Module : Simulation.Aivika.Experiment.Types --- Copyright : Copyright (c) 2012-2013, David Sorokin +-- Copyright : Copyright (c) 2012-2014, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental --- Tested with: GHC 7.6.3 +-- Tested with: GHC 7.8.3 -- -- The module defines the simulation experiments. They automate -- the process of generating and analyzing the results. Moreover, @@ -20,46 +20,32 @@ -- module Simulation.Aivika.Experiment.Types - (Experiment(..), + (-- * General Definitions + Experiment(..), + ExperimentRendering(..), defaultExperiment, runExperiment, runExperimentParallel, ExperimentData(..), - experimentDataInStartTime, - experimentSeriesProviders, - experimentMixedSignal, - Series(..), - SeriesContainer(..), - SeriesEntity(..), - SeriesProvider(..), - SeriesListWithSubscript, - SeriesArrayWithSubscript, - SeriesVectorWithSubscript, - seriesListWithSubscript, - seriesArrayWithSubscript, - seriesVectorWithSubscript, ExperimentView(..), ExperimentGenerator(..), ExperimentReporter(..), ExperimentFilePath(..), resolveFilePath, expandFilePath, - mapFilePath) where + mapFilePath, + -- * Web Page Rendering + WebPageRendering(..), + WebPageRenderer(..), + WebPageWriter(..), + WebPageGenerator(..)) where import Control.Monad import Control.Monad.State import Control.Concurrent.ParallelIO.Local import qualified Data.Map as M -import qualified Data.Vector as V -import qualified Data.Vector.Unboxed as UV -import qualified Data.Array as A -import qualified Data.Array.Unboxed as UA -import Data.Array (Array) -import Data.Array.Unboxed (UArray) -import Data.Array.IO - import Data.Ix import Data.Maybe import Data.Monoid @@ -70,17 +56,18 @@ import GHC.Conc (getNumCapabilities) -import Simulation.Aivika hiding (Var, readVar, varChanged_) -import Simulation.Aivika.Var -import qualified Simulation.Aivika.Ref.Light as LR - +import Simulation.Aivika import Simulation.Aivika.Experiment.HtmlWriter import Simulation.Aivika.Experiment.Utils (replace) --- | It defines the simulation experiment with the specified rendering backend. -data Experiment r = +-- | It defines the simulation experiment with the specified rendering backend and its bound data. +data Experiment = Experiment { experimentSpecs :: Specs, -- ^ The simulation specs for the experiment. + experimentTransform :: ResultTransform, + -- ^ 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. experimentDirectoryName :: ExperimentFilePath, @@ -91,194 +78,81 @@ -- ^ The experiment description. experimentVerbose :: Bool, -- ^ Whether the process of generating the results is verbose. - experimentGenerators :: [ExperimentGenerator r], - -- ^ The experiment generators. - experimentIndexHtml :: Experiment r -> [ExperimentReporter] -> FilePath -> IO (), - -- ^ Create the @index.html@ file after the simulation is finished - -- in the specified directory. 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 r +defaultExperiment :: Experiment defaultExperiment = Experiment { experimentSpecs = Specs 0 10 0.01 RungeKutta4 SimpleGenerator, + experimentTransform = id, + experimentLocalisation = englishResultLocalisation, experimentRunCount = 1, experimentDirectoryName = UniqueFilePath "experiment", experimentTitle = "Simulation Experiment", experimentDescription = "", experimentVerbose = True, - experimentGenerators = [], - experimentIndexHtml = createIndexHtml, experimentNumCapabilities = getNumCapabilities } +-- | It allows rendering the simulation results in an arbitrary way. +class ExperimentRendering r a | r -> a where + + -- | Render the experiment after the simulation is finished, for example, + -- creating the @index.html@ file in the specified directory. + renderExperiment :: Experiment -> r -> [ExperimentReporter a] -> FilePath -> IO () + -- | This is a generator of the reporter with the specified rendering backend. -data ExperimentGenerator r = - ExperimentGenerator { generateReporter :: Experiment r -> r -> FilePath -> IO ExperimentReporter - -- ^ Generate a reporter for the specified directory, - -- where the @index.html@ file will be saved for the - -- current simulation experiment. +data ExperimentGenerator r a = + ExperimentGenerator { generateReporter :: Experiment -> r -> FilePath -> IO (ExperimentReporter a) + -- ^ Generate a reporter bound up with the specified directory. } -- | 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 ExperimentView v r where +class ExperimentRendering r a => ExperimentView v r a | r -> a where -- | Create a generator of the reporter. - outputView :: v -> ExperimentGenerator r - --- | Represents the series. It is usually something, or --- an array of something, or a list of such values which --- can be simulated. --- --- The array and list of series are treated as a sequence of --- separate sub-series that have a subscript which can be --- optionally specified explicitly. By default, the subscript --- is numeric but it may be any string. --- --- At the same time, if the array or list of numeric values --- is wrapped in monads 'Simulation', 'Dynamics' or 'Event' then the --- underlying numeric array and list are already treated as --- a sampling statistics or list of numbers in time point. --- --- Moreover, if the array or list of numbers is contained in --- reference 'Ref' or variable 'Var' then the array and list --- of such values are also treated as a sampling statistics --- or list of numbers in time point. -class Series s where - - -- | Return the simulatable entity with the specified name - -- for the given series. - seriesEntity :: String -> s -> SeriesEntity - --- | Defines the simulatable entity. -data SeriesEntity = - SeriesEntity { seriesProviders :: [SeriesProvider] - -- ^ Return the providers for the entity. - } - --- | This is provider of the simulatable data. -data SeriesProvider = - SeriesProvider { providerName :: String, - -- ^ Return the name. - providerToDouble :: Maybe (Event Double), - -- ^ Try to return the data as double values. - providerToDoubleStats :: Maybe (Event (SamplingStats Double)), - -- ^ Try to return the statistics data in time points. - providerToDoubleList :: Maybe (Event [Double]), - -- ^ Try to return the list of double values. - providerToInt :: Maybe (Event Int), - -- ^ Try to return the data as integers. - providerToIntStats :: Maybe (Event (SamplingStats Int)), - -- ^ Try to return the statistics data in time points. - providerToIntList :: Maybe (Event [Int]), - -- ^ Try to return the list of integer values. - providerToString :: Maybe (Event String), - -- ^ Try to return the data as strings. - providerSignal :: Maybe (Signal ()) - -- ^ Try to get a signal for the data, which - -- is actual for the 'Ref' references and - -- the 'Var' variables. You should not provide - -- such a signal if the data are calculated - -- only in the integration time points, which - -- is true for the integrals, for example. - } + outputView :: v -> ExperimentGenerator r a -- | It describes the source simulation data used in the experiment. data ExperimentData = - ExperimentData { experimentSignalInIntegTimes :: Signal Double, - -- ^ The signal triggered in the integration time points. - experimentSignalInStartTime :: Signal Double, - -- ^ The signal triggered in the start time. - experimentSignalInStopTime :: Signal Double, - -- ^ The signal triggered in the stop time. - experimentSeries :: M.Map String SeriesEntity - -- ^ The simulation entitities with labels as keys. + ExperimentData { experimentResults :: Results, + -- ^ The simulation results used in the experiment. + experimentPredefinedSignals :: ResultPredefinedSignals + -- ^ The predefined signals provided by every model. } --- | Prepare data for the simulation experiment in start time from the series --- with the specified labels. -experimentDataInStartTime :: [(String, SeriesEntity)] -> Simulation ExperimentData -experimentDataInStartTime m = runDynamicsInStartTime $ runEventWith EarlierEvents d where - d = do signalInIntegTimes <- newSignalInIntegTimes - signalInStartTime <- newSignalInStartTime - signalInStopTime <- newSignalInStopTime - let series = M.fromList m - return ExperimentData { experimentSignalInIntegTimes = signalInIntegTimes, - experimentSignalInStartTime = signalInStartTime, - experimentSignalInStopTime = signalInStopTime, - experimentSeries = series } - --- | Get a mixed signal for the specified providers based on --- the experimental data. This signal is triggered when --- the provided signals are triggered. The mixed signal is --- also triggered in the integration time points if there is --- at least one provider without signal. -experimentMixedSignal :: ExperimentData -> [SeriesProvider] -> Signal () -experimentMixedSignal expdata providers = - let xs0 = map providerSignal providers - xs1 = filter isJust xs0 - xs2 = filter isNothing xs0 - signal1 = mconcat $ map fromJust xs1 - signal2 = if null xs2 - then signal3 <> signal4 - else signal5 - signal3 = void $ experimentSignalInStartTime expdata - signal4 = void $ experimentSignalInStopTime expdata - signal5 = void $ experimentSignalInIntegTimes expdata - in signal1 <> signal2 - --- | Return the 'SeriesProvider' values from the experiment data by the specified labels. -experimentSeriesProviders :: ExperimentData -> [String] -> [SeriesProvider] -experimentSeriesProviders expdata labels = - join $ flip map labels $ \label -> - case M.lookup label (experimentSeries expdata) of - Nothing -> - error $ - "There is no series with label " ++ label ++ - ": experimentSeriesProviders" - Just entity -> - seriesProviders entity - --- | Defines what creates the simulation reports. -data ExperimentReporter = +-- | Defines what creates the simulation reports by the specified renderer. +data ExperimentReporter a = ExperimentReporter { reporterInitialise :: IO (), -- ^ Initialise the reporting before -- the simulation runs are started. reporterFinalise :: IO (), -- ^ Finalise the reporting after -- all simulation runs are finished. - reporterSimulate :: ExperimentData -> Event (Event ()), + 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. - reporterTOCHtml :: 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'. - reporterHtml :: 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. + reporterRequest :: a + -- ^ Return data requested by the renderer. } -- | Run the simulation experiment sequentially. For example, -- it can be a Monte-Carlo simulation dependentent on the external -- 'Parameter' values. -runExperiment :: Experiment r +runExperiment :: ExperimentRendering r a + => Experiment -- ^ the simulation experiment to run + -> [ExperimentGenerator r a] + -- ^ generators used for rendering -> r -- ^ the rendering backend - -> Simulation ExperimentData + -> Simulation Results -- ^ the simulation results received from the model -> IO () runExperiment = runExperimentWithExecutor sequence_ @@ -295,11 +169,14 @@ -- threads directly with help of 'experimentNumCapabilities', -- although the real number of parallel threads can depend on many -- factors. -runExperimentParallel :: Experiment r +runExperimentParallel :: ExperimentRendering r a + => Experiment -- ^ the simulation experiment to run + -> [ExperimentGenerator r a] + -- ^ generators used for rendering -> r -- ^ the rendering backend - -> Simulation ExperimentData + -> Simulation Results -- ^ the simulation results received from the model -> IO () runExperimentParallel e = runExperimentWithExecutor executor e @@ -309,23 +186,25 @@ parallel_ pool tasks -- | Run the simulation experiment with the specified executor. -runExperimentWithExecutor :: ([IO ()] -> IO ()) +runExperimentWithExecutor :: ExperimentRendering r a + => ([IO ()] -> IO ()) -- ^ an executor that allows parallelizing the simulation if required - -> Experiment r + -> Experiment -- ^ the simulation experiment to run + -> [ExperimentGenerator r a] + -- ^ generators used for rendering -> r -- ^ the rendering backend - -> Simulation ExperimentData + -> Simulation Results -- ^ the simulation results received from the model -> IO () -runExperimentWithExecutor executor e r simulation = +runExperimentWithExecutor executor e generators r simulation = do let specs = experimentSpecs e runCount = experimentRunCount e dirName = experimentDirectoryName e - generators = experimentGenerators e path <- resolveFilePath "" dirName when (experimentVerbose e) $ - do putStr "Using directory " + do putStr "Updating directory " putStrLn path createDirectoryIfMissing True path reporters <- mapM (\x -> generateReporter x e r path) @@ -333,40 +212,72 @@ forM_ reporters reporterInitialise let simulate :: Simulation () simulate = - do d <- simulation + do signals <- newResultPredefinedSignals + results <- simulation + let d = ExperimentData { experimentResults = experimentTransform e results, + experimentPredefinedSignals = signals } fs <- runDynamicsInStartTime $ runEventWith EarlierEvents $ forM reporters $ \reporter -> reporterSimulate reporter d runEventInStopTime $ - sequence_ fs + disposeEvent $ mconcat fs executor $ runSimulations simulate specs runCount forM_ reporters reporterFinalise - experimentIndexHtml e e reporters path + renderExperiment e r reporters path return () - --- | Create an index HTML file. -createIndexHtml :: Experiment r -> [ExperimentReporter] -> FilePath -> IO () -createIndexHtml e reporters path = - do let html :: HtmlWriter () - html = - writeHtmlDocumentWithTitle (experimentTitle e) $ + +-- | It defines the web page renderer for simulation 'Experiment'. +data WebPageRenderer = WebPageRenderer + +-- | 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 subclass of renderers that know how to save the @index.html@ file +-- when rendering the simulation experiment. +class ExperimentRendering r WebPageWriter => WebPageRendering r + +-- | A convenient type synonym for describing the web page generators. +type WebPageGenerator r = ExperimentGenerator r WebPageWriter + +instance WebPageRendering WebPageRenderer + +instance ExperimentRendering WebPageRenderer WebPageWriter where + + renderExperiment e r reporters path = + do let html :: HtmlWriter () + html = + writeHtmlDocumentWithTitle (experimentTitle e) $ do writeHtmlList $ forM_ (zip [1..] reporters) $ \(i, reporter) -> - reporterTOCHtml reporter i + reporterWriteTOCHtml (reporterRequest reporter) i writeHtmlBreak unless (null $ experimentDescription e) $ writeHtmlParagraph $ writeHtmlText $ experimentDescription e forM_ (zip [1..] reporters) $ \(i, reporter) -> - reporterHtml reporter i - file = combine path "index.html" - ((), contents) <- runHtmlWriter html id - UTF8.writeFile file (contents []) - when (experimentVerbose e) $ - do putStr "Generated file " - putStrLn file - + reporterWriteHtml (reporterRequest reporter) i + file = combine path "index.html" + ((), contents) <- runHtmlWriter html id + UTF8.writeFile file (contents []) + when (experimentVerbose e) $ + do putStr "Generated file " + putStrLn file + -- | 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 @@ -409,553 +320,3 @@ mapFilePath :: (FilePath -> FilePath) -> ExperimentFilePath -> ExperimentFilePath mapFilePath f (WritableFilePath path) = WritableFilePath (f path) mapFilePath f (UniqueFilePath path) = UniqueFilePath (f path) - --- | Represent a container for simulation data. -class SeriesContainer c where - - -- | Extract data from the container. - containerData :: c a -> Event a - - -- | Get the signal for the container. - containerSignal :: c a -> Maybe (Signal ()) - -instance SeriesContainer Parameter where - - containerData = liftParameter - - containerSignal = const Nothing - -instance SeriesContainer Simulation where - - containerData = liftSimulation - - containerSignal = const Nothing - -instance SeriesContainer Dynamics where - - containerData = liftDynamics - - containerSignal = const Nothing - -instance SeriesContainer Event where - - containerData = id - - containerSignal = const Nothing - -instance SeriesContainer Ref where - - containerData = readRef - - containerSignal = Just . refChanged_ - -instance SeriesContainer LR.Ref where - - containerData = LR.readRef - - containerSignal = const Nothing - -instance SeriesContainer Var where - - containerData = readVar - - containerSignal = Just . varChanged_ - -instance SeriesContainer Signalable where - - containerData = readSignalable - - containerSignal = Just . signalableChanged_ - -instance SeriesContainer c => Series (c Double) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = - Just $ - containerData s, - providerToDoubleStats = - Just $ - fmap returnSamplingStats $ - containerData s, - providerToDoubleList = - Just $ - fmap return $ - containerData s, - providerToInt = Nothing, - providerToIntStats = Nothing, - providerToIntList = Nothing, - providerToString = - Just $ - fmap show $ - containerData s, - providerSignal = - containerSignal s }] } - -instance SeriesContainer c => Series (c Int) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = - Just $ - fmap fromIntegral $ - containerData s, - providerToDoubleStats = - Just $ - fmap returnSamplingStats $ - fmap fromIntegral $ - containerData s, - providerToDoubleList = - Just $ - fmap return $ - fmap fromIntegral $ - containerData s, - providerToInt = - Just $ - containerData s, - providerToIntStats = - Just $ - fmap returnSamplingStats $ - containerData s, - providerToIntList = - Just $ - fmap return $ - containerData s, - providerToString = - Just $ - fmap show $ - containerData s, - providerSignal = - containerSignal s }] } - -instance SeriesContainer c => Series (c String) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = Nothing, - providerToDoubleList = Nothing, - providerToInt = Nothing, - providerToIntStats = Nothing, - providerToIntList = Nothing, - providerToString = - Just $ - containerData s, - providerSignal = - containerSignal s }] } - -instance Series s => Series [s] where - - seriesEntity name s = - SeriesEntity { seriesProviders = - join $ forM (zip [0..] s) $ \(i, s) -> - let name' = name ++ "[" ++ show i ++ "]" - in seriesProviders $ seriesEntity name' s } - -instance (Show i, Ix i, Series s) => Series (Array i s) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - join $ forM (A.assocs s) $ \(i, s) -> - let name' = name ++ "[" ++ show i ++ "]" - in seriesProviders $ seriesEntity name' s } - -instance Series s => Series (V.Vector s) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - join $ forM (zip [0..] (V.toList s)) $ \(i, s) -> - let name' = name ++ "[" ++ show i ++ "]" - in seriesProviders $ seriesEntity name' s } - --- | Represents a list with the specified subscript. -data SeriesListWithSubscript s = - SeriesListWithSubscript { seriesList :: [s], - seriesListSubscript :: [String] } - --- | Represents an array with the specified subscript. -data SeriesArrayWithSubscript i s = - SeriesArrayWithSubscript { seriesArray :: Array i s, - seriesArraySubscript :: Array i String } - --- | Represents a vector with the specified subscript. -data SeriesVectorWithSubscript s = - SeriesVectorWithSubscript { seriesVector :: V.Vector s, - seriesVectorSubscript :: V.Vector String } - --- | Add the specified subscript to the list. -seriesListWithSubscript :: Series s - => [s] - -- ^ the list to subscript - -> [String] - -- ^ the list of subscripts - -> SeriesListWithSubscript s - -- ^ the subscripted list -seriesListWithSubscript = SeriesListWithSubscript - --- | Add the specified subscript to the array. -seriesArrayWithSubscript :: (Ix i, Series s) - => Array i s - -- ^ the array to subscript - -> Array i String - -- ^ the array of subscripts - -> SeriesArrayWithSubscript i s - -- ^ the subscripted array -seriesArrayWithSubscript = SeriesArrayWithSubscript - --- | Add the specified subscript to the vector. -seriesVectorWithSubscript :: Series s - => V.Vector s - -- ^ the vector to subscript - -> V.Vector String - -- ^ the vector of subscripts - -> SeriesVectorWithSubscript s - -- ^ the subscripted vector -seriesVectorWithSubscript = SeriesVectorWithSubscript - -instance Series s => Series (SeriesListWithSubscript s) where - - seriesEntity name s = - SeriesEntity { seriesProviders = do - let xs = seriesList s - ns = seriesListSubscript s - join $ forM (zip3 [1..] xs ns) $ \(i, s, n) -> - let name' = name ++ n - in seriesProviders $ seriesEntity name' s } - -instance (Ix i, Series s) => Series (SeriesArrayWithSubscript i s) where - - seriesEntity name s = - SeriesEntity { seriesProviders = do - let xs = seriesArray s - ns = seriesArraySubscript s - join $ forM (zip (A.assocs xs) (A.elems ns)) $ \((i, s), n) -> - let name' = name ++ n - in seriesProviders $ seriesEntity name' s } - -instance Series s => Series (SeriesVectorWithSubscript s) where - - seriesEntity name s = - SeriesEntity { seriesProviders = do - let xs = seriesVector s - ns = seriesVectorSubscript s - join $ forM (zip (V.toList xs) (V.toList ns)) $ \(x, n) -> - let name' = name ++ n - in seriesProviders $ seriesEntity name' x } - -instance SeriesContainer c => Series (c (SamplingStats Double)) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = - Just $ - containerData s, - providerToDoubleList = Nothing, - providerToInt = Nothing, - providerToIntStats = Nothing, - providerToIntList = Nothing, - providerToString = Nothing, - providerSignal = - containerSignal s } ] } - -instance SeriesContainer c => Series (c (SamplingStats Int)) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = - Just $ - fmap fromIntSamplingStats $ - containerData s, - providerToDoubleList = Nothing, - providerToInt = Nothing, - providerToIntStats = - Just $ - containerData s, - providerToIntList = Nothing, - providerToString = Nothing, - providerSignal = - containerSignal s } ] } - -instance SeriesContainer c => Series (c [Double]) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = - Just $ - fmap listSamplingStats $ - containerData s, - providerToDoubleList = - Just $ - containerData s, - providerToInt = Nothing, - providerToIntStats = Nothing, - providerToIntList = Nothing, - providerToString = - Just $ - fmap show $ - containerData s, - providerSignal = - containerSignal s } ] } - -instance SeriesContainer c => Series (c [Int]) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = - Just $ - fmap fromIntSamplingStats $ - fmap listSamplingStats $ - containerData s, - providerToDoubleList = - Just $ - fmap (map fromIntegral) $ - containerData s, - providerToInt = Nothing, - providerToIntStats = - Just $ - fmap listSamplingStats $ - containerData s, - providerToIntList = - Just $ - containerData s, - providerToString = - Just $ - fmap show $ - containerData s, - providerSignal = - containerSignal s } ] } - -instance (Ix i, SeriesContainer c) => Series (c (Array i Double)) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = - Just $ - fmap listSamplingStats $ - fmap A.elems $ - containerData s, - providerToDoubleList = - Just $ - fmap A.elems $ - containerData s, - providerToInt = Nothing, - providerToIntStats = Nothing, - providerToIntList = Nothing, - providerToString = Nothing, - providerSignal = - containerSignal s } ] } - -instance (Ix i, SeriesContainer c) => Series (c (Array i Int)) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = - Just $ - fmap fromIntSamplingStats $ - fmap listSamplingStats $ - fmap A.elems $ - containerData s, - providerToDoubleList = - Just $ - fmap (map fromIntegral) $ - fmap A.elems $ - containerData s, - providerToInt = Nothing, - providerToIntStats = - Just $ - fmap listSamplingStats $ - fmap A.elems $ - containerData s, - providerToIntList = - Just $ - fmap A.elems $ - containerData s, - providerToString = Nothing, - providerSignal = - containerSignal s } ] } - -instance (Ix i, SeriesContainer c) => Series (c (UArray i Double)) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = - Just $ - fmap listSamplingStats $ - fmap UA.elems $ - containerData s, - providerToDoubleList = - Just $ - fmap UA.elems $ - containerData s, - providerToInt = Nothing, - providerToIntStats = Nothing, - providerToIntList = Nothing, - providerToString = Nothing, - providerSignal = - containerSignal s } ] } - -instance (Ix i, SeriesContainer c) => Series (c (UArray i Int)) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = - Just $ - fmap fromIntSamplingStats $ - fmap listSamplingStats $ - fmap UA.elems $ - containerData s, - providerToDoubleList = - Just $ - fmap (map fromIntegral) $ - fmap UA.elems $ - containerData s, - providerToInt = Nothing, - providerToIntStats = - Just $ - fmap listSamplingStats $ - fmap UA.elems $ - containerData s, - providerToIntList = - Just $ - fmap UA.elems $ - containerData s, - providerToString = Nothing, - providerSignal = - containerSignal s } ] } - -instance SeriesContainer c => Series (c (V.Vector Double)) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = - Just $ - fmap listSamplingStats $ - fmap V.toList $ - containerData s, - providerToDoubleList = - Just $ - fmap V.toList $ - containerData s, - providerToInt = Nothing, - providerToIntStats = Nothing, - providerToIntList = Nothing, - providerToString = - Just $ - fmap show $ - containerData s, - providerSignal = - containerSignal s } ] } - -instance SeriesContainer c => Series (c (V.Vector Int)) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = - Just $ - fmap fromIntSamplingStats $ - fmap listSamplingStats $ - fmap V.toList $ - containerData s, - providerToDoubleList = - Just $ - fmap (map fromIntegral) $ - fmap V.toList $ - containerData s, - providerToInt = Nothing, - providerToIntStats = - Just $ - fmap listSamplingStats $ - fmap V.toList $ - containerData s, - providerToIntList = - Just $ - fmap V.toList $ - containerData s, - providerToString = - Just $ - fmap show $ - containerData s, - providerSignal = - containerSignal s }] } - -instance SeriesContainer c => Series (c (UV.Vector Double)) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = - Just $ - fmap listSamplingStats $ - fmap UV.toList $ - containerData s, - providerToDoubleList = - Just $ - fmap UV.toList $ - containerData s, - providerToInt = Nothing, - providerToIntStats = Nothing, - providerToIntList = Nothing, - providerToString = - Just $ - fmap show $ - containerData s, - providerSignal = - containerSignal s } ] } - -instance SeriesContainer c => Series (c (UV.Vector Int)) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = - Just $ - fmap fromIntSamplingStats $ - fmap listSamplingStats $ - fmap UV.toList $ - containerData s, - providerToDoubleList = - Just $ - fmap (map fromIntegral) $ - fmap UV.toList $ - containerData s, - providerToInt = Nothing, - providerToIntStats = - Just $ - fmap listSamplingStats $ - fmap UV.toList $ - containerData s, - providerToIntList = - Just $ - fmap UV.toList $ - containerData s, - providerToString = - Just $ - fmap show $ - containerData s, - providerSignal = - containerSignal s } ] } 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, David Sorokin +-- Copyright : Copyright (c) 2012-2014, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental --- Tested with: GHC 7.4.1 +-- Tested with: GHC 7.6.3 -- -- It defines utility functions missed in the standard library. -- diff --git a/aivika-experiment.cabal b/aivika-experiment.cabal --- a/aivika-experiment.cabal +++ b/aivika-experiment.cabal @@ -1,5 +1,5 @@ name: aivika-experiment -version: 1.3.1 +version: 1.4 synopsis: Simulation experiments for the Aivika library description: This package allows defining simulation experiments for the Aivika @@ -18,7 +18,7 @@ homepage: http://github.com/dsorokin/aivika-experiment cabal-version: >= 1.6 build-type: Simple -tested-with: GHC == 7.6.3 +tested-with: GHC == 7.8.3 extra-source-files: examples/MachRep3.hs examples/LinearArray.hs @@ -27,38 +27,35 @@ exposed-modules: Simulation.Aivika.Experiment Simulation.Aivika.Experiment.Types - Simulation.Aivika.Experiment.FileRenderer 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.SamplingStatsSource Simulation.Aivika.Experiment.FinalStatsView Simulation.Aivika.Experiment.Histogram Simulation.Aivika.Experiment.ExperimentSpecsView Simulation.Aivika.Experiment.ExperimentSpecsWriter Simulation.Aivika.Experiment.FinalTableView - Simulation.Aivika.Experiment.ListSource Simulation.Aivika.Experiment.Utils + Simulation.Aivika.Experiment.MRef build-depends: base >= 3 && < 6, mtl >= 1.1.0.2, - array >= 0.3.0.0, - vector >= 0.9, containers >= 0.4.0.0, directory >= 1.1.0.2, filepath >= 1.3.0.0, utf8-string >= 0.3.7, split >= 0.2.2, - network >= 2.3.0.13, + network-uri >= 2.6, parallel-io >= 0.3.2.1, - aivika >= 1.3 + aivika >= 1.4 extensions: FlexibleInstances, + FlexibleContexts, MultiParamTypeClasses, - RankNTypes + FunctionalDependencies ghc-options: -O2 diff --git a/examples/LinearArray.hs b/examples/LinearArray.hs --- a/examples/LinearArray.hs +++ b/examples/LinearArray.hs @@ -9,6 +9,8 @@ {-# LANGUAGE RecursiveDo #-} import Data.Array +import Data.Monoid + import Control.Monad import Control.Monad.Trans @@ -32,7 +34,7 @@ return (i, x) return $ array bnds ps -model :: Int -> Simulation ExperimentData +model :: Int -> Simulation Results model n = mdo m <- generateArray (1, n) $ \i -> integ (q + k * (c!(i - 1) - c!i) + k * (c!(i + 1) - c!i)) 0 @@ -43,30 +45,45 @@ q = 1 k = 2 v = 0.75 - experimentDataInStartTime - [("t", seriesEntity "time" time), - ("m", seriesEntity "M" m), - ("c", seriesEntity "C" c)] + return $ results + [resultSource "t" "time" time, + resultSource "m" "M" m, + resultSource "c" "C" c] -experiment :: FileRenderer r => Experiment r +experiment :: Experiment experiment = defaultExperiment { experimentSpecs = specs, experimentRunCount = 1, experimentTitle = "Linear Array", experimentDescription = "Model Linear Array as described in " ++ - "the examples included in Berkeley-Madonna.", - experimentGenerators = - [outputView defaultExperimentSpecsView, - outputView $ defaultTableView { - tableSeries = ["t", "m", "c"] }, - outputView $ defaultFinalTableView { - finalTableSeries = ["m", "c"] }, - outputView $ defaultLastValueView { - lastValueSeries = ["t", "m", "c"] }, - outputView $ defaultTimingStatsView { - timingStatsSeries = ["t", "m", "c"] }, - outputView $ defaultFinalStatsView { - finalStatsSeries = ["m", "c"] } ] } + "the examples included in Berkeley-Madonna." } -main = runExperiment experiment HtmlRenderer (model 51) +generators :: WebPageRendering r => [WebPageGenerator r] +generators = + [outputView defaultExperimentSpecsView, + outputView $ defaultTableView { + tableSeries = + resultByName "t" <> + resultByName "m" <> + resultByName "c" }, + outputView $ defaultFinalTableView { + finalTableSeries = + resultByName "m" <> + resultByName "c" }, + outputView $ defaultLastValueView { + lastValueSeries = + resultByName "t" <> + resultByName "m" <> + resultByName "c" }, + outputView $ defaultTimingStatsView { + timingStatsSeries = + resultByName "t" <> + resultByName "m" <> + resultByName "c" }, + outputView $ defaultFinalStatsView { + finalStatsSeries = + resultByName "m" <> + resultByName "c" } ] + +main = runExperiment experiment generators WebPageRenderer (model 51) diff --git a/examples/MachRep3.hs b/examples/MachRep3.hs --- a/examples/MachRep3.hs +++ b/examples/MachRep3.hs @@ -36,26 +36,28 @@ "until both machines are down. We find the proportion of up time. It " ++ "should come out to about 0.45." -experiment :: FileRenderer r => Experiment r +experiment :: Experiment experiment = defaultExperiment { experimentSpecs = specs, experimentRunCount = 3, - experimentDescription = description, - experimentGenerators = - [outputView defaultExperimentSpecsView, - outputView $ defaultLastValueView { - lastValueSeries = ["x"] }, - outputView $ defaultTimingStatsView { - timingStatsSeries = ["x"] }, - outputView $ defaultFinalStatsView { - finalStatsSeries = ["x"] }, - outputView $ defaultTableView { - tableSeries = ["x"] }, - outputView $ defaultFinalTableView { - finalTableSeries = ["x"] } ] } + experimentDescription = description } -model :: Simulation ExperimentData +generators :: WebPageRendering r => [WebPageGenerator r] +generators = + [outputView defaultExperimentSpecsView, + outputView $ defaultLastValueView { + lastValueSeries = resultByName "x" }, + outputView $ defaultTimingStatsView { + timingStatsSeries = resultByName "x" }, + outputView $ defaultFinalStatsView { + finalStatsSeries = resultByName "x" }, + outputView $ defaultTableView { + tableSeries = resultByName "x" }, + outputView $ defaultFinalTableView { + finalTableSeries = resultByName "x" } ] + +model :: Simulation Results model = do -- number of machines currently up nUp <- newRef 2 @@ -104,13 +106,13 @@ runProcessInStartTimeUsingId pid2 (machine pid1) - let result = + let prop = do x <- readRef totalUpTime y <- liftDynamics time return $ x / (2 * y) - experimentDataInStartTime - [("x", seriesEntity "The proportion of up time" result), - ("t", seriesEntity "Simulation time" time)] + return $ results + [resultSource "x" "The proportion of up time" prop, + resultSource "t" "Simulation time" time] -main = runExperiment experiment HtmlRenderer model +main = runExperiment experiment generators WebPageRenderer model