aivika-experiment 0.1 → 0.1.1
raw patch · 9 files changed
+1518/−1518 lines, 9 filesdep ~networksetup-changedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: network
API changes (from Hackage documentation)
Files
- LICENSE +30/−30
- Setup.lhs +3/−3
- Simulation/Aivika/Experiment.hs +485/−485
- Simulation/Aivika/Experiment/HtmlWriter.hs +384/−384
- Simulation/Aivika/Experiment/LastValueView.hs +178/−178
- Simulation/Aivika/Experiment/TableView.hs +245/−245
- Simulation/Aivika/Experiment/Utils.hs +22/−22
- aivika-experiment.cabal +45/−45
- examples/MachRep3.hs +126/−126
LICENSE view
@@ -1,30 +1,30 @@-Copyright (c) 2012 David Sorokin <david.sorokin@gmail.com>--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 <david.sorokin@gmail.com> + +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.
Setup.lhs view
@@ -1,3 +1,3 @@-#!/usr/bin/env runhaskell-> import Distribution.Simple-> main = defaultMain+#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain
Simulation/Aivika/Experiment.hs view
@@ -1,485 +1,485 @@--{-# LANGUAGE FlexibleInstances #-}---- |--- Module : Simulation.Aivika.Experiment--- Copyright : Copyright (c) 2012, David Sorokin <david.sorokin@gmail.com>--- License : BSD3--- Maintainer : David Sorokin <david.sorokin@gmail.com>--- 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 <david.sorokin@gmail.com> +-- License : BSD3 +-- Maintainer : David Sorokin <david.sorokin@gmail.com> +-- 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 }
Simulation/Aivika/Experiment/HtmlWriter.hs view
@@ -1,384 +1,384 @@---- |--- Module : Simulation.Aivika.Experiment.HtmlWriter--- Copyright : Copyright (c) 2012, David Sorokin <david.sorokin@gmail.com>--- License : BSD3--- Maintainer : David Sorokin <david.sorokin@gmail.com>--- 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 "<a href=\""- writeHtml $ escapeURIString isUnescapedInURI uri- writeHtml "\">"- inner- writeHtml "</a>"- --- | Write the HTML image with the specified URI.-writeHtmlImage :: String -> HtmlWriter ()-writeHtmlImage uri =- do writeHtml "<img src=\""- writeHtml $ escapeURIString isUnescapedInURI uri- writeHtml "\" />"---- | Write the @\<p\>@ element with the specified contents. -writeHtmlParagraph :: HtmlWriter () -> HtmlWriter () -writeHtmlParagraph inner =- do writeHtml "<p>"- inner- writeHtml "</p>"- --- | Write the @\<h1\>@ element with the specified contents. -writeHtmlHeader1 :: HtmlWriter () -> HtmlWriter () -writeHtmlHeader1 inner =- do writeHtml "<h1>"- inner- writeHtml "</h1>"- --- | Write the @\<h2\>@ element with the specified contents. -writeHtmlHeader2 :: HtmlWriter () -> HtmlWriter () -writeHtmlHeader2 inner =- do writeHtml "<h2>"- inner- writeHtml "</h2>"- --- | Write the @\<h3\>@ element with the specified contents. -writeHtmlHeader3 :: HtmlWriter () -> HtmlWriter () -writeHtmlHeader3 inner =- do writeHtml "<h3>"- inner- writeHtml "</h3>"- --- | Write the @\<h4\>@ element with the specified contents. -writeHtmlHeader4 :: HtmlWriter () -> HtmlWriter () -writeHtmlHeader4 inner =- do writeHtml "<h4>"- inner- writeHtml "</h4>"- --- | Write the @\<h5\>@ element with the specified contents. -writeHtmlHeader5 :: HtmlWriter () -> HtmlWriter () -writeHtmlHeader5 inner =- do writeHtml "<h5>"- inner- writeHtml "</h5>"- --- | Write the @\<h6\>@ element with the specified contents. -writeHtmlHeader6 :: HtmlWriter () -> HtmlWriter () -writeHtmlHeader6 inner =- do writeHtml "<h6>"- inner- writeHtml "</h6>"- --- | Write the @\<p\>@ element with the specified id and contents. -writeHtmlParagraphWithId :: String -> HtmlWriter () -> HtmlWriter () -writeHtmlParagraphWithId id inner =- do writeHtml "<p id=\""- writeHtml id- writeHtml "\">"- inner- writeHtml "</p>"- --- | Write the @\<h1\>@ element with the specified id and contents. -writeHtmlHeader1WithId :: String -> HtmlWriter () -> HtmlWriter () -writeHtmlHeader1WithId id inner =- do writeHtml "<h1 id=\""- writeHtml id- writeHtml "\">"- inner- writeHtml "</h1>"- --- | Write the @\<h2\>@ element with the specified id and contents. -writeHtmlHeader2WithId :: String -> HtmlWriter () -> HtmlWriter () -writeHtmlHeader2WithId id inner =- do writeHtml "<h2 id=\""- writeHtml id- writeHtml "\">"- inner- writeHtml "</h2>"- --- | Write the @\<h3\>@ element with the specified id and contents. -writeHtmlHeader3WithId :: String -> HtmlWriter () -> HtmlWriter () -writeHtmlHeader3WithId id inner =- do writeHtml "<h3 id=\""- writeHtml id- writeHtml "\">"- inner- writeHtml "</h3>"- --- | Write the @\<h4\>@ element with the specified id and contents. -writeHtmlHeader4WithId :: String -> HtmlWriter () -> HtmlWriter () -writeHtmlHeader4WithId id inner =- do writeHtml "<h4 id=\""- writeHtml id- writeHtml "\">"- inner- writeHtml "</h4>"- --- | Write the @\<h5\>@ element with the specified id and contents. -writeHtmlHeader5WithId :: String -> HtmlWriter () -> HtmlWriter () -writeHtmlHeader5WithId id inner =- do writeHtml "<h5 id=\""- writeHtml id- writeHtml "\">"- inner- writeHtml "</h5>"- --- | Write the @\<h6\>@ element with the specified id and contents. -writeHtmlHeader6WithId :: String -> HtmlWriter () -> HtmlWriter () -writeHtmlHeader6WithId id inner =- do writeHtml "<h6 id=\""- writeHtml id- writeHtml "\">"- inner- writeHtml "</h6>"- --- | Write the @\<br\>@ element.-writeHtmlBreak :: HtmlWriter () -writeHtmlBreak =- writeHtml "<br />"- --- | Write the list of items wrapped in @\<ul\>@. -writeHtmlList :: HtmlWriter () -> HtmlWriter ()-writeHtmlList inner =- do writeHtml "<ul>"- inner- writeHtml "</ul>"---- | Write the item list wrapped in @\<li\>@. -writeHtmlListItem :: HtmlWriter () -> HtmlWriter ()-writeHtmlListItem inner =- do writeHtml "<li>"- inner- writeHtml "</li>"---- | Write the HTML document with the specified title and contents-writeHtmlDocumentWithTitle :: String -> HtmlWriter () -> HtmlWriter ()-writeHtmlDocumentWithTitle title inner =- do writeHtml "<html>"- writeHtml "<head>"- writeHtml "<title>"- writeHtmlText title- writeHtml "</title>"- writeHtmlCss - writeHtml "</head>"- writeHtml "<body>"- writeHtmlHeader1 $ - writeHtmlText title- writeHtml "</h1>"- inner- writeHtml "<br /><p><font size=\"-1\">Automatically generated by "- writeHtml "<a href=\"https://github.com/dsorokin/aivika-experiment\">"- writeHtml "Aivika Experiment</a>"- writeHtml "</font></p>"- writeHtml "</body>"- writeHtml "</html>"---- | 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 "<style type=\"text/css\">"- writeHtmlLn "* { margin: 0; padding: 0 }"- writeHtmlLn ""- writeHtmlLn "html {"- writeHtmlLn " background-color: white;"- writeHtmlLn " width: 100%;"- writeHtmlLn " height: 100%;"- writeHtmlLn "}"- writeHtmlLn ""- writeHtmlLn "body {"- writeHtmlLn " background: white;"- writeHtmlLn " color: black;"- writeHtmlLn " text-align: left;"- writeHtmlLn " min-height: 100%;"- writeHtmlLn " position: relative;"- writeHtmlLn "}"- writeHtmlLn ""- writeHtmlLn "p {"- writeHtmlLn " margin: 0.8em 0;"- writeHtmlLn "}"- writeHtmlLn ""- writeHtmlLn "ul, ol {"- writeHtmlLn " margin: 0.8em 0 0.8em 2em;"- writeHtmlLn "}"- writeHtmlLn ""- writeHtmlLn "dl {"- writeHtmlLn " margin: 0.8em 0;"- writeHtmlLn "}"- writeHtmlLn ""- writeHtmlLn "dt {"- writeHtmlLn " font-weight: bold;"- writeHtmlLn "}"- writeHtmlLn ""- writeHtmlLn "dd {"- writeHtmlLn " margin-left: 2em;"- writeHtmlLn "}"- writeHtmlLn ""- writeHtmlLn "a { text-decoration: none; }"- writeHtmlLn "a[href]:link { color: rgb(196,69,29); }"- writeHtmlLn "a[href]:visited { color: rgb(171,105,84); }"- writeHtmlLn "a[href]:hover { text-decoration:underline; }"- writeHtmlLn ""- writeHtmlLn "body {"- writeHtmlLn " font:13px/1.4 sans-serif;"- writeHtmlLn " *font-size:small; /* for IE */"- writeHtmlLn " *font:x-small; /* for IE in quirks mode */"- writeHtmlLn "}"- writeHtmlLn ""- writeHtmlLn "h1 { font-size: 146.5%; /* 19pt */ } "- writeHtmlLn "h2 { font-size: 131%; /* 17pt */ }"- writeHtmlLn "h3 { font-size: 116%; /* 15pt */ }"- writeHtmlLn "h4 { font-size: 100%; /* 13pt */ }"- writeHtmlLn "h5 { font-size: 100%; /* 13pt */ }"- writeHtmlLn ""- writeHtmlLn "select, input, button, textarea {"- writeHtmlLn " font:99% sans-serif;"- writeHtmlLn "}"- writeHtmlLn ""- writeHtmlLn "table {"- writeHtmlLn " font-size:inherit;"- writeHtmlLn " font:100%;"- writeHtmlLn "}"- writeHtmlLn ""- writeHtmlLn "pre, code, kbd, samp, tt, .src {"- writeHtmlLn " font-family:monospace;"- writeHtmlLn " *font-size:108%;"- writeHtmlLn " line-height: 124%;"- writeHtmlLn "}"- writeHtmlLn ""- writeHtmlLn ".links, .link {"- writeHtmlLn " font-size: 85%; /* 11pt */"- writeHtmlLn "}"- writeHtmlLn ".info {"- writeHtmlLn " font-size: 85%; /* 11pt */"- writeHtmlLn "}"- writeHtmlLn ""- writeHtmlLn ".caption, h1, h2, h3, h4, h5, h6 { "- writeHtmlLn " font-weight: bold;"- writeHtmlLn " color: rgb(78,98,114);"- writeHtmlLn " margin: 0.8em 0 0.4em;"- writeHtmlLn "}"- writeHtmlLn ""- writeHtmlLn "* + h1, * + h2, * + h3, * + h4, * + h5, * + h6 {"- writeHtmlLn " margin-top: 2em;"- writeHtmlLn "}"- writeHtmlLn ""- writeHtmlLn "h1 + h2, h2 + h3, h3 + h4, h4 + h5, h5 + h6 {"- writeHtmlLn " margin-top: inherit;"- writeHtmlLn "}"- writeHtmlLn ""- writeHtmlLn "ul.links {"- writeHtmlLn " list-style: none;"- writeHtmlLn " text-align: left;"- writeHtmlLn " float: right;"- writeHtmlLn " display: inline-table;"- writeHtmlLn " margin: 0 0 0 1em;"- writeHtmlLn "}"- writeHtmlLn ""- writeHtmlLn "ul.links li {"- writeHtmlLn " display: inline;"- writeHtmlLn " border-left: 1px solid #d5d5d5; "- writeHtmlLn " white-space: nowrap;"- writeHtmlLn " padding: 0;"- writeHtmlLn "}"- writeHtmlLn ""- writeHtmlLn "ul.links li a {"- writeHtmlLn " padding: 0.2em 0.5em;"- writeHtmlLn "}"- writeHtmlLn "</style>"+ +-- | +-- Module : Simulation.Aivika.Experiment.HtmlWriter +-- Copyright : Copyright (c) 2012, David Sorokin <david.sorokin@gmail.com> +-- License : BSD3 +-- Maintainer : David Sorokin <david.sorokin@gmail.com> +-- 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 "<a href=\"" + writeHtml $ escapeURIString isUnescapedInURI uri + writeHtml "\">" + inner + writeHtml "</a>" + +-- | Write the HTML image with the specified URI. +writeHtmlImage :: String -> HtmlWriter () +writeHtmlImage uri = + do writeHtml "<img src=\"" + writeHtml $ escapeURIString isUnescapedInURI uri + writeHtml "\" />" + +-- | Write the @\<p\>@ element with the specified contents. +writeHtmlParagraph :: HtmlWriter () -> HtmlWriter () +writeHtmlParagraph inner = + do writeHtml "<p>" + inner + writeHtml "</p>" + +-- | Write the @\<h1\>@ element with the specified contents. +writeHtmlHeader1 :: HtmlWriter () -> HtmlWriter () +writeHtmlHeader1 inner = + do writeHtml "<h1>" + inner + writeHtml "</h1>" + +-- | Write the @\<h2\>@ element with the specified contents. +writeHtmlHeader2 :: HtmlWriter () -> HtmlWriter () +writeHtmlHeader2 inner = + do writeHtml "<h2>" + inner + writeHtml "</h2>" + +-- | Write the @\<h3\>@ element with the specified contents. +writeHtmlHeader3 :: HtmlWriter () -> HtmlWriter () +writeHtmlHeader3 inner = + do writeHtml "<h3>" + inner + writeHtml "</h3>" + +-- | Write the @\<h4\>@ element with the specified contents. +writeHtmlHeader4 :: HtmlWriter () -> HtmlWriter () +writeHtmlHeader4 inner = + do writeHtml "<h4>" + inner + writeHtml "</h4>" + +-- | Write the @\<h5\>@ element with the specified contents. +writeHtmlHeader5 :: HtmlWriter () -> HtmlWriter () +writeHtmlHeader5 inner = + do writeHtml "<h5>" + inner + writeHtml "</h5>" + +-- | Write the @\<h6\>@ element with the specified contents. +writeHtmlHeader6 :: HtmlWriter () -> HtmlWriter () +writeHtmlHeader6 inner = + do writeHtml "<h6>" + inner + writeHtml "</h6>" + +-- | Write the @\<p\>@ element with the specified id and contents. +writeHtmlParagraphWithId :: String -> HtmlWriter () -> HtmlWriter () +writeHtmlParagraphWithId id inner = + do writeHtml "<p id=\"" + writeHtml id + writeHtml "\">" + inner + writeHtml "</p>" + +-- | Write the @\<h1\>@ element with the specified id and contents. +writeHtmlHeader1WithId :: String -> HtmlWriter () -> HtmlWriter () +writeHtmlHeader1WithId id inner = + do writeHtml "<h1 id=\"" + writeHtml id + writeHtml "\">" + inner + writeHtml "</h1>" + +-- | Write the @\<h2\>@ element with the specified id and contents. +writeHtmlHeader2WithId :: String -> HtmlWriter () -> HtmlWriter () +writeHtmlHeader2WithId id inner = + do writeHtml "<h2 id=\"" + writeHtml id + writeHtml "\">" + inner + writeHtml "</h2>" + +-- | Write the @\<h3\>@ element with the specified id and contents. +writeHtmlHeader3WithId :: String -> HtmlWriter () -> HtmlWriter () +writeHtmlHeader3WithId id inner = + do writeHtml "<h3 id=\"" + writeHtml id + writeHtml "\">" + inner + writeHtml "</h3>" + +-- | Write the @\<h4\>@ element with the specified id and contents. +writeHtmlHeader4WithId :: String -> HtmlWriter () -> HtmlWriter () +writeHtmlHeader4WithId id inner = + do writeHtml "<h4 id=\"" + writeHtml id + writeHtml "\">" + inner + writeHtml "</h4>" + +-- | Write the @\<h5\>@ element with the specified id and contents. +writeHtmlHeader5WithId :: String -> HtmlWriter () -> HtmlWriter () +writeHtmlHeader5WithId id inner = + do writeHtml "<h5 id=\"" + writeHtml id + writeHtml "\">" + inner + writeHtml "</h5>" + +-- | Write the @\<h6\>@ element with the specified id and contents. +writeHtmlHeader6WithId :: String -> HtmlWriter () -> HtmlWriter () +writeHtmlHeader6WithId id inner = + do writeHtml "<h6 id=\"" + writeHtml id + writeHtml "\">" + inner + writeHtml "</h6>" + +-- | Write the @\<br\>@ element. +writeHtmlBreak :: HtmlWriter () +writeHtmlBreak = + writeHtml "<br />" + +-- | Write the list of items wrapped in @\<ul\>@. +writeHtmlList :: HtmlWriter () -> HtmlWriter () +writeHtmlList inner = + do writeHtml "<ul>" + inner + writeHtml "</ul>" + +-- | Write the item list wrapped in @\<li\>@. +writeHtmlListItem :: HtmlWriter () -> HtmlWriter () +writeHtmlListItem inner = + do writeHtml "<li>" + inner + writeHtml "</li>" + +-- | Write the HTML document with the specified title and contents +writeHtmlDocumentWithTitle :: String -> HtmlWriter () -> HtmlWriter () +writeHtmlDocumentWithTitle title inner = + do writeHtml "<html>" + writeHtml "<head>" + writeHtml "<title>" + writeHtmlText title + writeHtml "</title>" + writeHtmlCss + writeHtml "</head>" + writeHtml "<body>" + writeHtmlHeader1 $ + writeHtmlText title + writeHtml "</h1>" + inner + writeHtml "<br /><p><font size=\"-1\">Automatically generated by " + writeHtml "<a href=\"https://github.com/dsorokin/aivika-experiment\">" + writeHtml "Aivika Experiment</a>" + writeHtml "</font></p>" + writeHtml "</body>" + writeHtml "</html>" + +-- | 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 "<style type=\"text/css\">" + writeHtmlLn "* { margin: 0; padding: 0 }" + writeHtmlLn "" + writeHtmlLn "html {" + writeHtmlLn " background-color: white;" + writeHtmlLn " width: 100%;" + writeHtmlLn " height: 100%;" + writeHtmlLn "}" + writeHtmlLn "" + writeHtmlLn "body {" + writeHtmlLn " background: white;" + writeHtmlLn " color: black;" + writeHtmlLn " text-align: left;" + writeHtmlLn " min-height: 100%;" + writeHtmlLn " position: relative;" + writeHtmlLn "}" + writeHtmlLn "" + writeHtmlLn "p {" + writeHtmlLn " margin: 0.8em 0;" + writeHtmlLn "}" + writeHtmlLn "" + writeHtmlLn "ul, ol {" + writeHtmlLn " margin: 0.8em 0 0.8em 2em;" + writeHtmlLn "}" + writeHtmlLn "" + writeHtmlLn "dl {" + writeHtmlLn " margin: 0.8em 0;" + writeHtmlLn "}" + writeHtmlLn "" + writeHtmlLn "dt {" + writeHtmlLn " font-weight: bold;" + writeHtmlLn "}" + writeHtmlLn "" + writeHtmlLn "dd {" + writeHtmlLn " margin-left: 2em;" + writeHtmlLn "}" + writeHtmlLn "" + writeHtmlLn "a { text-decoration: none; }" + writeHtmlLn "a[href]:link { color: rgb(196,69,29); }" + writeHtmlLn "a[href]:visited { color: rgb(171,105,84); }" + writeHtmlLn "a[href]:hover { text-decoration:underline; }" + writeHtmlLn "" + writeHtmlLn "body {" + writeHtmlLn " font:13px/1.4 sans-serif;" + writeHtmlLn " *font-size:small; /* for IE */" + writeHtmlLn " *font:x-small; /* for IE in quirks mode */" + writeHtmlLn "}" + writeHtmlLn "" + writeHtmlLn "h1 { font-size: 146.5%; /* 19pt */ } " + writeHtmlLn "h2 { font-size: 131%; /* 17pt */ }" + writeHtmlLn "h3 { font-size: 116%; /* 15pt */ }" + writeHtmlLn "h4 { font-size: 100%; /* 13pt */ }" + writeHtmlLn "h5 { font-size: 100%; /* 13pt */ }" + writeHtmlLn "" + writeHtmlLn "select, input, button, textarea {" + writeHtmlLn " font:99% sans-serif;" + writeHtmlLn "}" + writeHtmlLn "" + writeHtmlLn "table {" + writeHtmlLn " font-size:inherit;" + writeHtmlLn " font:100%;" + writeHtmlLn "}" + writeHtmlLn "" + writeHtmlLn "pre, code, kbd, samp, tt, .src {" + writeHtmlLn " font-family:monospace;" + writeHtmlLn " *font-size:108%;" + writeHtmlLn " line-height: 124%;" + writeHtmlLn "}" + writeHtmlLn "" + writeHtmlLn ".links, .link {" + writeHtmlLn " font-size: 85%; /* 11pt */" + writeHtmlLn "}" + writeHtmlLn ".info {" + writeHtmlLn " font-size: 85%; /* 11pt */" + writeHtmlLn "}" + writeHtmlLn "" + writeHtmlLn ".caption, h1, h2, h3, h4, h5, h6 { " + writeHtmlLn " font-weight: bold;" + writeHtmlLn " color: rgb(78,98,114);" + writeHtmlLn " margin: 0.8em 0 0.4em;" + writeHtmlLn "}" + writeHtmlLn "" + writeHtmlLn "* + h1, * + h2, * + h3, * + h4, * + h5, * + h6 {" + writeHtmlLn " margin-top: 2em;" + writeHtmlLn "}" + writeHtmlLn "" + writeHtmlLn "h1 + h2, h2 + h3, h3 + h4, h4 + h5, h5 + h6 {" + writeHtmlLn " margin-top: inherit;" + writeHtmlLn "}" + writeHtmlLn "" + writeHtmlLn "ul.links {" + writeHtmlLn " list-style: none;" + writeHtmlLn " text-align: left;" + writeHtmlLn " float: right;" + writeHtmlLn " display: inline-table;" + writeHtmlLn " margin: 0 0 0 1em;" + writeHtmlLn "}" + writeHtmlLn "" + writeHtmlLn "ul.links li {" + writeHtmlLn " display: inline;" + writeHtmlLn " border-left: 1px solid #d5d5d5; " + writeHtmlLn " white-space: nowrap;" + writeHtmlLn " padding: 0;" + writeHtmlLn "}" + writeHtmlLn "" + writeHtmlLn "ul.links li a {" + writeHtmlLn " padding: 0.2em 0.5em;" + writeHtmlLn "}" + writeHtmlLn "</style>"
Simulation/Aivika/Experiment/LastValueView.hs view
@@ -1,178 +1,178 @@---- |--- Module : Simulation.Aivika.Experiment.LastValueView--- Copyright : Copyright (c) 2012, David Sorokin <david.sorokin@gmail.com>--- License : BSD3--- Maintainer : David Sorokin <david.sorokin@gmail.com>--- 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 <david.sorokin@gmail.com> +-- License : BSD3 +-- Maintainer : David Sorokin <david.sorokin@gmail.com> +-- 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)
Simulation/Aivika/Experiment/TableView.hs view
@@ -1,245 +1,245 @@---- |--- Module : Simulation.Aivika.Experiment.TableView--- Copyright : Copyright (c) 2012, David Sorokin <david.sorokin@gmail.com>--- License : BSD3--- Maintainer : David Sorokin <david.sorokin@gmail.com>--- 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 <david.sorokin@gmail.com> +-- License : BSD3 +-- Maintainer : David Sorokin <david.sorokin@gmail.com> +-- 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)
Simulation/Aivika/Experiment/Utils.hs view
@@ -1,23 +1,23 @@---- |--- Module : Simulation.Aivika.Experiment.Utils--- Copyright : Copyright (c) 2012, David Sorokin <david.sorokin@gmail.com>--- License : BSD3--- Maintainer : David Sorokin <david.sorokin@gmail.com>--- 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 <david.sorokin@gmail.com> +-- License : BSD3 +-- Maintainer : David Sorokin <david.sorokin@gmail.com> +-- 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'
aivika-experiment.cabal view
@@ -1,45 +1,45 @@-name: aivika-experiment-version: 0.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 <david.sorokin@gmail.com>-author: David Sorokin-maintainer: David Sorokin <david.sorokin@gmail.com>-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.4.0.1,- aivika >= 0.4.3-- extensions: FlexibleInstances- - ghc-options: -O2+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 <david.sorokin@gmail.com> +author: David Sorokin +maintainer: David Sorokin <david.sorokin@gmail.com> +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
examples/MachRep3.hs view
@@ -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 = + "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