diff --git a/Simulation/Aivika/Experiment.hs b/Simulation/Aivika/Experiment.hs --- a/Simulation/Aivika/Experiment.hs +++ b/Simulation/Aivika/Experiment.hs @@ -49,7 +49,7 @@ import Data.Monoid import Data.String.Utils (replace) -import System.IO +import qualified System.IO.UTF8 as UTF8 import System.Directory import System.FilePath (combine) @@ -308,7 +308,7 @@ reporterHtml reporter i file = combine path "index.html" ((), contents) <- runHtmlWriter html id - writeFile file (contents []) + UTF8.writeFile file (contents []) when (experimentVerbose e) $ do putStr "Generated file " putStrLn file diff --git a/Simulation/Aivika/Experiment/ExperimentSpecsView.hs b/Simulation/Aivika/Experiment/ExperimentSpecsView.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Experiment/ExperimentSpecsView.hs @@ -0,0 +1,88 @@ + +-- | +-- Module : Simulation.Aivika.Experiment.ExperimentSpecsView +-- Copyright : Copyright (c) 2012, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.4.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 Simulation.Aivika.Experiment +import Simulation.Aivika.Experiment.HtmlWriter +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 View ExperimentSpecsView where + + outputView v = + let reporter exp dir = + do st <- newExperimentSpecs v exp + return Reporter { reporterInitialise = return (), + reporterFinalise = return (), + reporterSimulate = const $ return $ return (), + reporterTOCHtml = experimentSpecsTOCHtml st, + reporterHtml = experimentSpecsHtml st } + in Generator { generateReporter = reporter } + +-- | The state of the view. +data ExperimentSpecsViewState = + ExperimentSpecsViewState { experimentSpecsView :: ExperimentSpecsView, + experimentSpecsExperiment :: Experiment } + +-- | Create a new state of the view. +newExperimentSpecs :: ExperimentSpecsView -> Experiment -> IO 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 new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Experiment/ExperimentSpecsWriter.hs @@ -0,0 +1,131 @@ + +-- | +-- Module : Simulation.Aivika.Experiment.ExperimentSpecsWriter +-- Copyright : Copyright (c) 2012, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.4.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.Experiment +import Simulation.Aivika.Experiment.HtmlWriter + +import Simulation.Aivika.Dynamics.Simulation + +-- | 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 (show 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 $ spcStartTime $ experimentSpecs exp + writeHtml "
" + writeHtmlText $ experimentSpecsStopTimeText writer + writeHtml "" + writeHtmlText $ format $ spcStopTime $ experimentSpecs exp + writeHtml "
" + writeHtmlText $ experimentSpecsDTText writer + writeHtml "" + writeHtmlText $ format $ spcDT $ experimentSpecs exp + writeHtml "
" + writeHtmlText $ experimentSpecsRunCountText writer + writeHtml "" + writeHtmlText $ format $ 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/FinalStatsView.hs b/Simulation/Aivika/Experiment/FinalStatsView.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Experiment/FinalStatsView.hs @@ -0,0 +1,177 @@ + +-- | +-- Module : Simulation.Aivika.Experiment.FinalStatsView +-- Copyright : Copyright (c) 2012, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.4.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.Experiment +import Simulation.Aivika.Experiment.HtmlWriter +import Simulation.Aivika.Experiment.SamplingStatsWriter + +import Simulation.Aivika.Dynamics +import Simulation.Aivika.Dynamics.Simulation +import Simulation.Aivika.Dynamics.Signal +import Simulation.Aivika.Dynamics.EventQueue +import Simulation.Aivika.Dynamics.Base +import Simulation.Aivika.Statistics + +-- | 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 :: Dynamics 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. + } + +-- | 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.", + finalStatsWriter = defaultSamplingStatsWriter, + finalStatsPredicate = return True, + finalStatsSeries = [] } + +instance View FinalStatsView where + + outputView v = + let reporter exp dir = + do st <- newFinalStats v exp dir + return Reporter { reporterInitialise = return (), + reporterFinalise = return (), + reporterSimulate = simulateFinalStats st, + reporterTOCHtml = finalStatsTOCHtml st, + reporterHtml = finalStatsHtml st } + in Generator { generateReporter = reporter } + +-- | The state of the view. +data FinalStatsViewState = + FinalStatsViewState { finalStatsView :: FinalStatsView, + finalStatsExperiment :: Experiment, + finalStatsLock :: MVar (), + finalStatsResults :: IORef (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 -> IO FinalStatsViewState +newFinalStats view exp dir = + do l <- newMVar () + r <- newIORef Nothing + return FinalStatsViewState { finalStatsView = view, + finalStatsExperiment = exp, + finalStatsLock = l, + 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 } + +-- | Simulation the specified series. +simulateFinalStats :: FinalStatsViewState -> ExperimentData -> Dynamics (Dynamics ()) +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 providerToDouble provider of + Nothing -> error $ + "Cannot represent series " ++ + providerName provider ++ + " as double values: simulateFinalStats" + Just input -> 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 + t0 <- starttime + enqueue (experimentQueue expdata) t0 $ + do let h = filterSignalM (const predicate) $ + experimentSignalInStopTime expdata + -- we must subscribe through the event queue; + -- otherwise, we will loose a signal in the start time, + -- because the handleSignal_ function checks the event queue + handleSignal_ h $ \_ -> + do xs <- sequence input + liftIO $ withMVar lock $ \() -> + forM_ (zip xs values) $ \(x, values) -> + modifyIORef values $ addSamplingStats x + return $ return () + +-- | Get the HTML code. +finalStatsHtml :: FinalStatsViewState -> Int -> HtmlWriter () +finalStatsHtml st index = + do header st index + results <- liftIO $ readIORef (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 new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Experiment/FinalTableView.hs @@ -0,0 +1,250 @@ + +-- | +-- Module : Simulation.Aivika.Experiment.FinalTableView +-- Copyright : Copyright (c) 2012, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.4.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.Experiment +import Simulation.Aivika.Experiment.HtmlWriter + +import Simulation.Aivika.Dynamics +import Simulation.Aivika.Dynamics.Simulation +import Simulation.Aivika.Dynamics.Signal +import Simulation.Aivika.Dynamics.EventQueue +import Simulation.Aivika.Dynamics.Base + +-- | 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 :: FileName, + -- ^ It defines the file name for the CSV file. + -- It may include special variable @$TITLE@. + -- + -- An example is + -- + -- @ + -- finalTableFileName = UniqueFileName \"$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 :: Dynamics 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. + } + +-- | 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 = UniqueFileName "$TITLE" ".csv", + finalTableSeparator = ",", + finalTableFormatter = id, + finalTablePredicate = return True, + finalTableSeries = [] } + +instance View FinalTableView where + + outputView v = + let reporter exp dir = + do st <- newFinalTable v exp dir + return Reporter { reporterInitialise = return (), + reporterFinalise = finaliseFinalTable st, + reporterSimulate = simulateFinalTable st, + reporterTOCHtml = finalTableTOCHtml st, + reporterHtml = finalTableHtml st } + in Generator { generateReporter = reporter } + +-- | The state of the view. +data FinalTableViewState = + FinalTableViewState { finalTableView :: FinalTableView, + finalTableExperiment :: Experiment, + finalTableDir :: FilePath, + finalTableFile :: IORef (Maybe FilePath), + finalTableLock :: MVar (), + finalTableResults :: IORef (Maybe FinalTableResults) } + +-- | The table results. +data FinalTableResults = + FinalTableResults { finalTableNames :: [String], + finalTableValues :: IORef (M.Map Int [String]) } + +-- | Create a new state of the view. +newFinalTable :: FinalTableView -> Experiment -> FilePath -> IO FinalTableViewState +newFinalTable view exp dir = + do f <- newIORef Nothing + l <- newMVar () + r <- newIORef Nothing + return FinalTableViewState { finalTableView = view, + finalTableExperiment = exp, + finalTableDir = dir, + finalTableFile = f, + finalTableLock = l, + finalTableResults = r } + +-- | Create new table results. +newFinalTableResults :: [String] -> Experiment -> IO FinalTableResults +newFinalTableResults names exp = + do values <- newIORef M.empty + return FinalTableResults { finalTableNames = names, + finalTableValues = values } + +-- | Simulation of the specified series. +simulateFinalTable :: FinalTableViewState -> ExperimentData -> Dynamics (Dynamics ()) +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 + t <- time + enqueue (experimentQueue expdata) t $ + do let h = filterSignalM (const predicate) $ + experimentSignalInStopTime expdata + -- we must subscribe through the event queue; + -- otherwise, we will loose a signal in the start time, + -- because the handleSignal_ function checks the event queue + handleSignal_ h $ \_ -> + do xs <- sequence input + i <- liftSimulation simulationIndex + liftIO $ withMVar lock $ \() -> + modifyIORef values $ M.insert i xs + return $ return () + +-- | Save the results in the CSV file after the simulation is complete. +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 + case results of + Nothing -> return () + Just results -> + do let names = finalTableNames results + values = finalTableValues results + m <- readIORef values + file <- resolveFileName + (Just $ finalTableDir st) + (finalTableFileName $ finalTableView st) $ + M.fromList [("$TITLE", title)] + -- create a new file + h <- liftIO $ openFile file WriteMode + -- write a header + hPutStr h run + forM_ names $ \name -> + do hPutStr h separator + hPutStr h 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 @@ -27,10 +27,6 @@ import Numeric ---- -import System.IO.Unsafe ---- - ------------------------------------------------------------------------------- -- | Holds all the information needed to plot the histogram 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 @@ -238,6 +238,7 @@ writeHtmlDocumentWithTitle title inner = do writeHtml "" writeHtml "" + writeHtml "" writeHtml "" writeHtmlText title writeHtml "" 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 @@ -61,7 +61,7 @@ defaultLastValueView = LastValueView { lastValueTitle = "The Last Values", lastValueRunTitle = "$TITLE / Run $RUN_INDEX of $RUN_COUNT", - lastValueDescription = [], + lastValueDescription = "It shows the values in the final time points.", lastValueFormatter = id, lastValueSeries = [] } diff --git a/Simulation/Aivika/Experiment/SamplingStatsWriter.hs b/Simulation/Aivika/Experiment/SamplingStatsWriter.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Experiment/SamplingStatsWriter.hs @@ -0,0 +1,112 @@ + +-- | +-- Module : Simulation.Aivika.Experiment.SamplingStatsWriter +-- Copyright : Copyright (c) 2012, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.4.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 +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 (show 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 $ samplingStatsMean stats + writeHtml "
" + writeHtmlText $ samplingStatsDeviationText writer + writeHtml "" + writeHtmlText $ format $ samplingStatsDeviation stats + writeHtml "
" + writeHtmlText $ samplingStatsMinText writer + writeHtml "" + writeHtmlText $ format $ samplingStatsMin stats + writeHtml "
" + writeHtmlText $ samplingStatsMaxText writer + writeHtml "" + writeHtmlText $ format $ samplingStatsMax stats + writeHtml "
" + writeHtmlText $ samplingStatsCountText writer + writeHtml "" + writeHtml $ format $ samplingStatsCount stats + writeHtml "
" + writeHtml "

" + } 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 @@ -104,7 +104,7 @@ defaultTableView :: TableView defaultTableView = TableView { tableTitle = "Table", - tableDescription = [], + 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 = UniqueFileName "$TITLE - $RUN_INDEX" ".csv", diff --git a/Simulation/Aivika/Experiment/TimingStatsView.hs b/Simulation/Aivika/Experiment/TimingStatsView.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Experiment/TimingStatsView.hs @@ -0,0 +1,191 @@ + +-- | +-- Module : Simulation.Aivika.Experiment.TimingStatsView +-- Copyright : Copyright (c) 2012, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.4.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.String.Utils (replace) + +import Simulation.Aivika.Experiment +import Simulation.Aivika.Experiment.HtmlWriter +import Simulation.Aivika.Experiment.TimingStatsWriter + +import Simulation.Aivika.Dynamics +import Simulation.Aivika.Dynamics.Simulation +import Simulation.Aivika.Dynamics.Signal +import Simulation.Aivika.Dynamics.EventQueue +import Simulation.Aivika.Dynamics.Base +import Simulation.Aivika.Statistics + +-- | 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 :: Dynamics Bool, + -- ^ Specifies when gathering the statistics. + timingStatsSeries :: [String] + -- ^ It contains the labels of the observed series. + } + +-- | 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, + timingStatsSeries = [] } + +instance View TimingStatsView where + + outputView v = + let reporter exp dir = + do st <- newTimingStats v exp + return Reporter { reporterInitialise = return (), + reporterFinalise = return (), + reporterSimulate = simulateTimingStats st, + reporterTOCHtml = timingStatsTOCHtml st, + reporterHtml = timingStatsHtml st } + in Generator { 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 -> IO TimingStatsViewState +newTimingStats view exp = + do let n = experimentRunCount exp + rs <- forM [0..(n - 1)] $ \i -> 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 -> Dynamics (Dynamics ()) +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 + i <- liftSimulation simulationIndex + let r = fromJust $ M.lookup (i - 1) $ timingStatsMap st + t <- time + 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] + enqueue (experimentQueue expdata) t $ + -- we must subscribe through the event queue; + -- otherwise, we will loose a signal in the start time, + -- because the handleSignal_ function checks the event queue + handleSignal_ h $ \_ -> + do t <- time + x <- input + liftIO $ modifyIORef stats $ addTimingStats t x + return $ return () + +-- | 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 new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Experiment/TimingStatsWriter.hs @@ -0,0 +1,130 @@ + +-- | +-- Module : Simulation.Aivika.Experiment.TimingStatsWriter +-- Copyright : Copyright (c) 2012, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.4.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 +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 (show 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 $ timingStatsMean stats + writeHtml "
" + writeHtmlText $ timingStatsDeviationText writer + writeHtml "" + writeHtmlText $ format $ timingStatsDeviation stats + writeHtml "
" + writeHtmlText $ timingStatsMinText writer + writeHtml "" + writeHtmlText $ format $ timingStatsMin stats + writeHtml "" + writeHtmlText "(" + writeHtmlText $ timingStatsTimeText writer + writeHtmlText " = " + writeHtmlText $ format $ timingStatsMinTime stats + writeHtmlText ")" + writeHtml "
" + writeHtmlText $ timingStatsMaxText writer + writeHtml "" + writeHtmlText $ format $ timingStatsMax stats + writeHtml "" + writeHtmlText "(" + writeHtmlText $ timingStatsTimeText writer + writeHtmlText " = " + writeHtmlText $ format $ timingStatsMaxTime stats + writeHtmlText ")" + writeHtml "
" + writeHtmlText $ timingStatsTimeText writer + writeHtml "" + writeHtml "[" + writeHtml $ format $ timingStatsStartTime stats + writeHtml "; " + writeHtml $ format $ timingStatsLastTime stats + writeHtml "]" + writeHtml "
" + writeHtml "

" + } 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: 0.1.2 +version: 0.2 synopsis: Simulation experiments for the Aivika library description: This package allows defining simulation experiments for the Aivika @@ -28,7 +28,14 @@ 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.Histogram + Simulation.Aivika.Experiment.ExperimentSpecsView + Simulation.Aivika.Experiment.ExperimentSpecsWriter + Simulation.Aivika.Experiment.FinalTableView Simulation.Aivika.Experiment.Utils build-depends: base >= 3 && < 6, @@ -37,10 +44,11 @@ containers >= 0.4.0.0, directory >= 1.1.0.2, filepath >= 1.3.0.0, + utf8-string >= 0.3.7, MissingH >= 1.2.0.0, network >= 2.3.0.13, parallel-io >= 0.3.2.1, - aivika >= 0.4.3 + aivika >= 0.5.1 extensions: FlexibleInstances diff --git a/examples/MachRep3.hs b/examples/MachRep3.hs --- a/examples/MachRep3.hs +++ b/examples/MachRep3.hs @@ -13,7 +13,7 @@ -- until both machines are down. We find the proportion of up time. It -- should come out to about 0.45. -module MachRep3Model (model) where +-- module MachRep3Model (model) where import System.Random import Control.Monad @@ -30,6 +30,10 @@ import Simulation.Aivika.Experiment import Simulation.Aivika.Experiment.LastValueView import Simulation.Aivika.Experiment.TableView +import Simulation.Aivika.Experiment.TimingStatsView +import Simulation.Aivika.Experiment.FinalStatsView +import Simulation.Aivika.Experiment.ExperimentSpecsView +import Simulation.Aivika.Experiment.FinalTableView specs = Specs { spcStartTime = 0.0, spcStopTime = 1000.0, @@ -51,16 +55,17 @@ experimentRunCount = 3, experimentDescription = description, experimentGenerators = - [outputView $ defaultLastValueView { - lastValueDescription = - "It shows the last value of " ++ - "the proportion of up time.", - lastValueSeries = ["x"] }, + [outputView defaultExperimentSpecsView, + outputView $ defaultLastValueView { + lastValueSeries = ["x"] }, + outputView $ defaultTimingStatsView { + timingStatsSeries = ["x"] }, + outputView $ defaultFinalStatsView { + finalStatsSeries = ["x"] }, outputView $ defaultTableView { - tableDescription = - "These are tables for " ++ - "the proportion of up time.", - tableSeries = ["x"] } ] } + tableSeries = ["x"] }, + outputView $ defaultFinalTableView { + finalTableSeries = ["x"] } ] } upRate = 1.0 / 1.0 -- reciprocal of mean up time repairRate = 1.0 / 0.5 -- reciprocal of mean repair time @@ -122,6 +127,7 @@ return $ x / (2 * y) experimentDataInStartTime queue - [("x", seriesEntity "The proportion of up time" result)] + [("x", seriesEntity "The proportion of up time" result), + ("t", seriesEntity "Simulation time" time)] main = runExperiment experiment model