diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,30 +1,30 @@ -Copyright (c) 2012 David Sorokin - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: - -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - -2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - -3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS -OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) -HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY -OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF -SUCH DAMAGE. +Copyright (c) 2012 David Sorokin + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,3 +1,3 @@ -#!/usr/bin/env runhaskell -> import Distribution.Simple -> main = defaultMain +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/Simulation/Aivika/Experiment.hs b/Simulation/Aivika/Experiment.hs --- a/Simulation/Aivika/Experiment.hs +++ b/Simulation/Aivika/Experiment.hs @@ -1,485 +1,539 @@ - -{-# LANGUAGE FlexibleInstances #-} - --- | --- Module : Simulation.Aivika.Experiment --- Copyright : Copyright (c) 2012, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.4.1 --- --- The module defines the simulation experiments. They automate --- the process of generating and analyzing the results. Moreover, --- this module is open to extensions, allowing you to define --- your own output views for the simulations results, for example, --- such views that would allow saving the results in PDF or as --- charts. To decrease the number of dependencies, such possible --- extenstions are not included in this package, although simple --- views are provided. --- - -module Simulation.Aivika.Experiment - (Experiment(..), - defaultExperiment, - runExperiment, - ExperimentData(..), - experimentDataInStartTime, - experimentSeriesProviders, - experimentMixedSignal, - Series(..), - SeriesEntity(..), - SeriesProvider(..), - View(..), - Generator(..), - Reporter(..), - DirectoryName(..), - resolveDirectoryName, - FileName(..), - resolveFileName) where - -import Control.Monad -import Control.Monad.State - -import qualified Data.Map as M -import Data.Array -import Data.Maybe -import Data.Monoid -import Data.String.Utils (replace) - -import System.IO -import System.Directory -import System.FilePath (combine) - -import Simulation.Aivika.Dynamics -import Simulation.Aivika.Dynamics.Simulation -import Simulation.Aivika.Dynamics.Signal -import Simulation.Aivika.Dynamics.Ref -import Simulation.Aivika.Dynamics.Var -import Simulation.Aivika.Dynamics.UVar -import Simulation.Aivika.Dynamics.EventQueue -import Simulation.Aivika.Dynamics.Parameter - -import Simulation.Aivika.Experiment.HtmlWriter - --- | It defines the simulation experiment. -data Experiment = - Experiment { experimentSpecs :: Specs, - -- ^ The simulation specs for the experiment. - experimentRunCount :: Int, - -- ^ How many simulation runs should be launched. - experimentDirectoryName :: DirectoryName, - -- ^ The directory in which the output results should be saved. - experimentTitle :: String, - -- ^ The experiment title. - experimentDescription :: String, - -- ^ The experiment description. - experimentVerbose :: Bool, - -- ^ Whether the process of generating the results is verbose. - experimentGenerators :: [Generator], - -- ^ The experiment generators. - experimentIndexHtml :: Experiment -> [Reporter] -> FilePath -> IO () - -- ^ Create the @index.html@ file after the simulation is finished - -- in the specified directory. - } - --- | The default experiment. -defaultExperiment :: Experiment -defaultExperiment = - Experiment { experimentSpecs = Specs 0 10 0.01 RungeKutta4, - experimentRunCount = 1, - experimentDirectoryName = UniqueDirectoryName "experiment", - experimentTitle = "Simulation Experiment", - experimentDescription = "", - experimentVerbose = True, - experimentGenerators = [], - experimentIndexHtml = createIndexHtml } - --- | This is a generator of the reporter. -data Generator = - Generator { generateReporter :: Experiment -> FilePath -> IO Reporter - -- ^ Generate a reporter for the specified directory, - -- where the @index.html@ file will be saved for the - -- current simulation experiment. - } - --- | 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 View v where - - -- | Create a generator of the reporter. - outputView :: v -> Generator - --- | Represents the series. It is usually something, or --- an array of something, or a list of such values which --- can be simulated. -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 (Dynamics Double), - -- ^ Try to return the data as double values. - providerToInt :: Maybe (Dynamics Int), - -- ^ Try to return the data as integers. - providerToString :: Maybe (Dynamics 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. - } - --- | It describes the source simulation data used in the experiment. -data ExperimentData = - ExperimentData { experimentQueue :: EventQueue, - -- ^ Return the event queue. - 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. - } - --- | Prepare data for the simulation experiment in start time from the series --- with the specified labels. -experimentDataInStartTime :: EventQueue -> [(String, SeriesEntity)] -> Simulation ExperimentData -experimentDataInStartTime q m = runDynamicsInStartTime d where - d = do signalInIntegTimes <- newSignalInIntegTimes q - signalInStartTime <- newSignalInStartTime q - signalInStopTime <- newSignalInStopTime q - let series = M.fromList m - return ExperimentData { experimentQueue = q, - 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 Reporter = - Reporter { reporterInitialise :: IO (), - -- ^ Initialise the reporting before - -- the simulation runs are started. - reporterFinalise :: IO (), - -- ^ Finalise the reporting after - -- all simulation runs are finished. - reporterSimulate :: ExperimentData -> - Dynamics (Dynamics ()), - -- ^ 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. - } - --- | Run the simulation experiment sequentially. For example, --- it can be a Monte-Carlo simulation dependentent on the external --- 'Parameter' values. -runExperiment :: Experiment -> Simulation ExperimentData -> IO () -runExperiment e simulation = - do let specs = experimentSpecs e - runCount = experimentRunCount e - dirName = experimentDirectoryName e - generators = experimentGenerators e - path <- resolveDirectoryName Nothing dirName M.empty - when (experimentVerbose e) $ - do putStr "Using directory " - putStrLn path - createDirectoryIfMissing True path - reporters <- mapM (\x -> generateReporter x e path) - generators - forM_ reporters reporterInitialise - let simulate :: Simulation () - simulate = - do d <- simulation - fs <- runDynamicsInStartTime $ - forM reporters $ \reporter -> - reporterSimulate reporter d - runDynamicsInStopTime $ - do updateSignal $ - experimentMixedSignal d $ - join $ map seriesProviders $ - M.elems $ experimentSeries d - sequence_ fs - sequence_ $ runSimulations simulate specs runCount - forM_ reporters reporterFinalise - experimentIndexHtml e e reporters path - return () - --- | Create an index HTML file. -createIndexHtml :: Experiment -> [Reporter] -> FilePath -> IO () -createIndexHtml e reporters path = - do let html :: HtmlWriter () - html = - writeHtmlDocumentWithTitle (experimentTitle e) $ - do writeHtmlList $ - forM_ (zip [1..] reporters) $ \(i, reporter) -> - reporterTOCHtml reporter i - writeHtmlBreak - unless (null $ experimentDescription e) $ - writeHtmlParagraph $ - writeHtmlText $ experimentDescription e - forM_ (zip [1..] reporters) $ \(i, reporter) -> - reporterHtml reporter i - ((), contents) <- runHtmlWriter html id - writeFile (path ++ "/index.html") (contents []) - when (experimentVerbose e) $ - do putStr "Generated file " - putStr path - putStrLn "/index.html" - --- | Specifies the directory name, unique or writable. -data DirectoryName = WritableDirectoryName String - -- ^ The directory which is overwritten in - -- case if it existed before. - | UniqueDirectoryName String - -- ^ The directory which is always unique, - -- when a prefix is added to the name - -- in case of need. - --- | Specifies the file name, unique or writable. -data FileName = WritableFileName String String - -- ^ The file which is overwritten in - -- case if it existed before. The first - -- field defines a name or its prototype. - -- The second field is the file extension. - | UniqueFileName String String - -- ^ The file which is always unique, - -- when a prefix is added to the name - -- in case of need. The first field - -- defines a name or its prototype. - -- The second field is the file exension. - --- | Resolve the directory name relative to the passed in directory --- as the first argument, replacing the specified strings according the map. -resolveDirectoryName :: Maybe FilePath -> DirectoryName -> M.Map String String -> IO String -resolveDirectoryName dir (WritableDirectoryName name) map = - return $ replaceName (combineName dir name) map -resolveDirectoryName dir (UniqueDirectoryName name) map = - let x = replaceName name map - loop y i = - do let n = combineName dir y - f1 <- doesFileExist n - f2 <- doesDirectoryExist n - if f1 || f2 - then loop (x ++ "(" ++ show i ++ ")") (i + 1) - else return n - in loop x 2 - --- | Resolve the file name relative to the passed in directory --- as the first argument, replacing the specified strings according the map. -resolveFileName :: Maybe FilePath -> FileName -> M.Map String String -> IO String -resolveFileName dir (WritableFileName name ext) map = - return $ replaceName (combineName dir name ++ ext) map -resolveFileName dir (UniqueFileName name ext) map = - let x = replaceName name map - loop y i = - do let n = combineName dir y ++ ext - f1 <- doesFileExist n - f2 <- doesDirectoryExist n - if f1 || f2 - then loop (x ++ "(" ++ show i ++ ")") (i + 1) - else return n - in loop x 2 - --- | Replace the name according the specified table. -replaceName :: String -> M.Map String String -> String -replaceName name map = name' where - ((), name') = flip runState name $ - forM_ (M.assocs map) $ \(k, v) -> - do a <- get - put $ replace k v a - --- | Combine the file name with the directory name. -combineName :: Maybe String -> String -> String -combineName dir name = - case dir of - Nothing -> name - Just dir -> combine dir name - -instance Series (Dynamics Double) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Just s, - providerToInt = Nothing, - providerToString = Just $ fmap show s, - providerSignal = Nothing }] } - -instance Series (Dynamics Int) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Just $ fmap (fromInteger . toInteger) s, - providerToInt = Just s, - providerToString = Just $ fmap show s, - providerSignal = Nothing }] } - -instance Series (Dynamics String) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToInt = Nothing, - providerToString = Just s, - providerSignal = Nothing }] } - -instance Series (Ref Double) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Just $ readRef s, - providerToInt = Nothing, - providerToString = Just $ fmap show (readRef s), - providerSignal = Just $ refChanged_ s }] } - -instance Series (Ref Int) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Just $ fmap (fromInteger . toInteger) (readRef s), - providerToInt = Just $ readRef s, - providerToString = Just $ fmap show (readRef s), - providerSignal = Just $ refChanged_ s }] } - -instance Series (Ref String) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToInt = Nothing, - providerToString = Just $ readRef s, - providerSignal = Just $ refChanged_ s }] } - -instance Series (Var Double) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Just $ readVar s, - providerToInt = Nothing, - providerToString = Just $ fmap show (readVar s), - providerSignal = Just $ varChanged_ s }] } - -instance Series (Var Int) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Just $ fmap (fromInteger . toInteger) (readVar s), - providerToInt = Just $ readVar s, - providerToString = Just $ fmap show (readVar s), - providerSignal = Just $ varChanged_ s }] } - -instance Series (Var String) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToInt = Nothing, - providerToString = Just $ readVar s, - providerSignal = Just $ varChanged_ s }] } - -instance Series (UVar Double) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Just $ readUVar s, - providerToInt = Nothing, - providerToString = Just $ fmap show (readUVar s), - providerSignal = Just $ uvarChanged_ s }] } - -instance Series (UVar Int) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Just $ fmap (fromInteger . toInteger) (readUVar s), - providerToInt = Just $ readUVar s, - providerToString = Just $ fmap show (readUVar s), - providerSignal = Just $ uvarChanged_ s }] } - -instance Series s => Series [s] where - - seriesEntity name s = - SeriesEntity { seriesProviders = - join $ forM (zip [1..] 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 (assocs s) $ \(i, s) -> - let name' = name ++ "[" ++ show i ++ "]" - in seriesProviders $ seriesEntity name' s } + +{-# LANGUAGE FlexibleInstances #-} + +-- | +-- Module : Simulation.Aivika.Experiment +-- Copyright : Copyright (c) 2012, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.4.1 +-- +-- The module defines the simulation experiments. They automate +-- the process of generating and analyzing the results. Moreover, +-- this module is open to extensions, allowing you to define +-- your own output views for the simulations results, for example, +-- such views that would allow saving the results in PDF or as +-- charts. To decrease the number of dependencies, such possible +-- extenstions are not included in this package, although simple +-- views are provided. +-- + +module Simulation.Aivika.Experiment + (Experiment(..), + defaultExperiment, + runExperiment, + runExperimentParallel, + ExperimentData(..), + experimentDataInStartTime, + experimentSeriesProviders, + experimentMixedSignal, + Series(..), + SeriesEntity(..), + SeriesProvider(..), + View(..), + Generator(..), + Reporter(..), + DirectoryName(..), + resolveDirectoryName, + FileName(..), + resolveFileName) where + +import Control.Monad +import Control.Monad.State +import Control.Concurrent.ParallelIO.Local + +import qualified Data.Map as M +import Data.Array +import Data.Maybe +import Data.Monoid +import Data.String.Utils (replace) + +import System.IO +import System.Directory +import System.FilePath (combine) + +import GHC.Conc (getNumCapabilities) + +import Simulation.Aivika.Dynamics +import Simulation.Aivika.Dynamics.Simulation +import Simulation.Aivika.Dynamics.Signal +import Simulation.Aivika.Dynamics.Ref +import Simulation.Aivika.Dynamics.Var +import Simulation.Aivika.Dynamics.UVar +import Simulation.Aivika.Dynamics.EventQueue +import Simulation.Aivika.Dynamics.Parameter + +import Simulation.Aivika.Experiment.HtmlWriter + +-- | It defines the simulation experiment. +data Experiment = + Experiment { experimentSpecs :: Specs, + -- ^ The simulation specs for the experiment. + experimentRunCount :: Int, + -- ^ How many simulation runs should be launched. + experimentDirectoryName :: DirectoryName, + -- ^ The directory in which the output results should be saved. + experimentTitle :: String, + -- ^ The experiment title. + experimentDescription :: String, + -- ^ The experiment description. + experimentVerbose :: Bool, + -- ^ Whether the process of generating the results is verbose. + experimentGenerators :: [Generator], + -- ^ The experiment generators. + experimentIndexHtml :: Experiment -> [Reporter] -> FilePath -> IO () + -- ^ Create the @index.html@ file after the simulation is finished + -- in the specified directory. + } + +-- | The default experiment. +defaultExperiment :: Experiment +defaultExperiment = + Experiment { experimentSpecs = Specs 0 10 0.01 RungeKutta4, + experimentRunCount = 1, + experimentDirectoryName = UniqueDirectoryName "experiment", + experimentTitle = "Simulation Experiment", + experimentDescription = "", + experimentVerbose = True, + experimentGenerators = [], + experimentIndexHtml = createIndexHtml } + +-- | This is a generator of the reporter. +data Generator = + Generator { generateReporter :: Experiment -> FilePath -> IO Reporter + -- ^ Generate a reporter for the specified directory, + -- where the @index.html@ file will be saved for the + -- current simulation experiment. + } + +-- | 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 View v where + + -- | Create a generator of the reporter. + outputView :: v -> Generator + +-- | Represents the series. It is usually something, or +-- an array of something, or a list of such values which +-- can be simulated. +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 (Dynamics Double), + -- ^ Try to return the data as double values. + providerToInt :: Maybe (Dynamics Int), + -- ^ Try to return the data as integers. + providerToString :: Maybe (Dynamics 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. + } + +-- | It describes the source simulation data used in the experiment. +data ExperimentData = + ExperimentData { experimentQueue :: EventQueue, + -- ^ Return the event queue. + 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. + } + +-- | Prepare data for the simulation experiment in start time from the series +-- with the specified labels. +experimentDataInStartTime :: EventQueue -> [(String, SeriesEntity)] -> Simulation ExperimentData +experimentDataInStartTime q m = runDynamicsInStartTime d where + d = do signalInIntegTimes <- newSignalInIntegTimes q + signalInStartTime <- newSignalInStartTime q + signalInStopTime <- newSignalInStopTime q + let series = M.fromList m + return ExperimentData { experimentQueue = q, + 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 Reporter = + Reporter { reporterInitialise :: IO (), + -- ^ Initialise the reporting before + -- the simulation runs are started. + reporterFinalise :: IO (), + -- ^ Finalise the reporting after + -- all simulation runs are finished. + reporterSimulate :: ExperimentData -> + Dynamics (Dynamics ()), + -- ^ 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. + } + +-- | Run the simulation experiment sequentially. For example, +-- it can be a Monte-Carlo simulation dependentent on the external +-- 'Parameter' values. +runExperiment :: Experiment -> Simulation ExperimentData -> IO () +runExperiment = runExperimentWithExecutor sequence_ + +-- | Run the simulation experiment parallelly. +-- +-- Make sure that you compile with @-threaded@ and supply @+RTS -N2 -RTS@ +-- to the generated Haskell executable on dual core processor, +-- or you won't get any parallelism. Generally, the mentioned +-- @N@ parameter should correspond to the number of cores for +-- your processor. +runExperimentParallel :: Experiment -> Simulation ExperimentData -> IO () +runExperimentParallel = runExperimentWithExecutor executor + where executor tasks = + do n <- getNumCapabilities + withPool n $ \pool -> + parallel_ pool tasks + +-- | Run the simulation experiment with the specified executor. +runExperimentWithExecutor :: ([IO ()] -> IO ()) -> + Experiment -> + Simulation ExperimentData -> IO () +runExperimentWithExecutor executor e simulation = + do let specs = experimentSpecs e + runCount = experimentRunCount e + dirName = experimentDirectoryName e + generators = experimentGenerators e + path <- resolveDirectoryName Nothing dirName M.empty + when (experimentVerbose e) $ + do putStr "Using directory " + putStrLn path + createDirectoryIfMissing True path + reporters <- mapM (\x -> generateReporter x e path) + generators + forM_ reporters reporterInitialise + let simulate :: Simulation () + simulate = + do d <- simulation + fs <- runDynamicsInStartTime $ + forM reporters $ \reporter -> + reporterSimulate reporter d + runDynamicsInStopTime $ + do updateSignal $ + experimentMixedSignal d $ + join $ map seriesProviders $ + M.elems $ experimentSeries d + sequence_ fs + executor $ runSimulations simulate specs runCount + forM_ reporters reporterFinalise + experimentIndexHtml e e reporters path + return () + +-- | Create an index HTML file. +createIndexHtml :: Experiment -> [Reporter] -> FilePath -> IO () +createIndexHtml e reporters path = + do let html :: HtmlWriter () + html = + writeHtmlDocumentWithTitle (experimentTitle e) $ + do writeHtmlList $ + forM_ (zip [1..] reporters) $ \(i, reporter) -> + reporterTOCHtml 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 + writeFile file (contents []) + when (experimentVerbose e) $ + do putStr "Generated file " + putStrLn file + +-- | Specifies the directory name, unique or writable. +data DirectoryName = WritableDirectoryName String + -- ^ The directory which is overwritten in + -- case if it existed before. + | UniqueDirectoryName String + -- ^ The directory which is always unique, + -- when a prefix is added to the name + -- in case of need. + +-- | Specifies the file name, unique or writable. +data FileName = WritableFileName String String + -- ^ The file which is overwritten in + -- case if it existed before. The first + -- field defines a name or its prototype. + -- The second field is the file extension. + | UniqueFileName String String + -- ^ The file which is always unique, + -- when a prefix is added to the name + -- in case of need. The first field + -- defines a name or its prototype. + -- The second field is the file exension. + +-- | Resolve the directory name relative to the passed in directory +-- as the first argument, replacing the specified strings according the map. +resolveDirectoryName :: Maybe FilePath -> DirectoryName -> M.Map String String -> IO String +resolveDirectoryName dir (WritableDirectoryName name) map = + return $ replaceName (combineName dir name) map +resolveDirectoryName dir (UniqueDirectoryName name) map = + let x = replaceName name map + loop y i = + do let n = combineName dir y + f1 <- doesFileExist n + f2 <- doesDirectoryExist n + if f1 || f2 + then loop (x ++ "(" ++ show i ++ ")") (i + 1) + else return n + in loop x 2 + +-- | Resolve the file name relative to the passed in directory +-- as the first argument, replacing the specified strings according the map. +resolveFileName :: Maybe FilePath -> FileName -> M.Map String String -> IO String +resolveFileName dir (WritableFileName name ext) map = + return $ replaceName (combineName dir name ++ ext) map +resolveFileName dir (UniqueFileName name ext) map = + let x = replaceName name map + loop y i = + do let n = combineName dir y ++ ext + f1 <- doesFileExist n + f2 <- doesDirectoryExist n + if f1 || f2 + then loop (x ++ "(" ++ show i ++ ")") (i + 1) + else return n + in loop x 2 + +-- | Replace the name according the specified table. +replaceName :: String -> M.Map String String -> String +replaceName name map = name' where + ((), name') = flip runState name $ + forM_ (M.assocs map) $ \(k, v) -> + do a <- get + put $ replace k v a + +-- | Combine the file name with the directory name. +combineName :: Maybe String -> String -> String +combineName dir name = + case dir of + Nothing -> name + Just dir -> combine dir name + +instance Series (Simulation Double) where + + seriesEntity name s = + SeriesEntity { seriesProviders = + [SeriesProvider { providerName = name, + providerToDouble = Just $ liftSimulation s, + providerToInt = Nothing, + providerToString = Just $ liftSimulation $ fmap show s, + providerSignal = Nothing }] } + +instance Series (Simulation Int) where + + seriesEntity name s = + SeriesEntity { seriesProviders = + [SeriesProvider { providerName = name, + providerToDouble = Just $ liftSimulation $ fmap fromIntegral s, + providerToInt = Just $ liftSimulation s, + providerToString = Just $ liftSimulation $ fmap show s, + providerSignal = Nothing }] } + +instance Series (Simulation String) where + + seriesEntity name s = + SeriesEntity { seriesProviders = + [SeriesProvider { providerName = name, + providerToDouble = Nothing, + providerToInt = Nothing, + providerToString = Just $ liftSimulation s, + providerSignal = Nothing }] } + +instance Series (Dynamics Double) where + + seriesEntity name s = + SeriesEntity { seriesProviders = + [SeriesProvider { providerName = name, + providerToDouble = Just s, + providerToInt = Nothing, + providerToString = Just $ fmap show s, + providerSignal = Nothing }] } + +instance Series (Dynamics Int) where + + seriesEntity name s = + SeriesEntity { seriesProviders = + [SeriesProvider { providerName = name, + providerToDouble = Just $ fmap fromIntegral s, + providerToInt = Just s, + providerToString = Just $ fmap show s, + providerSignal = Nothing }] } + +instance Series (Dynamics String) where + + seriesEntity name s = + SeriesEntity { seriesProviders = + [SeriesProvider { providerName = name, + providerToDouble = Nothing, + providerToInt = Nothing, + providerToString = Just s, + providerSignal = Nothing }] } + +instance Series (Ref Double) where + + seriesEntity name s = + SeriesEntity { seriesProviders = + [SeriesProvider { providerName = name, + providerToDouble = Just $ readRef s, + providerToInt = Nothing, + providerToString = Just $ fmap show (readRef s), + providerSignal = Just $ refChanged_ s }] } + +instance Series (Ref Int) where + + seriesEntity name s = + SeriesEntity { seriesProviders = + [SeriesProvider { providerName = name, + providerToDouble = Just $ fmap fromIntegral (readRef s), + providerToInt = Just $ readRef s, + providerToString = Just $ fmap show (readRef s), + providerSignal = Just $ refChanged_ s }] } + +instance Series (Ref String) where + + seriesEntity name s = + SeriesEntity { seriesProviders = + [SeriesProvider { providerName = name, + providerToDouble = Nothing, + providerToInt = Nothing, + providerToString = Just $ readRef s, + providerSignal = Just $ refChanged_ s }] } + +instance Series (Var Double) where + + seriesEntity name s = + SeriesEntity { seriesProviders = + [SeriesProvider { providerName = name, + providerToDouble = Just $ readVar s, + providerToInt = Nothing, + providerToString = Just $ fmap show (readVar s), + providerSignal = Just $ varChanged_ s }] } + +instance Series (Var Int) where + + seriesEntity name s = + SeriesEntity { seriesProviders = + [SeriesProvider { providerName = name, + providerToDouble = Just $ fmap fromIntegral (readVar s), + providerToInt = Just $ readVar s, + providerToString = Just $ fmap show (readVar s), + providerSignal = Just $ varChanged_ s }] } + +instance Series (Var String) where + + seriesEntity name s = + SeriesEntity { seriesProviders = + [SeriesProvider { providerName = name, + providerToDouble = Nothing, + providerToInt = Nothing, + providerToString = Just $ readVar s, + providerSignal = Just $ varChanged_ s }] } + +instance Series (UVar Double) where + + seriesEntity name s = + SeriesEntity { seriesProviders = + [SeriesProvider { providerName = name, + providerToDouble = Just $ readUVar s, + providerToInt = Nothing, + providerToString = Just $ fmap show (readUVar s), + providerSignal = Just $ uvarChanged_ s }] } + +instance Series (UVar Int) where + + seriesEntity name s = + SeriesEntity { seriesProviders = + [SeriesProvider { providerName = name, + providerToDouble = Just $ fmap fromIntegral (readUVar s), + providerToInt = Just $ readUVar s, + providerToString = Just $ fmap show (readUVar s), + providerSignal = Just $ uvarChanged_ s }] } + +instance Series s => Series [s] where + + seriesEntity name s = + SeriesEntity { seriesProviders = + join $ forM (zip [1..] 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 (assocs s) $ \(i, s) -> + let name' = name ++ "[" ++ show i ++ "]" + in seriesProviders $ seriesEntity name' s } diff --git a/Simulation/Aivika/Experiment/Histogram.hs b/Simulation/Aivika/Experiment/Histogram.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Experiment/Histogram.hs @@ -0,0 +1,175 @@ + +-- | This module computes the histogram by the +-- specified data and strategy applied for such computing. +-- +-- The code in this module is essentially based on the +-- package +-- by Mike Izbicki, who kindly agreed to re-license +-- his library under BSD3, which allowed me to use his +-- code and comments with some modifications. + +module Simulation.Aivika.Experiment.Histogram + (-- * Creating Histograms + Histogram(..), + histogram, + histogramBinSize, + histogramNumBins, + -- * Binning Strategies + BinningStrategy(..), + binSturges, + binDoane, + binSqrt, + binScott) where + +import Data.List +import Data.Monoid +import qualified Data.Map as Map + +import Numeric + +--- +import System.IO.Unsafe +--- + +------------------------------------------------------------------------------- + +-- | Holds all the information needed to plot the histogram +-- for a list of different series. Each series produces its +-- own item in the resuling @[Int]@ list that may contain +-- zeros. +type Histogram = [(Double, [Int])] + +------------------------------------------------------------------------------- +-- Bin counters; check out http://en.wikipedia.org/wiki/Histogram#Number_of_bins_and_width + +-- | The strategy applied to calculate the histogram bins. +type BinningStrategy = [Double] -> Int + +-- | This is only a helper function to convert strategies that +-- specify bin width into strategies that specify the number of bins. +stratFromBinWidth :: [Double] -> Double -> Int +stratFromBinWidth xs h = ceiling $ (maximum xs - minimum xs) / h + +-- | Sturges' binning strategy is the least computational work, +-- but recommended for only normal data. +binSturges :: BinningStrategy +binSturges xs = ceiling $ logBase 2 n + 1 + where n = fromIntegral $ length xs + +-- | Doane's binning strategy extends Sturges' for non-normal data. +-- It takes a little more time because it must calculate the kurtosis +-- (peakkiness) of the distribution. +binDoane :: BinningStrategy +binDoane xs = ceiling $ 1 + log n + log (1 + a * ((n/6)**(1/2))) + where + n = fromIntegral $ length xs + a = kurtosis xs + +-- | Using the sqrt of the number of samples is not supported by any +-- theory, but is commonly used by excel and other histogram making software. +binSqrt :: BinningStrategy +binSqrt xs = round $ sqrt n + where + n = fromIntegral $ length xs + +-- | Scott's rule is the optimal solution for normal data, but requires +-- more computation than Sturges'. +binScott :: BinningStrategy +binScott xs = stratFromBinWidth xs $ 3.5 * stddev xs / (n**(1/3)) + where + n = fromIntegral $ length xs + +------------------------------------------------------------------------------- +-- create the histogram data + +-- | Creates a histogram by specifying the list of series. Call it with one of +-- the binning strategies that is appropriate to the type of data you have. +-- If you don't know, then try using 'binSturges'. +histogram :: BinningStrategy -> [[Double]] -> Histogram +histogram strat xs = histogramNumBins (strat $ concat xs) xs + +-- | Create a histogram by specifying the exact bin size. +-- You probably don't want to use this function, and should use histogram +-- with an appropriate binning strategy. +histogramBinSize :: Double -> [[Double]] -> Histogram +histogramBinSize size = combineBins . map (histBins size . bin size) + +-- | Create a histogram by the specified approximated number of bins. +-- You probably don't want to use this function, and should use +-- histogram with an appropriate binning strategy. +histogramNumBins :: Int -> [[Double]] -> Histogram +histogramNumBins n xs = + histogramBinSize size xs + where + size = fromIntegral (firstdigit diff) * (10 ** fromIntegral (exponent10 diff)) + diff = if diff_test > 0 + then diff_test + else 1 + diff_test = (maximum (map maximum xs) - + minimum (map minimum xs)) / fromIntegral (max 1 n) + + firstdigit dbl = floor $ dbl / (10 ** fromIntegral (exponent10 dbl)) + exponent10 dbl = floor $ logBase 10 dbl + +-- | It does all the binning for the histogram. +histBins :: Double -> [Double] -> [(Double, Int)] +histBins size xs = [ (head l, length l) | l <- group (sort xs) ] + +-- | It "rounds" every number into the closest number below it +-- that is divisible by size. +bin :: Double -> [Double] -> [Double] +bin size xs @ [_] = xs +bin size xs = map (\x -> size * fromIntegral (floor (x / size)) + size / 2) xs + +-- | Combine bins from different histograms (optimized version). +combineBins :: [[(Double, Int)]] -> [(Double, [Int])] +combineBins [xs] = map (\(t, n) -> (t, [n])) xs +combineBins xss = combineBins' xss + +-- | Combine bins from different histograms (generic version). +combineBins' :: [[(Double, Int)]] -> [(Double, [Int])] +combineBins' xs = map (merging . sorting) $ + groupping $ ordering $ concat $ numbering xs + where numbering = zipWith (curry indexing) [1..] + indexing (i, x) = map (\(t, n) -> (i, t, n)) x + ordering = sortBy $ \(_, t1, _) (_, t2, _) -> compare t1 t2 + groupping = groupBy $ \(_, t1, _) (_, t2, _) -> t1 == t2 + sorting = sortBy $ \(i1, _, _) (i2, _, _) -> compare i1 i2 + merging zs @ ((_, t, _) : _) = merging' zs t 1 [] + merging' [] t k acc + | k <= count = merging' [] t (k + 1) (0 : acc) + | k > count = (t, reverse acc) + merging' zs @ ((i, _, n) : xs) t k acc + | i == k = merging' xs t (k + 1) (n : acc) + | i > k = merging' zs t (k + 1) (0 : acc) + count = length xs + +------------------------------------------------------------------------------ +-- simple math functions +-- taken from package hstats, which wouldn't fully compile + +-- | Numerically stable mean. +mean :: Floating a => [a] -> a +mean x = fst $ foldl' (\(m, n) x -> (m+(x-m)/(n+1),n+1)) (0,0) x + +-- | Standard deviation of sample. +stddev :: (Floating a) => [a] -> a +stddev xs = sqrt $ var xs + +-- | Sample variance. +var :: (Floating a) => [a] -> a +var xs = var' 0 0 0 xs / fromIntegral (length xs - 1) + where + var' _ _ s [] = s + var' m n s (x:xs) = var' nm (n + 1) (s + delta * (x - nm)) xs + where + delta = x - m + nm = m + delta / fromIntegral (n + 1) + +-- | kurtosis is taken from wikipedia's definition. +kurtosis :: (Floating a) => [a] -> a +kurtosis xs = ((1/n) * sum [(x-x_bar)^4 | x <- xs]) + / ((1/n) * sum [(x-x_bar)^2 | x <- xs])^2 -3 + where + n = fromIntegral $ length xs + x_bar = mean xs 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,384 +1,384 @@ - --- | --- Module : Simulation.Aivika.Experiment.HtmlWriter --- Copyright : Copyright (c) 2012, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.4.1 --- --- This is an utility module that provides an HTML writer. --- - -module Simulation.Aivika.Experiment.HtmlWriter - (HtmlWriter, - runHtmlWriter, - composeHtml, - writeHtml, - writeHtmlLn, - writeHtmlText, - writeHtmlParagraph, - writeHtmlParagraphWithId, - writeHtmlHeader1, - writeHtmlHeader1WithId, - writeHtmlHeader2, - writeHtmlHeader2WithId, - writeHtmlHeader3, - writeHtmlHeader3WithId, - writeHtmlHeader4, - writeHtmlHeader4WithId, - writeHtmlHeader5, - writeHtmlHeader5WithId, - writeHtmlHeader6, - writeHtmlHeader6WithId, - writeHtmlBreak, - writeHtmlLink, - writeHtmlImage, - writeHtmlList, - writeHtmlListItem, - writeHtmlDocumentWithTitle, - encodeHtmlText) where - -import Control.Monad -import Control.Monad.Trans - -import Network.URI - --- | It writes fast an HTML code. -newtype HtmlWriter a = - HtmlWriter { runHtmlWriter :: ShowS -> IO (a, ShowS) - -- ^ Run the HTML writer monad. - } - -instance Monad HtmlWriter where - - return a = HtmlWriter $ \f -> return (a, f) - - (HtmlWriter m) >>= k = HtmlWriter $ \f -> - do (a, f') <- m f - let HtmlWriter m' = k a - m' f' - -instance MonadIO HtmlWriter where - - liftIO m = HtmlWriter $ \f -> - do x <- m - return (x, f) - --- | Write the HTML code. -writeHtml :: String -> HtmlWriter () -writeHtml code = - HtmlWriter $ \f -> return ((), f . (code ++)) - --- | Write the HTML code. -writeHtmlLn :: String -> HtmlWriter () -writeHtmlLn code = - do writeHtml code - writeHtml "\n" - --- | Write the text in HTML. -writeHtmlText :: String -> HtmlWriter () -writeHtmlText text = - HtmlWriter $ \f -> return ((), f . (encodeHtmlText text ++)) - --- | Compose the HTML applying the corresponded transformation. -composeHtml :: ShowS -> HtmlWriter () -composeHtml g = - HtmlWriter $ \f -> return ((), f . g) - --- | Write the HTML link with the specified URI and contents. -writeHtmlLink :: String -> HtmlWriter () -> HtmlWriter () -writeHtmlLink uri inner = - do writeHtml "" - inner - writeHtml "" - --- | Write the HTML image with the specified URI. -writeHtmlImage :: String -> HtmlWriter () -writeHtmlImage uri = - do writeHtml "" - --- | Write the @\@ element with the specified contents. -writeHtmlParagraph :: HtmlWriter () -> HtmlWriter () -writeHtmlParagraph inner = - do writeHtml "

" - inner - writeHtml "

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

" - inner - writeHtml "

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

" - inner - writeHtml "

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

" - inner - writeHtml "

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

" - inner - writeHtml "

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

" - inner - writeHtml "

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

" - inner - writeHtml "

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

" - inner - writeHtml "

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

" - inner - writeHtml "

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

" - inner - writeHtml "

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

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

    " - writeHtml "" - writeHtml "" - --- | Escape special HTML characters in the 'String'. --- It is based on one function from package Web-Encodings, --- which is licensed under BSD3 but obsolete now. -encodeHtmlText :: String -> String -encodeHtmlText x = join $ map encodeHtmlChar x - --- | Escape a character. -encodeHtmlChar :: Char -> String -encodeHtmlChar '<' = "<" -encodeHtmlChar '>' = ">" -encodeHtmlChar '&' = "&" -encodeHtmlChar '"' = """ -encodeHtmlChar '\'' = "'" -encodeHtmlChar c = [c] - --- | Write the CSS styles -writeHtmlCss :: HtmlWriter () -writeHtmlCss = - do writeHtmlLn "" + +-- | +-- Module : Simulation.Aivika.Experiment.HtmlWriter +-- Copyright : Copyright (c) 2012, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.4.1 +-- +-- This is an utility module that provides an HTML writer. +-- + +module Simulation.Aivika.Experiment.HtmlWriter + (HtmlWriter, + runHtmlWriter, + composeHtml, + writeHtml, + writeHtmlLn, + writeHtmlText, + writeHtmlParagraph, + writeHtmlParagraphWithId, + writeHtmlHeader1, + writeHtmlHeader1WithId, + writeHtmlHeader2, + writeHtmlHeader2WithId, + writeHtmlHeader3, + writeHtmlHeader3WithId, + writeHtmlHeader4, + writeHtmlHeader4WithId, + writeHtmlHeader5, + writeHtmlHeader5WithId, + writeHtmlHeader6, + writeHtmlHeader6WithId, + writeHtmlBreak, + writeHtmlLink, + writeHtmlImage, + writeHtmlList, + writeHtmlListItem, + writeHtmlDocumentWithTitle, + encodeHtmlText) where + +import Control.Monad +import Control.Monad.Trans + +import Network.URI + +-- | It writes fast an HTML code. +newtype HtmlWriter a = + HtmlWriter { runHtmlWriter :: ShowS -> IO (a, ShowS) + -- ^ Run the HTML writer monad. + } + +instance Monad HtmlWriter where + + return a = HtmlWriter $ \f -> return (a, f) + + (HtmlWriter m) >>= k = HtmlWriter $ \f -> + do (a, f') <- m f + let HtmlWriter m' = k a + m' f' + +instance MonadIO HtmlWriter where + + liftIO m = HtmlWriter $ \f -> + do x <- m + return (x, f) + +-- | Write the HTML code. +writeHtml :: String -> HtmlWriter () +writeHtml code = + HtmlWriter $ \f -> return ((), f . (code ++)) + +-- | Write the HTML code. +writeHtmlLn :: String -> HtmlWriter () +writeHtmlLn code = + do writeHtml code + writeHtml "\n" + +-- | Write the text in HTML. +writeHtmlText :: String -> HtmlWriter () +writeHtmlText text = + HtmlWriter $ \f -> return ((), f . (encodeHtmlText text ++)) + +-- | Compose the HTML applying the corresponded transformation. +composeHtml :: ShowS -> HtmlWriter () +composeHtml g = + HtmlWriter $ \f -> return ((), f . g) + +-- | Write the HTML link with the specified URI and contents. +writeHtmlLink :: String -> HtmlWriter () -> HtmlWriter () +writeHtmlLink uri inner = + do writeHtml "" + inner + writeHtml "" + +-- | Write the HTML image with the specified URI. +writeHtmlImage :: String -> HtmlWriter () +writeHtmlImage uri = + do writeHtml "" + +-- | Write the @\@ element with the specified contents. +writeHtmlParagraph :: HtmlWriter () -> HtmlWriter () +writeHtmlParagraph inner = + do writeHtml "

    " + inner + writeHtml "

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

    " + inner + writeHtml "

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

    " + inner + writeHtml "

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

    " + inner + writeHtml "

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

    " + inner + writeHtml "

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

    " + inner + writeHtml "

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

    " + inner + writeHtml "

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

    " + inner + writeHtml "

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

    " + inner + writeHtml "

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

    " + inner + writeHtml "

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

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

    " + writeHtml "" + writeHtml "" + +-- | Escape special HTML characters in the 'String'. +-- It is based on one function from package Web-Encodings, +-- which is licensed under BSD3 but obsolete now. +encodeHtmlText :: String -> String +encodeHtmlText x = join $ map encodeHtmlChar x + +-- | Escape a character. +encodeHtmlChar :: Char -> String +encodeHtmlChar '<' = "<" +encodeHtmlChar '>' = ">" +encodeHtmlChar '&' = "&" +encodeHtmlChar '"' = """ +encodeHtmlChar '\'' = "'" +encodeHtmlChar c = [c] + +-- | Write the CSS styles +writeHtmlCss :: HtmlWriter () +writeHtmlCss = + do writeHtmlLn "" diff --git a/Simulation/Aivika/Experiment/LastValueView.hs b/Simulation/Aivika/Experiment/LastValueView.hs --- a/Simulation/Aivika/Experiment/LastValueView.hs +++ b/Simulation/Aivika/Experiment/LastValueView.hs @@ -1,178 +1,178 @@ - --- | --- Module : Simulation.Aivika.Experiment.LastValueView --- Copyright : Copyright (c) 2012, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.4.1 --- --- The module defines 'LastValueView' that shows the last values --- for the simulation variables. --- - -module Simulation.Aivika.Experiment.LastValueView - (LastValueView(..), - defaultLastValueView) where - -import Control.Monad -import Control.Monad.Trans - -import qualified Data.Map as M -import Data.IORef -import Data.Maybe - -import Data.String.Utils (replace) - -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 shows the last values of the simulation --- variables. -data LastValueView = - LastValueView { lastValueTitle :: String, - -- ^ The title for the view. - lastValueRunTitle :: String, - -- ^ The run title for the view. It may include - -- special variables @$RUN_INDEX@, @$RUN_COUNT@ and - -- @$TITLE@. - -- - -- An example is - -- - -- @ - -- lastValueRunTitle = \"$TITLE / Run $RUN_INDEX of $RUN_COUNT\" - -- @ - lastValueDescription :: String, - -- ^ The description for the view. - lastValueFormatter :: ShowS, - -- ^ It transforms data before they will be shown. - lastValueSeries :: [String] - -- ^ It contains the labels of the observed series. - } - --- | This is the default view. -defaultLastValueView :: LastValueView -defaultLastValueView = - LastValueView { lastValueTitle = "The Last Values", - lastValueRunTitle = "$TITLE / Run $RUN_INDEX of $RUN_COUNT", - lastValueDescription = [], - lastValueFormatter = id, - lastValueSeries = [] } - -instance View LastValueView where - - outputView v = - let reporter exp dir = - do st <- newLastValues v exp - return Reporter { reporterInitialise = return (), - reporterFinalise = return (), - reporterSimulate = simulateLastValues st, - reporterTOCHtml = lastValueTOCHtml st, - reporterHtml = lastValueHtml st } - in Generator { generateReporter = reporter } - --- | The state of the view. -data LastValueViewState = - LastValueViewState { lastValueView :: LastValueView, - lastValueExperiment :: Experiment, - lastValueMap :: M.Map Int (IORef [(String, String)]) } - --- | Create a new state of the view. -newLastValues :: LastValueView -> Experiment -> IO LastValueViewState -newLastValues view exp = - do let n = experimentRunCount exp - rs <- forM [0..(n - 1)] $ \i -> newIORef [] - let m = M.fromList $ zip [0..(n - 1)] rs - return LastValueViewState { lastValueView = view, - lastValueExperiment = exp, - lastValueMap = m } - --- | Get the last values during the simulation. -simulateLastValues :: LastValueViewState -> ExperimentData -> Dynamics (Dynamics ()) -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) - i <- liftSimulation simulationIndex - t <- time - 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_ (experimentSignalInStopTime expdata) $ \t -> - do let r = fromJust $ M.lookup (i - 1) (lastValueMap st) - output <- forM input $ \(name, input) -> - do x <- input - return (name, x) - liftIO $ writeIORef r output - return $ return () - --- | Get the HTML code. -lastValueHtml :: LastValueViewState -> Int -> HtmlWriter () -lastValueHtml st index = - let n = experimentRunCount $ lastValueExperiment st - in if n == 1 - then lastValueHtmlSingle st index - else lastValueHtmlMultiple st index - --- | Get the HTML code for a single run. -lastValueHtmlSingle :: LastValueViewState -> Int -> HtmlWriter () -lastValueHtmlSingle st index = - do header st index - let r = fromJust $ M.lookup 0 (lastValueMap st) - pairs <- liftIO $ readIORef r - forM_ pairs $ \pair -> - formatPair pair (lastValueFormatter $ lastValueView st) - --- | Get the HTML code for multiple runs -lastValueHtmlMultiple :: LastValueViewState -> Int -> HtmlWriter () -lastValueHtmlMultiple st index = - do header st index - let n = experimentRunCount $ lastValueExperiment st - forM_ [0..(n - 1)] $ \i -> - do let subtitle = - replace "$RUN_INDEX" (show $ i + 1) $ - replace "$RUN_COUNT" (show n) $ - replace "$TITLE" (lastValueTitle $ lastValueView st) - (lastValueRunTitle $ lastValueView st) - writeHtmlHeader4 $ - writeHtmlText subtitle - let r = fromJust $ M.lookup i (lastValueMap st) - pairs <- liftIO $ readIORef r - forM_ pairs $ \pair -> - formatPair pair (lastValueFormatter $ lastValueView st) - -header :: LastValueViewState -> Int -> HtmlWriter () -header st index = - do writeHtmlHeader3WithId ("id" ++ show index) $ - writeHtmlText (lastValueTitle $ lastValueView st) - let description = lastValueDescription $ lastValueView st - unless (null description) $ - writeHtmlParagraph $ - writeHtmlText description - -formatPair :: (String, String) -> ShowS -> HtmlWriter () -formatPair (name, value) formatter = - writeHtmlParagraph $ - do writeHtmlText name - writeHtmlText " = " - writeHtmlText $ formatter value - --- | Get the TOC item -lastValueTOCHtml :: LastValueViewState -> Int -> HtmlWriter () -lastValueTOCHtml st index = - writeHtmlListItem $ - writeHtmlLink ("#id" ++ show index) $ - writeHtmlText (lastValueTitle $ lastValueView st) + +-- | +-- Module : Simulation.Aivika.Experiment.LastValueView +-- Copyright : Copyright (c) 2012, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.4.1 +-- +-- The module defines 'LastValueView' that shows the last values +-- for the simulation variables. +-- + +module Simulation.Aivika.Experiment.LastValueView + (LastValueView(..), + defaultLastValueView) where + +import Control.Monad +import Control.Monad.Trans + +import qualified Data.Map as M +import Data.IORef +import Data.Maybe + +import Data.String.Utils (replace) + +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 shows the last values of the simulation +-- variables. +data LastValueView = + LastValueView { lastValueTitle :: String, + -- ^ The title for the view. + lastValueRunTitle :: String, + -- ^ The run title for the view. It may include + -- special variables @$RUN_INDEX@, @$RUN_COUNT@ and + -- @$TITLE@. + -- + -- An example is + -- + -- @ + -- lastValueRunTitle = \"$TITLE / Run $RUN_INDEX of $RUN_COUNT\" + -- @ + lastValueDescription :: String, + -- ^ The description for the view. + lastValueFormatter :: ShowS, + -- ^ It transforms data before they will be shown. + lastValueSeries :: [String] + -- ^ It contains the labels of the observed series. + } + +-- | This is the default view. +defaultLastValueView :: LastValueView +defaultLastValueView = + LastValueView { lastValueTitle = "The Last Values", + lastValueRunTitle = "$TITLE / Run $RUN_INDEX of $RUN_COUNT", + lastValueDescription = [], + lastValueFormatter = id, + lastValueSeries = [] } + +instance View LastValueView where + + outputView v = + let reporter exp dir = + do st <- newLastValues v exp + return Reporter { reporterInitialise = return (), + reporterFinalise = return (), + reporterSimulate = simulateLastValues st, + reporterTOCHtml = lastValueTOCHtml st, + reporterHtml = lastValueHtml st } + in Generator { generateReporter = reporter } + +-- | The state of the view. +data LastValueViewState = + LastValueViewState { lastValueView :: LastValueView, + lastValueExperiment :: Experiment, + lastValueMap :: M.Map Int (IORef [(String, String)]) } + +-- | Create a new state of the view. +newLastValues :: LastValueView -> Experiment -> IO LastValueViewState +newLastValues view exp = + do let n = experimentRunCount exp + rs <- forM [0..(n - 1)] $ \i -> newIORef [] + let m = M.fromList $ zip [0..(n - 1)] rs + return LastValueViewState { lastValueView = view, + lastValueExperiment = exp, + lastValueMap = m } + +-- | Get the last values during the simulation. +simulateLastValues :: LastValueViewState -> ExperimentData -> Dynamics (Dynamics ()) +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) + i <- liftSimulation simulationIndex + t <- time + 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_ (experimentSignalInStopTime expdata) $ \t -> + do let r = fromJust $ M.lookup (i - 1) (lastValueMap st) + output <- forM input $ \(name, input) -> + do x <- input + return (name, x) + liftIO $ writeIORef r output + return $ return () + +-- | Get the HTML code. +lastValueHtml :: LastValueViewState -> Int -> HtmlWriter () +lastValueHtml st index = + let n = experimentRunCount $ lastValueExperiment st + in if n == 1 + then lastValueHtmlSingle st index + else lastValueHtmlMultiple st index + +-- | Get the HTML code for a single run. +lastValueHtmlSingle :: LastValueViewState -> Int -> HtmlWriter () +lastValueHtmlSingle st index = + do header st index + let r = fromJust $ M.lookup 0 (lastValueMap st) + pairs <- liftIO $ readIORef r + forM_ pairs $ \pair -> + formatPair pair (lastValueFormatter $ lastValueView st) + +-- | Get the HTML code for multiple runs +lastValueHtmlMultiple :: LastValueViewState -> Int -> HtmlWriter () +lastValueHtmlMultiple st index = + do header st index + let n = experimentRunCount $ lastValueExperiment st + forM_ [0..(n - 1)] $ \i -> + do let subtitle = + replace "$RUN_INDEX" (show $ i + 1) $ + replace "$RUN_COUNT" (show n) $ + replace "$TITLE" (lastValueTitle $ lastValueView st) + (lastValueRunTitle $ lastValueView st) + writeHtmlHeader4 $ + writeHtmlText subtitle + let r = fromJust $ M.lookup i (lastValueMap st) + pairs <- liftIO $ readIORef r + forM_ pairs $ \pair -> + formatPair pair (lastValueFormatter $ lastValueView st) + +header :: LastValueViewState -> Int -> HtmlWriter () +header st index = + do writeHtmlHeader3WithId ("id" ++ show index) $ + writeHtmlText (lastValueTitle $ lastValueView st) + let description = lastValueDescription $ lastValueView st + unless (null description) $ + writeHtmlParagraph $ + writeHtmlText description + +formatPair :: (String, String) -> ShowS -> HtmlWriter () +formatPair (name, value) formatter = + writeHtmlParagraph $ + do writeHtmlText name + writeHtmlText " = " + writeHtmlText $ formatter value + +-- | Get the TOC item +lastValueTOCHtml :: LastValueViewState -> Int -> HtmlWriter () +lastValueTOCHtml st index = + writeHtmlListItem $ + writeHtmlLink ("#id" ++ show index) $ + writeHtmlText (lastValueTitle $ lastValueView st) diff --git a/Simulation/Aivika/Experiment/TableView.hs b/Simulation/Aivika/Experiment/TableView.hs --- a/Simulation/Aivika/Experiment/TableView.hs +++ b/Simulation/Aivika/Experiment/TableView.hs @@ -1,245 +1,246 @@ - --- | --- Module : Simulation.Aivika.Experiment.TableView --- Copyright : Copyright (c) 2012, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.4.1 --- --- The module defines 'TableView' that saves the simulation --- results in the CSV file(s). --- - -module Simulation.Aivika.Experiment.TableView - (TableView(..), - defaultTableView) where - -import Control.Monad -import Control.Monad.Trans - -import qualified Data.Map as M -import Data.IORef -import Data.Maybe - -import System.IO -import System.FilePath - -import Data.String.Utils (replace) - -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 CSV file(s). -data TableView = - TableView { tableTitle :: String, - -- ^ This is a title used in HTML. - tableDescription :: String, - -- ^ This is a description in the HTML. - tableLinkText :: String, - -- ^ It specifies the text for the link - -- which is displayed in the HTML page - -- if there is only one simulation run. - -- The link downloads the corresponded - -- CSV file in the browser. If there are - -- more simulation runs, then this link - -- is not shown. - -- - -- An example is - -- - -- @ - -- tableLinkText = \"Download the CSV file\" - -- @ - tableRunLinkText :: String, - -- ^ It specifies the link text which is - -- displayed in the HTML page if there are - -- many simulation runs. Such a link downloads - -- the CSV file for the corresponded run. - -- To define the text, you can use special - -- variables @$LINK@, @$RUN_INDEX@ and @$RUN_COUNT@. - -- - -- An example is - -- - -- @ - -- tableRunLinkText = \"$LINK / Run $RUN_INDEX of $RUN_COUNT\" - -- @ - -- - -- If there is only one run, then the link of - -- this kind is not displayed. Instead, only one - -- link is shown, which text is defined by the - -- 'tableLinkText' field. - tableFileName :: FileName, - -- ^ It defines the file name for each CSV file. - -- It may include special variables @$TITLE@, - -- @$RUN_INDEX@ and @$RUN_COUNT@. - -- - -- An example is - -- - -- @ - -- tableFileName = UniqueFileName \"$TITLE - $RUN_INDEX\", \".csv\" - -- @ - tableSeparator :: String, - -- ^ It defines the separator for the view. - -- It delimits the cells in the rows of the CSV file. - tableFormatter :: ShowS, - -- ^ It defines the formatter which is applied - -- to all values before they will be written - -- in the CSV file(s). - tablePredicate :: Dynamics 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). - } - --- | The default table view. -defaultTableView :: TableView -defaultTableView = - TableView { tableTitle = "Table", - tableDescription = [], - tableLinkText = "Download the CSV file", - tableRunLinkText = "$LINK / Run $RUN_INDEX of $RUN_COUNT", - tableFileName = UniqueFileName "$TITLE - $RUN_INDEX" ".csv", - tableSeparator = ",", - tableFormatter = id, - tablePredicate = return True, - tableSeries = [] } - -instance View TableView where - - outputView v = - let reporter exp dir = - do st <- newTable v exp dir - return Reporter { reporterInitialise = return (), - reporterFinalise = return (), - reporterSimulate = simulateTable st, - reporterTOCHtml = tableTOCHtml st, - reporterHtml = tableHtml st } - in Generator { generateReporter = reporter } - --- | The state of the view. -data TableViewState = - TableViewState { tableView :: TableView, - tableExperiment :: Experiment, - tableDir :: FilePath, - tableMap :: M.Map Int FilePath } - --- | Create a new state of the view. -newTable :: TableView -> Experiment -> FilePath -> IO TableViewState -newTable view exp dir = - do let n = experimentRunCount exp - fs <- forM [0..(n - 1)] $ \i -> - resolveFileName (Just dir) (tableFileName view) $ - M.fromList [("$TITLE", tableTitle view), - ("$RUN_INDEX", show $ i + 1), - ("$RUN_COUNT", show n)] - let m = M.fromList $ zip [0..(n - 1)] fs - return TableViewState { tableView = view, - tableExperiment = exp, - tableDir = dir, - tableMap = m } - --- | Write the tables during the simulation. -simulateTable :: TableViewState -> ExperimentData -> Dynamics (Dynamics ()) -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 - i <- liftSimulation 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 when (column > 0) $ - hPutStr h separator - hPutStr h $ providerName provider - hPutStrLn h "" - t <- time - 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_ (experimentMixedSignal expdata providers) $ \t -> - do p <- predicate - when p $ - do forM_ (zip [0..] input) $ \(column, input) -> -- write the row - do x <- input -- 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 - --- | Get the HTML code. -tableHtml :: TableViewState -> Int -> HtmlWriter () -tableHtml st index = - let n = experimentRunCount $ tableExperiment st - in if n == 1 - then tableHtmlSingle st index - else tableHtmlMultiple st index - --- | Get the HTML code for a single run. -tableHtmlSingle :: TableViewState -> Int -> HtmlWriter () -tableHtmlSingle st index = - do header st index - let f = fromJust $ M.lookup 0 (tableMap st) - writeHtmlParagraph $ - writeHtmlLink (makeRelative (tableDir st) f) $ - writeHtmlText (tableLinkText $ tableView st) - --- | Get the HTML code for multiple runs -tableHtmlMultiple :: TableViewState -> Int -> HtmlWriter () -tableHtmlMultiple st index = - do header st index - let n = experimentRunCount $ tableExperiment st - forM_ [0..(n - 1)] $ \i -> - do let f = fromJust $ M.lookup i (tableMap st) - sublink = - replace "$RUN_INDEX" (show $ i + 1) $ - replace "$RUN_COUNT" (show n) $ - replace "$LINK" (tableLinkText $ tableView st) - (tableRunLinkText $ tableView st) - writeHtmlParagraph $ - writeHtmlLink (makeRelative (tableDir st) f) $ - writeHtmlText sublink - -header :: TableViewState -> Int -> HtmlWriter () -header st index = - do writeHtmlHeader3WithId ("id" ++ show index) $ - writeHtmlText (tableTitle $ tableView st) - let description = tableDescription $ tableView st - unless (null description) $ - writeHtmlParagraph $ - writeHtmlText description - --- | Get the TOC item -tableTOCHtml :: TableViewState -> Int -> HtmlWriter () -tableTOCHtml st index = - writeHtmlListItem $ - writeHtmlLink ("#id" ++ show index) $ - writeHtmlText (tableTitle $ tableView st) + +-- | +-- Module : Simulation.Aivika.Experiment.TableView +-- Copyright : Copyright (c) 2012, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.4.1 +-- +-- The module defines 'TableView' that saves the simulation +-- results in the CSV file(s). +-- + +module Simulation.Aivika.Experiment.TableView + (TableView(..), + defaultTableView) where + +import Control.Monad +import Control.Monad.Trans + +import qualified Data.Map as M +import Data.IORef +import Data.Maybe + +import System.IO +import System.FilePath + +import Data.String.Utils (replace) + +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 CSV file(s). +data TableView = + TableView { tableTitle :: String, + -- ^ This is a title used in HTML. + tableDescription :: String, + -- ^ This is a description in the HTML. + tableLinkText :: String, + -- ^ It specifies the text for the link + -- which is displayed in the HTML page + -- if there is only one simulation run. + -- The link downloads the corresponded + -- CSV file in the browser. If there are + -- more simulation runs, then this link + -- is not shown. + -- + -- An example is + -- + -- @ + -- tableLinkText = \"Download the CSV file\" + -- @ + tableRunLinkText :: String, + -- ^ It specifies the link text which is + -- displayed in the HTML page if there are + -- many simulation runs. Such a link downloads + -- the CSV file for the corresponded run. + -- To define the text, you can use special + -- variables @$LINK@, @$RUN_INDEX@ and @$RUN_COUNT@. + -- + -- An example is + -- + -- @ + -- tableRunLinkText = \"$LINK / Run $RUN_INDEX of $RUN_COUNT\" + -- @ + -- + -- If there is only one run, then the link of + -- this kind is not displayed. Instead, only one + -- link is shown, which text is defined by the + -- 'tableLinkText' field. + tableFileName :: FileName, + -- ^ It defines the file name for each CSV file. + -- It may include special variables @$TITLE@, + -- @$RUN_INDEX@ and @$RUN_COUNT@. + -- + -- An example is + -- + -- @ + -- tableFileName = UniqueFileName \"$TITLE - $RUN_INDEX\", \".csv\" + -- @ + tableSeparator :: String, + -- ^ It defines the separator for the view. + -- It delimits the cells in the rows of the CSV file. + tableFormatter :: ShowS, + -- ^ It defines the formatter which is applied + -- to all values before they will be written + -- in the CSV file(s). + tablePredicate :: Dynamics 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). + } + +-- | The default table view. +defaultTableView :: TableView +defaultTableView = + TableView { tableTitle = "Table", + tableDescription = [], + tableLinkText = "Download the CSV file", + tableRunLinkText = "$LINK / Run $RUN_INDEX of $RUN_COUNT", + tableFileName = UniqueFileName "$TITLE - $RUN_INDEX" ".csv", + tableSeparator = ",", + tableFormatter = id, + tablePredicate = return True, + tableSeries = [] } + +instance View TableView where + + outputView v = + let reporter exp dir = + do st <- newTable v exp dir + return Reporter { reporterInitialise = return (), + reporterFinalise = return (), + reporterSimulate = simulateTable st, + reporterTOCHtml = tableTOCHtml st, + reporterHtml = tableHtml st } + in Generator { generateReporter = reporter } + +-- | The state of the view. +data TableViewState = + TableViewState { tableView :: TableView, + tableExperiment :: Experiment, + tableDir :: FilePath, + tableMap :: M.Map Int FilePath } + +-- | Create a new state of the view. +newTable :: TableView -> Experiment -> FilePath -> IO TableViewState +newTable view exp dir = + do let n = experimentRunCount exp + fs <- forM [0..(n - 1)] $ \i -> + resolveFileName (Just dir) (tableFileName view) $ + M.fromList [("$TITLE", tableTitle view), + ("$RUN_INDEX", show $ i + 1), + ("$RUN_COUNT", show n)] + forM_ fs $ flip writeFile [] -- reserve the file names + let m = M.fromList $ zip [0..(n - 1)] fs + return TableViewState { tableView = view, + tableExperiment = exp, + tableDir = dir, + tableMap = m } + +-- | Write the tables during the simulation. +simulateTable :: TableViewState -> ExperimentData -> Dynamics (Dynamics ()) +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 + i <- liftSimulation 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 when (column > 0) $ + hPutStr h separator + hPutStr h $ providerName provider + hPutStrLn h "" + t <- time + 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_ (experimentMixedSignal expdata providers) $ \t -> + do p <- predicate + when p $ + do forM_ (zip [0..] input) $ \(column, input) -> -- write the row + do x <- input -- 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 + +-- | Get the HTML code. +tableHtml :: TableViewState -> Int -> HtmlWriter () +tableHtml st index = + let n = experimentRunCount $ tableExperiment st + in if n == 1 + then tableHtmlSingle st index + else tableHtmlMultiple st index + +-- | Get the HTML code for a single run. +tableHtmlSingle :: TableViewState -> Int -> HtmlWriter () +tableHtmlSingle st index = + do header st index + let f = fromJust $ M.lookup 0 (tableMap st) + writeHtmlParagraph $ + writeHtmlLink (makeRelative (tableDir st) f) $ + writeHtmlText (tableLinkText $ tableView st) + +-- | Get the HTML code for multiple runs +tableHtmlMultiple :: TableViewState -> Int -> HtmlWriter () +tableHtmlMultiple st index = + do header st index + let n = experimentRunCount $ tableExperiment st + forM_ [0..(n - 1)] $ \i -> + do let f = fromJust $ M.lookup i (tableMap st) + sublink = + replace "$RUN_INDEX" (show $ i + 1) $ + replace "$RUN_COUNT" (show n) $ + replace "$LINK" (tableLinkText $ tableView st) + (tableRunLinkText $ tableView st) + writeHtmlParagraph $ + writeHtmlLink (makeRelative (tableDir st) f) $ + writeHtmlText sublink + +header :: TableViewState -> Int -> HtmlWriter () +header st index = + do writeHtmlHeader3WithId ("id" ++ show index) $ + writeHtmlText (tableTitle $ tableView st) + let description = tableDescription $ tableView st + unless (null description) $ + writeHtmlParagraph $ + writeHtmlText description + +-- | Get the TOC item +tableTOCHtml :: TableViewState -> Int -> HtmlWriter () +tableTOCHtml st index = + writeHtmlListItem $ + writeHtmlLink ("#id" ++ show index) $ + writeHtmlText (tableTitle $ tableView st) diff --git a/Simulation/Aivika/Experiment/Utils.hs b/Simulation/Aivika/Experiment/Utils.hs --- a/Simulation/Aivika/Experiment/Utils.hs +++ b/Simulation/Aivika/Experiment/Utils.hs @@ -1,23 +1,23 @@ - --- | --- Module : Simulation.Aivika.Experiment.Utils --- Copyright : Copyright (c) 2012, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.4.1 --- --- It defines utility functions missed in the standard library. --- - -module Simulation.Aivika.Experiment.Utils - (divideBy) where - --- | Divide into the groups removing those elements --- that satisfy the predicate. -divideBy :: (a -> Bool) -> [a] -> [[a]] -divideBy p xs = - case dropWhile p xs of - [] -> [] - xs' -> ys : divideBy p xs'' + +-- | +-- Module : Simulation.Aivika.Experiment.Utils +-- Copyright : Copyright (c) 2012, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.4.1 +-- +-- It defines utility functions missed in the standard library. +-- + +module Simulation.Aivika.Experiment.Utils + (divideBy) where + +-- | Divide into the groups removing those elements +-- that satisfy the predicate. +divideBy :: (a -> Bool) -> [a] -> [[a]] +divideBy p xs = + case dropWhile p xs of + [] -> [] + xs' -> ys : divideBy p xs'' where (ys, xs'') = break p xs' diff --git a/aivika-experiment.cabal b/aivika-experiment.cabal --- a/aivika-experiment.cabal +++ b/aivika-experiment.cabal @@ -1,45 +1,47 @@ -name: aivika-experiment -version: 0.1.1 -synopsis: Simulation experiments for the Aivika library -description: - This package allows defining simulation experiments for the Aivika - package. Such experiments define in declarative manner what should be - simulated and in which view the simulation results should be - generated. It can be charts, tables and so on. - . - The library is extensible and you can add new views for the results. - . -category: Simulation -license: BSD3 -license-file: LICENSE -copyright: (c) 2012. David Sorokin -author: David Sorokin -maintainer: David Sorokin -homepage: http://github.com/dsorokin/aivika-experiment -cabal-version: >= 1.2.0 -build-type: Simple -tested-with: GHC == 7.4.1 - -extra-source-files: examples/MachRep3.hs - -library - - exposed-modules: Simulation.Aivika.Experiment - Simulation.Aivika.Experiment.HtmlWriter - Simulation.Aivika.Experiment.LastValueView - Simulation.Aivika.Experiment.TableView - Simulation.Aivika.Experiment.Utils - - build-depends: base >= 3 && < 6, - mtl >= 1.1.0.2, - array >= 0.3.0.0, - containers >= 0.4.0.0, - directory >= 1.1.0.2, - filepath >= 1.3.0.0, - MissingH >= 1.2.0.0, - network >= 2.3.0.13, - aivika >= 0.4.3 - - extensions: FlexibleInstances - - ghc-options: -O2 +name: aivika-experiment +version: 0.1.2 +synopsis: Simulation experiments for the Aivika library +description: + This package allows defining simulation experiments for the Aivika + package. Such experiments define in declarative manner what should be + simulated and in which view the simulation results should be + generated. It can be charts, tables and so on. + . + The library is extensible and you can add new views for the results. + . +category: Simulation +license: BSD3 +license-file: LICENSE +copyright: (c) 2012. David Sorokin +author: David Sorokin +maintainer: David Sorokin +homepage: http://github.com/dsorokin/aivika-experiment +cabal-version: >= 1.2.0 +build-type: Simple +tested-with: GHC == 7.4.1 + +extra-source-files: examples/MachRep3.hs + +library + + exposed-modules: Simulation.Aivika.Experiment + Simulation.Aivika.Experiment.HtmlWriter + Simulation.Aivika.Experiment.LastValueView + Simulation.Aivika.Experiment.TableView + Simulation.Aivika.Experiment.Histogram + Simulation.Aivika.Experiment.Utils + + build-depends: base >= 3 && < 6, + mtl >= 1.1.0.2, + array >= 0.3.0.0, + containers >= 0.4.0.0, + directory >= 1.1.0.2, + filepath >= 1.3.0.0, + MissingH >= 1.2.0.0, + network >= 2.3.0.13, + parallel-io >= 0.3.2.1, + aivika >= 0.4.3 + + extensions: FlexibleInstances + + ghc-options: -O2 diff --git a/examples/MachRep3.hs b/examples/MachRep3.hs --- a/examples/MachRep3.hs +++ b/examples/MachRep3.hs @@ -1,127 +1,127 @@ - --- It corresponds to model MachRep3 described in document --- Introduction to Discrete-Event Simulation and the SimPy Language --- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/DESimIntro.pdf]. --- SimPy is available on [http://simpy.sourceforge.net/]. --- --- The model description is as follows. --- --- Variation of models MachRep1, MachRep2. Two machines, but --- sometimes break down. Up time is exponentially distributed with mean --- 1.0, and repair time is exponentially distributed with mean 0.5. In --- this example, there is only one repairperson, and she is not summoned --- until both machines are down. We find the proportion of up time. It --- should come out to about 0.45. - -module MachRep3Model (model) where - -import System.Random -import Control.Monad -import Control.Monad.Trans - -import Simulation.Aivika.Dynamics -import Simulation.Aivika.Dynamics.Simulation -import Simulation.Aivika.Dynamics.Base -import Simulation.Aivika.Dynamics.EventQueue -import Simulation.Aivika.Dynamics.Ref -import Simulation.Aivika.Dynamics.Resource -import Simulation.Aivika.Dynamics.Process - -import Simulation.Aivika.Experiment -import Simulation.Aivika.Experiment.LastValueView -import Simulation.Aivika.Experiment.TableView - -specs = Specs { spcStartTime = 0.0, - spcStopTime = 1000.0, - spcDT = 1.0, - spcMethod = RungeKutta4 } - -description = - "Variation of models MachRep1, MachRep2. Two machines, but " ++ - "sometimes break down. Up time is exponentially distributed with mean " ++ - "1.0, and repair time is exponentially distributed with mean 0.5. In " ++ - "this example, there is only one repairperson, and she is not summoned " ++ - "until both machines are down. We find the proportion of up time. It " ++ - "should come out to about 0.45." - -experiment :: Experiment -experiment = - defaultExperiment { - experimentSpecs = specs, - experimentRunCount = 3, - experimentDescription = description, - experimentGenerators = - [outputView $ defaultLastValueView { - lastValueDescription = - "It shows the last value of " ++ - "the proportion of up time.", - lastValueSeries = ["x"] }, - outputView $ defaultTableView { - tableDescription = - "These are tables for " ++ - "the proportion of up time.", - tableSeries = ["x"] } ] } - -upRate = 1.0 / 1.0 -- reciprocal of mean up time -repairRate = 1.0 / 0.5 -- reciprocal of mean repair time - -exprnd :: Double -> IO Double -exprnd lambda = - do x <- getStdRandom random - return (- log x / lambda) - -model :: Simulation ExperimentData -model = - do queue <- newQueue - - -- number of machines currently up - nUp <- newRef queue 2 - - -- total up time for all machines - totalUpTime <- newRef queue 0.0 - - repairPerson <- newResource queue 1 - - pid1 <- newProcessID queue - pid2 <- newProcessID queue - - let machine :: ProcessID -> Process () - machine pid = - do startUpTime <- liftDynamics time - upTime <- liftIO $ exprnd upRate - holdProcess upTime - finishUpTime <- liftDynamics time - liftDynamics $ modifyRef totalUpTime - (+ (finishUpTime - startUpTime)) - - liftDynamics $ modifyRef nUp $ \a -> a - 1 - nUp' <- liftDynamics $ readRef nUp - if nUp' == 1 - then passivateProcess - else do n <- liftDynamics $ - resourceCount repairPerson - when (n == 1) $ - liftDynamics $ reactivateProcess pid - - requestResource repairPerson - repairTime <- liftIO $ exprnd repairRate - holdProcess repairTime - liftDynamics $ modifyRef nUp $ \a -> a + 1 - releaseResource repairPerson - - machine pid - - runDynamicsInStartTime $ - do t0 <- starttime - runProcess (machine pid2) pid1 t0 - runProcess (machine pid1) pid2 t0 - - let result = - do x <- readRef totalUpTime - y <- time - return $ x / (2 * y) - - experimentDataInStartTime queue $ - [("x", seriesEntity "The proportion of up time" result)] - + +-- It corresponds to model MachRep3 described in document +-- Introduction to Discrete-Event Simulation and the SimPy Language +-- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/DESimIntro.pdf]. +-- SimPy is available on [http://simpy.sourceforge.net/]. +-- +-- The model description is as follows. +-- +-- Variation of models MachRep1, MachRep2. Two machines, but +-- sometimes break down. Up time is exponentially distributed with mean +-- 1.0, and repair time is exponentially distributed with mean 0.5. In +-- this example, there is only one repairperson, and she is not summoned +-- until both machines are down. We find the proportion of up time. It +-- should come out to about 0.45. + +module MachRep3Model (model) where + +import System.Random +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Dynamics +import Simulation.Aivika.Dynamics.Simulation +import Simulation.Aivika.Dynamics.Base +import Simulation.Aivika.Dynamics.EventQueue +import Simulation.Aivika.Dynamics.Ref +import Simulation.Aivika.Dynamics.Resource +import Simulation.Aivika.Dynamics.Process + +import Simulation.Aivika.Experiment +import Simulation.Aivika.Experiment.LastValueView +import Simulation.Aivika.Experiment.TableView + +specs = Specs { spcStartTime = 0.0, + spcStopTime = 1000.0, + spcDT = 1.0, + spcMethod = RungeKutta4 } + +description = + "Model MachRep3. Variation of models MachRep1, MachRep2. Two machines, but " ++ + "sometimes break down. Up time is exponentially distributed with mean " ++ + "1.0, and repair time is exponentially distributed with mean 0.5. In " ++ + "this example, there is only one repairperson, and she is not summoned " ++ + "until both machines are down. We find the proportion of up time. It " ++ + "should come out to about 0.45." + +experiment :: Experiment +experiment = + defaultExperiment { + experimentSpecs = specs, + experimentRunCount = 3, + experimentDescription = description, + experimentGenerators = + [outputView $ defaultLastValueView { + lastValueDescription = + "It shows the last value of " ++ + "the proportion of up time.", + lastValueSeries = ["x"] }, + outputView $ defaultTableView { + tableDescription = + "These are tables for " ++ + "the proportion of up time.", + tableSeries = ["x"] } ] } + +upRate = 1.0 / 1.0 -- reciprocal of mean up time +repairRate = 1.0 / 0.5 -- reciprocal of mean repair time + +exprnd :: Double -> IO Double +exprnd lambda = + do x <- getStdRandom random + return (- log x / lambda) + +model :: Simulation ExperimentData +model = + do queue <- newQueue + + -- number of machines currently up + nUp <- newRef queue 2 + + -- total up time for all machines + totalUpTime <- newRef queue 0.0 + + repairPerson <- newResource queue 1 + + pid1 <- newProcessID queue + pid2 <- newProcessID queue + + let machine :: ProcessID -> Process () + machine pid = + do startUpTime <- liftDynamics time + upTime <- liftIO $ exprnd upRate + holdProcess upTime + finishUpTime <- liftDynamics time + liftDynamics $ modifyRef totalUpTime + (+ (finishUpTime - startUpTime)) + + liftDynamics $ modifyRef nUp $ \a -> a - 1 + nUp' <- liftDynamics $ readRef nUp + if nUp' == 1 + then passivateProcess + else do n <- liftDynamics $ + resourceCount repairPerson + when (n == 1) $ + liftDynamics $ reactivateProcess pid + + requestResource repairPerson + repairTime <- liftIO $ exprnd repairRate + holdProcess repairTime + liftDynamics $ modifyRef nUp $ \a -> a + 1 + releaseResource repairPerson + + machine pid + + runDynamicsInStartTime $ + do t0 <- starttime + runProcess (machine pid2) pid1 t0 + runProcess (machine pid1) pid2 t0 + + let result = + do x <- readRef totalUpTime + y <- time + return $ x / (2 * y) + + experimentDataInStartTime queue + [("x", seriesEntity "The proportion of up time" result)] + main = runExperiment experiment model