diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2012-2013 David Sorokin +Copyright (c) 2012, 2013, 2014 David Sorokin All rights reserved. diff --git a/Simulation/Aivika/Experiment.hs b/Simulation/Aivika/Experiment.hs --- a/Simulation/Aivika/Experiment.hs +++ b/Simulation/Aivika/Experiment.hs @@ -1,956 +1,45 @@ -{-# LANGUAGE FlexibleInstances #-} - -- | -- Module : Simulation.Aivika.Experiment --- Copyright : Copyright (c) 2012-2013, David Sorokin +-- Copyright : Copyright (c) 2012-2014, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental -- Tested with: GHC 7.6.3 -- --- The module defines the simulation experiments. They automate --- the process of generating and analyzing the results. Moreover, --- this module is open to extensions, allowing you to define --- your own output views for the simulation results, for example, --- such views that would allow saving the results in PDF or as --- charts. To decrease the number of dependencies, such possible --- extenstions are not included in this package, although simple --- views are provided. +-- This module re-exports the library functionality. -- module Simulation.Aivika.Experiment - (Experiment(..), - defaultExperiment, - runExperiment, - runExperimentParallel, - ExperimentData(..), - experimentDataInStartTime, - experimentSeriesProviders, - experimentMixedSignal, - Series(..), - SeriesContainer(..), - SeriesEntity(..), - SeriesProvider(..), - SeriesListWithSubscript, - SeriesArrayWithSubscript, - SeriesVectorWithSubscript, - seriesListWithSubscript, - seriesArrayWithSubscript, - seriesVectorWithSubscript, - View(..), - Generator(..), - Reporter(..), - DirectoryName(..), - resolveDirectoryName, - FileName(..), - resolveFileName) where - -import Control.Monad -import Control.Monad.State -import Control.Concurrent.ParallelIO.Local - -import qualified Data.Map as M -import qualified Data.Vector as V -import qualified Data.Vector.Unboxed as UV -import qualified Data.Array as A -import qualified Data.Array.Unboxed as UA - -import Data.Array (Array) -import Data.Array.Unboxed (UArray) -import Data.Array.IO - -import Data.Ix -import Data.Maybe -import Data.Monoid - -import qualified System.IO.UTF8 as UTF8 -import System.Directory -import System.FilePath (combine) - -import GHC.Conc (getNumCapabilities) - -import Simulation.Aivika.Specs -import Simulation.Aivika.Simulation -import Simulation.Aivika.Dynamics -import Simulation.Aivika.Event -import Simulation.Aivika.Signal -import Simulation.Aivika.Ref -import Simulation.Aivika.Var -import Simulation.Aivika.Parameter -import Simulation.Aivika.Statistics + (-- * Modules + module Simulation.Aivika.Experiment.Types, + module Simulation.Aivika.Experiment.HtmlWriter, + module Simulation.Aivika.Experiment.LastValueView, + module Simulation.Aivika.Experiment.TableView, + module Simulation.Aivika.Experiment.TimingStatsView, + module Simulation.Aivika.Experiment.TimingStatsWriter, + module Simulation.Aivika.Experiment.SamplingStatsWriter, + module Simulation.Aivika.Experiment.SamplingStatsSource, + module Simulation.Aivika.Experiment.FinalStatsView, + module Simulation.Aivika.Experiment.Histogram, + module Simulation.Aivika.Experiment.ExperimentSpecsView, + module Simulation.Aivika.Experiment.ExperimentSpecsWriter, + module Simulation.Aivika.Experiment.FinalTableView, + module Simulation.Aivika.Experiment.ListSource, + module Simulation.Aivika.Experiment.Utils) where +import Simulation.Aivika.Experiment.Types import Simulation.Aivika.Experiment.HtmlWriter -import Simulation.Aivika.Experiment.Utils (replace) - --- | 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. - experimentNumCapabilities :: IO Int - -- ^ The number of threads used for the Monte-Carlo simulation - -- if the executable was compiled with the support of multi-threading. - } - --- | The default experiment. -defaultExperiment :: Experiment -defaultExperiment = - Experiment { experimentSpecs = Specs 0 10 0.01 RungeKutta4, - experimentRunCount = 1, - experimentDirectoryName = UniqueDirectoryName "experiment", - experimentTitle = "Simulation Experiment", - experimentDescription = "", - experimentVerbose = True, - experimentGenerators = [], - experimentIndexHtml = createIndexHtml, - experimentNumCapabilities = getNumCapabilities } - --- | 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. --- --- The array and list of series are treated as a sequence of --- separate sub-series that have a subscript which can be --- optionally specified explicitly. By default, the subscript --- is numeric but it may be any string. --- --- At the same time, if the array or list of numeric values --- is wrapped in monads 'Simulation', 'Dynamics' or 'Event' then the --- underlying numeric array and list are already treated as --- a sampling statistics or list of numbers in time point. --- --- Moreover, if the array or list of numbers is contained in --- reference 'Ref' or variable 'Var' then the array and list --- of such values are also treated as a sampling statistics --- or list of numbers in time point. -class Series s where - - -- | Return the simulatable entity with the specified name - -- for the given series. - seriesEntity :: String -> s -> SeriesEntity - --- | Defines the simulatable entity. -data SeriesEntity = - SeriesEntity { seriesProviders :: [SeriesProvider] - -- ^ Return the providers for the entity. - } - --- | This is provider of the simulatable data. -data SeriesProvider = - SeriesProvider { providerName :: String, - -- ^ Return the name. - providerToDouble :: Maybe (Event Double), - -- ^ Try to return the data as double values. - providerToDoubleStats :: Maybe (Event (SamplingStats Double)), - -- ^ Try to return the statistics data in time points. - providerToDoubleList :: Maybe (Event [Double]), - -- ^ Try to return the list of double values. - providerToInt :: Maybe (Event Int), - -- ^ Try to return the data as integers. - providerToIntStats :: Maybe (Event (SamplingStats Int)), - -- ^ Try to return the statistics data in time points. - providerToIntList :: Maybe (Event [Int]), - -- ^ Try to return the list of integer values. - providerToString :: Maybe (Event String), - -- ^ Try to return the data as strings. - providerSignal :: Maybe (Signal ()) - -- ^ Try to get a signal for the data, which - -- is actual for the 'Ref' references and - -- the 'Var' variables. You should not provide - -- such a signal if the data are calculated - -- only in the integration time points, which - -- is true for the integrals, for example. - } - --- | It describes the source simulation data used in the experiment. -data ExperimentData = - ExperimentData { experimentSignalInIntegTimes :: Signal Double, - -- ^ The signal triggered in the integration time points. - experimentSignalInStartTime :: Signal Double, - -- ^ The signal triggered in the start time. - experimentSignalInStopTime :: Signal Double, - -- ^ The signal triggered in the stop time. - experimentSeries :: M.Map String SeriesEntity - -- ^ The simulation entitities with labels as keys. - } - --- | Prepare data for the simulation experiment in start time from the series --- with the specified labels. -experimentDataInStartTime :: [(String, SeriesEntity)] -> Simulation ExperimentData -experimentDataInStartTime m = runEventInStartTime IncludingEarlierEvents d where - d = do signalInIntegTimes <- newSignalInIntegTimes - signalInStartTime <- newSignalInStartTime - signalInStopTime <- newSignalInStopTime - let series = M.fromList m - return ExperimentData { experimentSignalInIntegTimes = signalInIntegTimes, - experimentSignalInStartTime = signalInStartTime, - experimentSignalInStopTime = signalInStopTime, - experimentSeries = series } - --- | Get a mixed signal for the specified providers based on --- the experimental data. This signal is triggered when --- the provided signals are triggered. The mixed signal is --- also triggered in the integration time points if there is --- at least one provider without signal. -experimentMixedSignal :: ExperimentData -> [SeriesProvider] -> Signal () -experimentMixedSignal expdata providers = - let xs0 = map providerSignal providers - xs1 = filter isJust xs0 - xs2 = filter isNothing xs0 - signal1 = mconcat $ map fromJust xs1 - signal2 = if null xs2 - then signal3 <> signal4 - else signal5 - signal3 = void $ experimentSignalInStartTime expdata - signal4 = void $ experimentSignalInStopTime expdata - signal5 = void $ experimentSignalInIntegTimes expdata - in signal1 <> signal2 - --- | Return the 'SeriesProvider' values from the experiment data by the specified labels. -experimentSeriesProviders :: ExperimentData -> [String] -> [SeriesProvider] -experimentSeriesProviders expdata labels = - join $ flip map labels $ \label -> - case M.lookup label (experimentSeries expdata) of - Nothing -> - error $ - "There is no series with label " ++ label ++ - ": experimentSeriesProviders" - Just entity -> - seriesProviders entity - --- | Defines what creates the simulation reports. -data 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 -> Event (Event ()), - -- ^ Start the simulation run in the start time - -- and return a finalizer that will be called - -- in the stop time after the last signal is - -- triggered and processed. - reporterTOCHtml :: Int -> HtmlWriter (), - -- ^ Return a TOC (Table of Contents) item for - -- the HTML index file after the finalisation - -- function is called, i.e. in the very end. - -- The agument specifies the ordered number of - -- the item. - -- - -- You should wrap your HTML in 'writeHtmlListItem'. - reporterHtml :: Int -> HtmlWriter () - -- ^ Return an HTML code for the index file - -- after the finalisation function is called, - -- i.e. in the very end. The agument specifies - -- the ordered number of the item. - } - --- | Run the simulation experiment sequentially. For example, --- it can be a Monte-Carlo simulation dependentent on the external --- 'Parameter' values. -runExperiment :: Experiment -> Simulation ExperimentData -> IO () -runExperiment = runExperimentWithExecutor sequence_ - --- | Run the simulation experiment parallelly. --- --- Make sure that you compile with @-threaded@ and supply @+RTS -N2 -RTS@ --- to the generated Haskell executable on dual core processor, --- or you won't get any parallelism. Generally, the mentioned --- @N@ parameter should correspond to the number of cores for --- your processor. --- --- In case of need you might want to specify the number of --- threads directly with help of 'experimentNumCapabilities', --- although the real number of parallel threads can depend on many --- factors. -runExperimentParallel :: Experiment -> Simulation ExperimentData -> IO () -runExperimentParallel e = runExperimentWithExecutor executor e - where executor tasks = - do n <- experimentNumCapabilities e - withPool n $ \pool -> - parallel_ pool tasks - --- | Run the simulation experiment with the specified executor. -runExperimentWithExecutor :: ([IO ()] -> IO ()) -> - Experiment -> - Simulation ExperimentData -> IO () -runExperimentWithExecutor executor e simulation = - do let specs = experimentSpecs e - runCount = experimentRunCount e - dirName = experimentDirectoryName e - generators = experimentGenerators e - path <- resolveDirectoryName Nothing dirName M.empty - when (experimentVerbose e) $ - do putStr "Using directory " - putStrLn path - createDirectoryIfMissing True path - reporters <- mapM (\x -> generateReporter x e path) - generators - forM_ reporters reporterInitialise - let simulate :: Simulation () - simulate = - do d <- simulation - fs <- runEventInStartTime IncludingEarlierEvents $ - forM reporters $ \reporter -> - reporterSimulate reporter d - runEventInStopTime IncludingCurrentEvents $ - sequence_ fs - executor $ runSimulations simulate specs runCount - forM_ reporters reporterFinalise - experimentIndexHtml e e reporters path - return () - --- | Create an index HTML file. -createIndexHtml :: Experiment -> [Reporter] -> FilePath -> IO () -createIndexHtml e reporters path = - do let html :: HtmlWriter () - html = - writeHtmlDocumentWithTitle (experimentTitle e) $ - do writeHtmlList $ - forM_ (zip [1..] reporters) $ \(i, reporter) -> - reporterTOCHtml reporter i - writeHtmlBreak - unless (null $ experimentDescription e) $ - writeHtmlParagraph $ - writeHtmlText $ experimentDescription e - forM_ (zip [1..] reporters) $ \(i, reporter) -> - reporterHtml reporter i - file = combine path "index.html" - ((), contents) <- runHtmlWriter html id - UTF8.writeFile file (contents []) - when (experimentVerbose e) $ - do putStr "Generated file " - putStrLn file - --- | Specifies the directory name, unique or writable. -data DirectoryName = WritableDirectoryName String - -- ^ The directory which is overwritten in - -- case if it existed before. - | UniqueDirectoryName String - -- ^ The directory which is always unique, - -- when a prefix is added to the name - -- in case of need. - --- | Specifies the file name, unique or writable. -data FileName = WritableFileName String String - -- ^ The file which is overwritten in - -- case if it existed before. The first - -- field defines a name or its prototype. - -- The second field is the file extension. - | UniqueFileName String String - -- ^ The file which is always unique, - -- when a prefix is added to the name - -- in case of need. The first field - -- defines a name or its prototype. - -- The second field is the file exension. - --- | Resolve the directory name relative to the passed in directory --- as the first argument, replacing the specified strings according the map. -resolveDirectoryName :: Maybe FilePath -> DirectoryName -> M.Map String String -> IO String -resolveDirectoryName dir (WritableDirectoryName name) map = - return $ replaceName (combineName dir name) map -resolveDirectoryName dir (UniqueDirectoryName name) map = - let x = replaceName name map - loop y i = - do let n = combineName dir y - f1 <- doesFileExist n - f2 <- doesDirectoryExist n - if f1 || f2 - then loop (x ++ "(" ++ show i ++ ")") (i + 1) - else return n - in loop x 2 - --- | Resolve the file name relative to the passed in directory --- as the first argument, replacing the specified strings according the map. -resolveFileName :: Maybe FilePath -> FileName -> M.Map String String -> IO String -resolveFileName dir (WritableFileName name ext) map = - return $ replaceName (combineName dir name ++ ext) map -resolveFileName dir (UniqueFileName name ext) map = - let x = replaceName name map - loop y i = - do let n = combineName dir y ++ ext - f1 <- doesFileExist n - f2 <- doesDirectoryExist n - if f1 || f2 - then loop (x ++ "(" ++ show i ++ ")") (i + 1) - else return n - in loop x 2 - --- | Replace the name according the specified table. -replaceName :: String -> M.Map String String -> String -replaceName name map = name' where - ((), name') = flip runState name $ - forM_ (M.assocs map) $ \(k, v) -> - do a <- get - put $ replace k v a - --- | Combine the file name with the directory name. -combineName :: Maybe String -> String -> String -combineName dir name = - case dir of - Nothing -> name - Just dir -> combine dir name - --- | Represent a container for simulation data. -class SeriesContainer c where - - -- | Extract data from the container. - containerData :: c a -> Event a - - -- | Get the signal for the container. - containerSignal :: c a => Maybe (Signal ()) - -instance SeriesContainer Simulation where - - containerData = liftSimulation - - containerSignal = const Nothing - -instance SeriesContainer Dynamics where - - containerData = liftDynamics - - containerSignal = const Nothing - -instance SeriesContainer Event where - - containerData = id - - containerSignal = const Nothing - -instance SeriesContainer Ref where - - containerData = readRef - - containerSignal = Just . refChanged_ - -instance SeriesContainer Var where - - containerData = readVar - - containerSignal = Just . varChanged_ - -instance SeriesContainer c => Series (c Double) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = - Just $ - containerData s, - providerToDoubleStats = - Just $ - fmap returnSamplingStats $ - containerData s, - providerToDoubleList = - Just $ - fmap return $ - containerData s, - providerToInt = Nothing, - providerToIntStats = Nothing, - providerToIntList = Nothing, - providerToString = - Just $ - fmap show $ - containerData s, - providerSignal = - containerSignal s }] } - -instance SeriesContainer c => Series (c Int) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = - Just $ - fmap fromIntegral $ - containerData s, - providerToDoubleStats = - Just $ - fmap returnSamplingStats $ - fmap fromIntegral $ - containerData s, - providerToDoubleList = - Just $ - fmap return $ - fmap fromIntegral $ - containerData s, - providerToInt = - Just $ - containerData s, - providerToIntStats = - Just $ - fmap returnSamplingStats $ - containerData s, - providerToIntList = - Just $ - fmap return $ - containerData s, - providerToString = - Just $ - fmap show $ - containerData s, - providerSignal = - containerSignal s }] } - -instance SeriesContainer c => Series (c String) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = Nothing, - providerToDoubleList = Nothing, - providerToInt = Nothing, - providerToIntStats = Nothing, - providerToIntList = Nothing, - providerToString = - Just $ - containerData s, - providerSignal = - containerSignal s }] } - -instance Series s => Series [s] where - - seriesEntity name s = - SeriesEntity { seriesProviders = - join $ forM (zip [0..] s) $ \(i, s) -> - let name' = name ++ "[" ++ show i ++ "]" - in seriesProviders $ seriesEntity name' s } - -instance (Show i, Ix i, Series s) => Series (Array i s) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - join $ forM (A.assocs s) $ \(i, s) -> - let name' = name ++ "[" ++ show i ++ "]" - in seriesProviders $ seriesEntity name' s } - -instance Series s => Series (V.Vector s) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - join $ forM (zip [0..] (V.toList s)) $ \(i, s) -> - let name' = name ++ "[" ++ show i ++ "]" - in seriesProviders $ seriesEntity name' s } - --- | Represents a list with the specified subscript. -data SeriesListWithSubscript s = - SeriesListWithSubscript { seriesList :: [s], - seriesListSubscript :: [String] } - --- | Represents an array with the specified subscript. -data SeriesArrayWithSubscript i s = - SeriesArrayWithSubscript { seriesArray :: Array i s, - seriesArraySubscript :: Array i String } - --- | Represents a vector with the specified subscript. -data SeriesVectorWithSubscript s = - SeriesVectorWithSubscript { seriesVector :: V.Vector s, - seriesVectorSubscript :: V.Vector String } - --- | Add the specified subscript to the list. -seriesListWithSubscript :: Series s - => [s] - -- ^ the list to subscript - -> [String] - -- ^ the list of subscripts - -> SeriesListWithSubscript s - -- ^ the subscripted list -seriesListWithSubscript = SeriesListWithSubscript - --- | Add the specified subscript to the array. -seriesArrayWithSubscript :: (Ix i, Series s) - => Array i s - -- ^ the array to subscript - -> Array i String - -- ^ the array of subscripts - -> SeriesArrayWithSubscript i s - -- ^ the subscripted array -seriesArrayWithSubscript = SeriesArrayWithSubscript - --- | Add the specified subscript to the vector. -seriesVectorWithSubscript :: Series s - => V.Vector s - -- ^ the vector to subscript - -> V.Vector String - -- ^ the vector of subscripts - -> SeriesVectorWithSubscript s - -- ^ the subscripted vector -seriesVectorWithSubscript = SeriesVectorWithSubscript - -instance Series s => Series (SeriesListWithSubscript s) where - - seriesEntity name s = - SeriesEntity { seriesProviders = do - let xs = seriesList s - ns = seriesListSubscript s - join $ forM (zip3 [1..] xs ns) $ \(i, s, n) -> - let name' = name ++ n - in seriesProviders $ seriesEntity name' s } - -instance (Ix i, Series s) => Series (SeriesArrayWithSubscript i s) where - - seriesEntity name s = - SeriesEntity { seriesProviders = do - let xs = seriesArray s - ns = seriesArraySubscript s - join $ forM (zip (A.assocs xs) (A.elems ns)) $ \((i, s), n) -> - let name' = name ++ n - in seriesProviders $ seriesEntity name' s } - -instance Series s => Series (SeriesVectorWithSubscript s) where - - seriesEntity name s = - SeriesEntity { seriesProviders = do - let xs = seriesVector s - ns = seriesVectorSubscript s - join $ forM (zip (V.toList xs) (V.toList ns)) $ \(x, n) -> - let name' = name ++ n - in seriesProviders $ seriesEntity name' x } - -instance SeriesContainer c => Series (c (SamplingStats Double)) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = - Just $ - containerData s, - providerToDoubleList = Nothing, - providerToInt = Nothing, - providerToIntStats = Nothing, - providerToIntList = Nothing, - providerToString = Nothing, - providerSignal = - containerSignal s } ] } - -instance SeriesContainer c => Series (c (SamplingStats Int)) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = - Just $ - fmap fromIntSamplingStats $ - containerData s, - providerToDoubleList = Nothing, - providerToInt = Nothing, - providerToIntStats = - Just $ - containerData s, - providerToIntList = Nothing, - providerToString = Nothing, - providerSignal = - containerSignal s } ] } - -instance SeriesContainer c => Series (c [Double]) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = - Just $ - fmap listSamplingStats $ - containerData s, - providerToDoubleList = - Just $ - containerData s, - providerToInt = Nothing, - providerToIntStats = Nothing, - providerToIntList = Nothing, - providerToString = - Just $ - fmap show $ - containerData s, - providerSignal = - containerSignal s } ] } - -instance SeriesContainer c => Series (c [Int]) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = - Just $ - fmap fromIntSamplingStats $ - fmap listSamplingStats $ - containerData s, - providerToDoubleList = - Just $ - fmap (map fromIntegral) $ - containerData s, - providerToInt = Nothing, - providerToIntStats = - Just $ - fmap listSamplingStats $ - containerData s, - providerToIntList = - Just $ - containerData s, - providerToString = - Just $ - fmap show $ - containerData s, - providerSignal = - containerSignal s } ] } - -instance (Ix i, SeriesContainer c) => Series (c (Array i Double)) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = - Just $ - fmap listSamplingStats $ - fmap A.elems $ - containerData s, - providerToDoubleList = - Just $ - fmap A.elems $ - containerData s, - providerToInt = Nothing, - providerToIntStats = Nothing, - providerToIntList = Nothing, - providerToString = Nothing, - providerSignal = - containerSignal s } ] } - -instance (Ix i, SeriesContainer c) => Series (c (Array i Int)) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = - Just $ - fmap fromIntSamplingStats $ - fmap listSamplingStats $ - fmap A.elems $ - containerData s, - providerToDoubleList = - Just $ - fmap (map fromIntegral) $ - fmap A.elems $ - containerData s, - providerToInt = Nothing, - providerToIntStats = - Just $ - fmap listSamplingStats $ - fmap A.elems $ - containerData s, - providerToIntList = - Just $ - fmap A.elems $ - containerData s, - providerToString = Nothing, - providerSignal = - containerSignal s } ] } - -instance (Ix i, SeriesContainer c) => Series (c (UArray i Double)) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = - Just $ - fmap listSamplingStats $ - fmap UA.elems $ - containerData s, - providerToDoubleList = - Just $ - fmap UA.elems $ - containerData s, - providerToInt = Nothing, - providerToIntStats = Nothing, - providerToIntList = Nothing, - providerToString = Nothing, - providerSignal = - containerSignal s } ] } - -instance (Ix i, SeriesContainer c) => Series (c (UArray i Int)) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = - Just $ - fmap fromIntSamplingStats $ - fmap listSamplingStats $ - fmap UA.elems $ - containerData s, - providerToDoubleList = - Just $ - fmap (map fromIntegral) $ - fmap UA.elems $ - containerData s, - providerToInt = Nothing, - providerToIntStats = - Just $ - fmap listSamplingStats $ - fmap UA.elems $ - containerData s, - providerToIntList = - Just $ - fmap UA.elems $ - containerData s, - providerToString = Nothing, - providerSignal = - containerSignal s } ] } - -instance SeriesContainer c => Series (c (V.Vector Double)) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = - Just $ - fmap listSamplingStats $ - fmap V.toList $ - containerData s, - providerToDoubleList = - Just $ - fmap V.toList $ - containerData s, - providerToInt = Nothing, - providerToIntStats = Nothing, - providerToIntList = Nothing, - providerToString = - Just $ - fmap show $ - containerData s, - providerSignal = - containerSignal s } ] } - -instance SeriesContainer c => Series (c (V.Vector Int)) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = - Just $ - fmap fromIntSamplingStats $ - fmap listSamplingStats $ - fmap V.toList $ - containerData s, - providerToDoubleList = - Just $ - fmap (map fromIntegral) $ - fmap V.toList $ - containerData s, - providerToInt = Nothing, - providerToIntStats = - Just $ - fmap listSamplingStats $ - fmap V.toList $ - containerData s, - providerToIntList = - Just $ - fmap V.toList $ - containerData s, - providerToString = - Just $ - fmap show $ - containerData s, - providerSignal = - containerSignal s }] } - -instance SeriesContainer c => Series (c (UV.Vector Double)) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = - Just $ - fmap listSamplingStats $ - fmap UV.toList $ - containerData s, - providerToDoubleList = - Just $ - fmap UV.toList $ - containerData s, - providerToInt = Nothing, - providerToIntStats = Nothing, - providerToIntList = Nothing, - providerToString = - Just $ - fmap show $ - containerData s, - providerSignal = - containerSignal s } ] } - -instance SeriesContainer c => Series (c (UV.Vector Int)) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = - Just $ - fmap fromIntSamplingStats $ - fmap listSamplingStats $ - fmap UV.toList $ - containerData s, - providerToDoubleList = - Just $ - fmap (map fromIntegral) $ - fmap UV.toList $ - containerData s, - providerToInt = Nothing, - providerToIntStats = - Just $ - fmap listSamplingStats $ - fmap UV.toList $ - containerData s, - providerToIntList = - Just $ - fmap UV.toList $ - containerData s, - providerToString = - Just $ - fmap show $ - containerData s, - providerSignal = - containerSignal s } ] } +import Simulation.Aivika.Experiment.LastValueView +import Simulation.Aivika.Experiment.TableView +import Simulation.Aivika.Experiment.TimingStatsView +import Simulation.Aivika.Experiment.TimingStatsWriter +import Simulation.Aivika.Experiment.SamplingStatsWriter +import Simulation.Aivika.Experiment.SamplingStatsSource +import Simulation.Aivika.Experiment.FinalStatsView +import Simulation.Aivika.Experiment.Histogram +import Simulation.Aivika.Experiment.ExperimentSpecsView +import Simulation.Aivika.Experiment.ExperimentSpecsWriter +import Simulation.Aivika.Experiment.FinalTableView +import Simulation.Aivika.Experiment.ListSource +import Simulation.Aivika.Experiment.Utils diff --git a/Simulation/Aivika/Experiment/ExperimentSpecsView.hs b/Simulation/Aivika/Experiment/ExperimentSpecsView.hs --- a/Simulation/Aivika/Experiment/ExperimentSpecsView.hs +++ b/Simulation/Aivika/Experiment/ExperimentSpecsView.hs @@ -18,7 +18,7 @@ import Control.Monad import Control.Monad.Trans -import Simulation.Aivika.Experiment +import Simulation.Aivika.Experiment.Types import Simulation.Aivika.Experiment.HtmlWriter import Simulation.Aivika.Experiment.ExperimentSpecsWriter @@ -39,17 +39,17 @@ experimentSpecsDescription = "It shows the experiment specs.", experimentSpecsWriter = defaultExperimentSpecsWriter } -instance View ExperimentSpecsView where +instance ExperimentView ExperimentSpecsView where outputView v = let reporter exp dir = do st <- newExperimentSpecs v exp - return Reporter { reporterInitialise = return (), - reporterFinalise = return (), - reporterSimulate = const $ return $ return (), - reporterTOCHtml = experimentSpecsTOCHtml st, - reporterHtml = experimentSpecsHtml st } - in Generator { generateReporter = reporter } + return ExperimentReporter { reporterInitialise = return (), + reporterFinalise = return (), + reporterSimulate = const $ return $ return (), + reporterTOCHtml = experimentSpecsTOCHtml st, + reporterHtml = experimentSpecsHtml st } + in ExperimentGenerator { generateReporter = reporter } -- | The state of the view. data ExperimentSpecsViewState = diff --git a/Simulation/Aivika/Experiment/ExperimentSpecsWriter.hs b/Simulation/Aivika/Experiment/ExperimentSpecsWriter.hs --- a/Simulation/Aivika/Experiment/ExperimentSpecsWriter.hs +++ b/Simulation/Aivika/Experiment/ExperimentSpecsWriter.hs @@ -16,7 +16,7 @@ (ExperimentSpecsWriter(..), defaultExperimentSpecsWriter) where -import Simulation.Aivika.Experiment +import Simulation.Aivika.Experiment.Types import Simulation.Aivika.Experiment.HtmlWriter import Simulation.Aivika.Specs diff --git a/Simulation/Aivika/Experiment/FinalStatsView.hs b/Simulation/Aivika/Experiment/FinalStatsView.hs --- a/Simulation/Aivika/Experiment/FinalStatsView.hs +++ b/Simulation/Aivika/Experiment/FinalStatsView.hs @@ -22,7 +22,7 @@ import Data.IORef import Data.Maybe -import Simulation.Aivika.Experiment +import Simulation.Aivika.Experiment.Types import Simulation.Aivika.Experiment.HtmlWriter import Simulation.Aivika.Experiment.SamplingStatsWriter import Simulation.Aivika.Experiment.SamplingStatsSource @@ -59,17 +59,17 @@ finalStatsPredicate = return True, finalStatsSeries = [] } -instance View FinalStatsView where +instance ExperimentView FinalStatsView where outputView v = let reporter exp dir = do st <- newFinalStats v exp dir - return Reporter { reporterInitialise = return (), - reporterFinalise = return (), - reporterSimulate = simulateFinalStats st, - reporterTOCHtml = finalStatsTOCHtml st, - reporterHtml = finalStatsHtml st } - in Generator { generateReporter = reporter } + return ExperimentReporter { reporterInitialise = return (), + reporterFinalise = return (), + reporterSimulate = simulateFinalStats st, + reporterTOCHtml = finalStatsTOCHtml st, + reporterHtml = finalStatsHtml st } + in ExperimentGenerator { generateReporter = reporter } -- | The state of the view. data FinalStatsViewState = diff --git a/Simulation/Aivika/Experiment/FinalTableView.hs b/Simulation/Aivika/Experiment/FinalTableView.hs --- a/Simulation/Aivika/Experiment/FinalTableView.hs +++ b/Simulation/Aivika/Experiment/FinalTableView.hs @@ -27,10 +27,11 @@ import System.IO import System.FilePath -import Simulation.Aivika.Experiment +import Simulation.Aivika.Experiment.Types import Simulation.Aivika.Experiment.HtmlWriter import Simulation.Aivika.Specs +import Simulation.Aivika.Parameter import Simulation.Aivika.Simulation import Simulation.Aivika.Event import Simulation.Aivika.Signal @@ -93,17 +94,17 @@ finalTablePredicate = return True, finalTableSeries = [] } -instance View FinalTableView where +instance ExperimentView FinalTableView where outputView v = let reporter exp dir = do st <- newFinalTable v exp dir - return Reporter { reporterInitialise = return (), - reporterFinalise = finaliseFinalTable st, - reporterSimulate = simulateFinalTable st, - reporterTOCHtml = finalTableTOCHtml st, - reporterHtml = finalTableHtml st } - in Generator { generateReporter = reporter } + return ExperimentReporter { reporterInitialise = return (), + reporterFinalise = finaliseFinalTable st, + reporterSimulate = simulateFinalTable st, + reporterTOCHtml = finalTableTOCHtml st, + reporterHtml = finalTableHtml st } + in ExperimentGenerator { generateReporter = reporter } -- | The state of the view. data FinalTableViewState = @@ -171,7 +172,7 @@ experimentSignalInStopTime expdata handleSignal_ h $ \_ -> do xs <- sequence input - i <- liftSimulation simulationIndex + i <- liftParameter simulationIndex liftIO $ withMVar lock $ \() -> modifyIORef values $ M.insert i xs return $ return () diff --git a/Simulation/Aivika/Experiment/LastValueView.hs b/Simulation/Aivika/Experiment/LastValueView.hs --- a/Simulation/Aivika/Experiment/LastValueView.hs +++ b/Simulation/Aivika/Experiment/LastValueView.hs @@ -22,11 +22,12 @@ import Data.IORef import Data.Maybe -import Simulation.Aivika.Experiment +import Simulation.Aivika.Experiment.Types import Simulation.Aivika.Experiment.HtmlWriter import Simulation.Aivika.Experiment.Utils (replace) import Simulation.Aivika.Specs +import Simulation.Aivika.Parameter import Simulation.Aivika.Simulation import Simulation.Aivika.Event import Simulation.Aivika.Signal @@ -63,17 +64,17 @@ lastValueFormatter = id, lastValueSeries = [] } -instance View LastValueView where +instance ExperimentView 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 } + return ExperimentReporter { reporterInitialise = return (), + reporterFinalise = return (), + reporterSimulate = simulateLastValues st, + reporterTOCHtml = lastValueTOCHtml st, + reporterHtml = lastValueHtml st } + in ExperimentGenerator { generateReporter = reporter } -- | The state of the view. data LastValueViewState = @@ -103,7 +104,7 @@ providerName provider ++ " as a string: simulateLastValues" Just input -> (providerName provider, input) - i <- liftSimulation simulationIndex + i <- liftParameter simulationIndex handleSignal_ (experimentSignalInStopTime expdata) $ \t -> do let r = fromJust $ M.lookup (i - 1) (lastValueMap st) output <- forM input $ \(name, input) -> diff --git a/Simulation/Aivika/Experiment/ListSource.hs b/Simulation/Aivika/Experiment/ListSource.hs --- a/Simulation/Aivika/Experiment/ListSource.hs +++ b/Simulation/Aivika/Experiment/ListSource.hs @@ -27,7 +27,7 @@ import Simulation.Aivika.Event import Simulation.Aivika.Statistics -import Simulation.Aivika.Experiment +import Simulation.Aivika.Experiment.Types -- | Represents the optimized source of data for constructing the list. data ListSource a = SingleValueSource (Event a) diff --git a/Simulation/Aivika/Experiment/SamplingStatsSource.hs b/Simulation/Aivika/Experiment/SamplingStatsSource.hs --- a/Simulation/Aivika/Experiment/SamplingStatsSource.hs +++ b/Simulation/Aivika/Experiment/SamplingStatsSource.hs @@ -20,7 +20,7 @@ import Simulation.Aivika.Event import Simulation.Aivika.Statistics -import Simulation.Aivika.Experiment +import Simulation.Aivika.Experiment.Types -- | Represents the optimized source of data for the statistics. data SamplingStatsSource a = SingleValueSource (Event a) diff --git a/Simulation/Aivika/Experiment/SamplingStatsWriter.hs b/Simulation/Aivika/Experiment/SamplingStatsWriter.hs --- a/Simulation/Aivika/Experiment/SamplingStatsWriter.hs +++ b/Simulation/Aivika/Experiment/SamplingStatsWriter.hs @@ -15,7 +15,7 @@ (SamplingStatsWriter(..), defaultSamplingStatsWriter) where -import Simulation.Aivika.Experiment +import Simulation.Aivika.Experiment.Types import Simulation.Aivika.Experiment.HtmlWriter import Simulation.Aivika.Statistics diff --git a/Simulation/Aivika/Experiment/TableView.hs b/Simulation/Aivika/Experiment/TableView.hs --- a/Simulation/Aivika/Experiment/TableView.hs +++ b/Simulation/Aivika/Experiment/TableView.hs @@ -25,11 +25,12 @@ import System.IO import System.FilePath -import Simulation.Aivika.Experiment +import Simulation.Aivika.Experiment.Types import Simulation.Aivika.Experiment.HtmlWriter import Simulation.Aivika.Experiment.Utils (replace) import Simulation.Aivika.Specs +import Simulation.Aivika.Parameter import Simulation.Aivika.Simulation import Simulation.Aivika.Event import Simulation.Aivika.Signal @@ -111,17 +112,17 @@ tablePredicate = return True, tableSeries = [] } -instance View TableView where +instance ExperimentView 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 } + return ExperimentReporter { reporterInitialise = return (), + reporterFinalise = return (), + reporterSimulate = simulateTable st, + reporterTOCHtml = tableTOCHtml st, + reporterHtml = tableHtml st } + in ExperimentGenerator { generateReporter = reporter } -- | The state of the view. data TableViewState = @@ -162,7 +163,7 @@ separator = tableSeparator $ tableView st formatter = tableFormatter $ tableView st predicate = tablePredicate $ tableView st - i <- liftSimulation simulationIndex + i <- liftParameter simulationIndex -- create a new file let f = fromJust $ M.lookup (i - 1) (tableMap st) h <- liftIO $ openFile f WriteMode diff --git a/Simulation/Aivika/Experiment/TimingStatsView.hs b/Simulation/Aivika/Experiment/TimingStatsView.hs --- a/Simulation/Aivika/Experiment/TimingStatsView.hs +++ b/Simulation/Aivika/Experiment/TimingStatsView.hs @@ -22,12 +22,13 @@ import Data.IORef import Data.Maybe -import Simulation.Aivika.Experiment +import Simulation.Aivika.Experiment.Types import Simulation.Aivika.Experiment.HtmlWriter import Simulation.Aivika.Experiment.TimingStatsWriter import Simulation.Aivika.Experiment.Utils (replace) import Simulation.Aivika.Specs +import Simulation.Aivika.Parameter import Simulation.Aivika.Simulation import Simulation.Aivika.Dynamics import Simulation.Aivika.Event @@ -69,17 +70,17 @@ timingStatsPredicate = return True, timingStatsSeries = [] } -instance View TimingStatsView where +instance ExperimentView TimingStatsView where outputView v = let reporter exp dir = do st <- newTimingStats v exp - return Reporter { reporterInitialise = return (), - reporterFinalise = return (), - reporterSimulate = simulateTimingStats st, - reporterTOCHtml = timingStatsTOCHtml st, - reporterHtml = timingStatsHtml st } - in Generator { generateReporter = reporter } + return ExperimentReporter { reporterInitialise = return (), + reporterFinalise = return (), + reporterSimulate = simulateTimingStats st, + reporterTOCHtml = timingStatsTOCHtml st, + reporterHtml = timingStatsHtml st } + in ExperimentGenerator { generateReporter = reporter } -- | The state of the view. data TimingStatsViewState = @@ -110,7 +111,7 @@ " as double values: simulateTimingStats" Just input -> (provider, input) predicate = timingStatsPredicate $ timingStatsView st - i <- liftSimulation simulationIndex + i <- liftParameter simulationIndex let r = fromJust $ M.lookup (i - 1) $ timingStatsMap st forM_ labels $ \label -> do let providers = experimentSeriesProviders expdata [label] diff --git a/Simulation/Aivika/Experiment/TimingStatsWriter.hs b/Simulation/Aivika/Experiment/TimingStatsWriter.hs --- a/Simulation/Aivika/Experiment/TimingStatsWriter.hs +++ b/Simulation/Aivika/Experiment/TimingStatsWriter.hs @@ -15,7 +15,7 @@ (TimingStatsWriter(..), defaultTimingStatsWriter) where -import Simulation.Aivika.Experiment +import Simulation.Aivika.Experiment.Types import Simulation.Aivika.Experiment.HtmlWriter import Simulation.Aivika.Statistics diff --git a/Simulation/Aivika/Experiment/Types.hs b/Simulation/Aivika/Experiment/Types.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Experiment/Types.hs @@ -0,0 +1,961 @@ + +{-# LANGUAGE FlexibleInstances #-} + +-- | +-- Module : Simulation.Aivika.Experiment.Types +-- Copyright : Copyright (c) 2012-2013, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.6.3 +-- +-- The module defines the simulation experiments. They automate +-- the process of generating and analyzing the results. Moreover, +-- this module is open to extensions, allowing you to define +-- your own output views for the simulation results, for example, +-- such views that would allow saving the results in PDF or as +-- charts. To decrease the number of dependencies, such possible +-- extenstions are not included in this package, although simple +-- views are provided. +-- + +module Simulation.Aivika.Experiment.Types + (Experiment(..), + defaultExperiment, + runExperiment, + runExperimentParallel, + ExperimentData(..), + experimentDataInStartTime, + experimentSeriesProviders, + experimentMixedSignal, + Series(..), + SeriesContainer(..), + SeriesEntity(..), + SeriesProvider(..), + SeriesListWithSubscript, + SeriesArrayWithSubscript, + SeriesVectorWithSubscript, + seriesListWithSubscript, + seriesArrayWithSubscript, + seriesVectorWithSubscript, + ExperimentView(..), + ExperimentGenerator(..), + ExperimentReporter(..), + DirectoryName(..), + resolveDirectoryName, + FileName(..), + resolveFileName) where + +import Control.Monad +import Control.Monad.State +import Control.Concurrent.ParallelIO.Local + +import qualified Data.Map as M +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as UV +import qualified Data.Array as A +import qualified Data.Array.Unboxed as UA + +import Data.Array (Array) +import Data.Array.Unboxed (UArray) +import Data.Array.IO + +import Data.Ix +import Data.Maybe +import Data.Monoid + +import qualified System.IO.UTF8 as UTF8 +import System.Directory +import System.FilePath (combine) + +import GHC.Conc (getNumCapabilities) + +import Simulation.Aivika hiding (Var, readVar, varChanged_) +import Simulation.Aivika.Var + +import Simulation.Aivika.Experiment.HtmlWriter +import Simulation.Aivika.Experiment.Utils (replace) + +-- | 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 :: [ExperimentGenerator], + -- ^ The experiment generators. + experimentIndexHtml :: Experiment -> [ExperimentReporter] -> FilePath -> IO (), + -- ^ Create the @index.html@ file after the simulation is finished + -- in the specified directory. + experimentNumCapabilities :: IO Int + -- ^ The number of threads used for the Monte-Carlo simulation + -- if the executable was compiled with the support of multi-threading. + } + +-- | The default experiment. +defaultExperiment :: Experiment +defaultExperiment = + Experiment { experimentSpecs = Specs 0 10 0.01 RungeKutta4 SimpleGenerator, + experimentRunCount = 1, + experimentDirectoryName = UniqueDirectoryName "experiment", + experimentTitle = "Simulation Experiment", + experimentDescription = "", + experimentVerbose = True, + experimentGenerators = [], + experimentIndexHtml = createIndexHtml, + experimentNumCapabilities = getNumCapabilities } + +-- | This is a generator of the reporter. +data ExperimentGenerator = + ExperimentGenerator { generateReporter :: Experiment -> FilePath -> IO ExperimentReporter + -- ^ 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 ExperimentView v where + + -- | Create a generator of the reporter. + outputView :: v -> ExperimentGenerator + +-- | Represents the series. It is usually something, or +-- an array of something, or a list of such values which +-- can be simulated. +-- +-- The array and list of series are treated as a sequence of +-- separate sub-series that have a subscript which can be +-- optionally specified explicitly. By default, the subscript +-- is numeric but it may be any string. +-- +-- At the same time, if the array or list of numeric values +-- is wrapped in monads 'Simulation', 'Dynamics' or 'Event' then the +-- underlying numeric array and list are already treated as +-- a sampling statistics or list of numbers in time point. +-- +-- Moreover, if the array or list of numbers is contained in +-- reference 'Ref' or variable 'Var' then the array and list +-- of such values are also treated as a sampling statistics +-- or list of numbers in time point. +class Series s where + + -- | Return the simulatable entity with the specified name + -- for the given series. + seriesEntity :: String -> s -> SeriesEntity + +-- | Defines the simulatable entity. +data SeriesEntity = + SeriesEntity { seriesProviders :: [SeriesProvider] + -- ^ Return the providers for the entity. + } + +-- | This is provider of the simulatable data. +data SeriesProvider = + SeriesProvider { providerName :: String, + -- ^ Return the name. + providerToDouble :: Maybe (Event Double), + -- ^ Try to return the data as double values. + providerToDoubleStats :: Maybe (Event (SamplingStats Double)), + -- ^ Try to return the statistics data in time points. + providerToDoubleList :: Maybe (Event [Double]), + -- ^ Try to return the list of double values. + providerToInt :: Maybe (Event Int), + -- ^ Try to return the data as integers. + providerToIntStats :: Maybe (Event (SamplingStats Int)), + -- ^ Try to return the statistics data in time points. + providerToIntList :: Maybe (Event [Int]), + -- ^ Try to return the list of integer values. + providerToString :: Maybe (Event String), + -- ^ Try to return the data as strings. + providerSignal :: Maybe (Signal ()) + -- ^ Try to get a signal for the data, which + -- is actual for the 'Ref' references and + -- the 'Var' variables. You should not provide + -- such a signal if the data are calculated + -- only in the integration time points, which + -- is true for the integrals, for example. + } + +-- | It describes the source simulation data used in the experiment. +data ExperimentData = + ExperimentData { experimentSignalInIntegTimes :: Signal Double, + -- ^ The signal triggered in the integration time points. + experimentSignalInStartTime :: Signal Double, + -- ^ The signal triggered in the start time. + experimentSignalInStopTime :: Signal Double, + -- ^ The signal triggered in the stop time. + experimentSeries :: M.Map String SeriesEntity + -- ^ The simulation entitities with labels as keys. + } + +-- | Prepare data for the simulation experiment in start time from the series +-- with the specified labels. +experimentDataInStartTime :: [(String, SeriesEntity)] -> Simulation ExperimentData +experimentDataInStartTime m = runEventInStartTime IncludingEarlierEvents d where + d = do signalInIntegTimes <- newSignalInIntegTimes + signalInStartTime <- newSignalInStartTime + signalInStopTime <- newSignalInStopTime + let series = M.fromList m + return ExperimentData { experimentSignalInIntegTimes = signalInIntegTimes, + experimentSignalInStartTime = signalInStartTime, + experimentSignalInStopTime = signalInStopTime, + experimentSeries = series } + +-- | Get a mixed signal for the specified providers based on +-- the experimental data. This signal is triggered when +-- the provided signals are triggered. The mixed signal is +-- also triggered in the integration time points if there is +-- at least one provider without signal. +experimentMixedSignal :: ExperimentData -> [SeriesProvider] -> Signal () +experimentMixedSignal expdata providers = + let xs0 = map providerSignal providers + xs1 = filter isJust xs0 + xs2 = filter isNothing xs0 + signal1 = mconcat $ map fromJust xs1 + signal2 = if null xs2 + then signal3 <> signal4 + else signal5 + signal3 = void $ experimentSignalInStartTime expdata + signal4 = void $ experimentSignalInStopTime expdata + signal5 = void $ experimentSignalInIntegTimes expdata + in signal1 <> signal2 + +-- | Return the 'SeriesProvider' values from the experiment data by the specified labels. +experimentSeriesProviders :: ExperimentData -> [String] -> [SeriesProvider] +experimentSeriesProviders expdata labels = + join $ flip map labels $ \label -> + case M.lookup label (experimentSeries expdata) of + Nothing -> + error $ + "There is no series with label " ++ label ++ + ": experimentSeriesProviders" + Just entity -> + seriesProviders entity + +-- | Defines what creates the simulation reports. +data ExperimentReporter = + ExperimentReporter { reporterInitialise :: IO (), + -- ^ Initialise the reporting before + -- the simulation runs are started. + reporterFinalise :: IO (), + -- ^ Finalise the reporting after + -- all simulation runs are finished. + reporterSimulate :: ExperimentData -> Event (Event ()), + -- ^ Start the simulation run in the start time + -- and return a finalizer that will be called + -- in the stop time after the last signal is + -- triggered and processed. + reporterTOCHtml :: Int -> HtmlWriter (), + -- ^ Return a TOC (Table of Contents) item for + -- the HTML index file after the finalisation + -- function is called, i.e. in the very end. + -- The agument specifies the ordered number of + -- the item. + -- + -- You should wrap your HTML in 'writeHtmlListItem'. + reporterHtml :: Int -> HtmlWriter () + -- ^ Return an HTML code for the index file + -- after the finalisation function is called, + -- i.e. in the very end. The agument specifies + -- the ordered number of the item. + } + +-- | Run the simulation experiment sequentially. For example, +-- it can be a Monte-Carlo simulation dependentent on the external +-- 'Parameter' values. +runExperiment :: Experiment -> Simulation ExperimentData -> IO () +runExperiment = runExperimentWithExecutor sequence_ + +-- | Run the simulation experiment parallelly. +-- +-- Make sure that you compile with @-threaded@ and supply @+RTS -N2 -RTS@ +-- to the generated Haskell executable on dual core processor, +-- or you won't get any parallelism. Generally, the mentioned +-- @N@ parameter should correspond to the number of cores for +-- your processor. +-- +-- In case of need you might want to specify the number of +-- threads directly with help of 'experimentNumCapabilities', +-- although the real number of parallel threads can depend on many +-- factors. +runExperimentParallel :: Experiment -> Simulation ExperimentData -> IO () +runExperimentParallel e = runExperimentWithExecutor executor e + where executor tasks = + do n <- experimentNumCapabilities e + withPool n $ \pool -> + parallel_ pool tasks + +-- | Run the simulation experiment with the specified executor. +runExperimentWithExecutor :: ([IO ()] -> IO ()) -> + Experiment -> + Simulation ExperimentData -> IO () +runExperimentWithExecutor executor e simulation = + do let specs = experimentSpecs e + runCount = experimentRunCount e + dirName = experimentDirectoryName e + generators = experimentGenerators e + path <- resolveDirectoryName Nothing dirName M.empty + when (experimentVerbose e) $ + do putStr "Using directory " + putStrLn path + createDirectoryIfMissing True path + reporters <- mapM (\x -> generateReporter x e path) + generators + forM_ reporters reporterInitialise + let simulate :: Simulation () + simulate = + do d <- simulation + fs <- runEventInStartTime IncludingEarlierEvents $ + forM reporters $ \reporter -> + reporterSimulate reporter d + runEventInStopTime IncludingCurrentEvents $ + sequence_ fs + executor $ runSimulations simulate specs runCount + forM_ reporters reporterFinalise + experimentIndexHtml e e reporters path + return () + +-- | Create an index HTML file. +createIndexHtml :: Experiment -> [ExperimentReporter] -> FilePath -> IO () +createIndexHtml e reporters path = + do let html :: HtmlWriter () + html = + writeHtmlDocumentWithTitle (experimentTitle e) $ + do writeHtmlList $ + forM_ (zip [1..] reporters) $ \(i, reporter) -> + reporterTOCHtml reporter i + writeHtmlBreak + unless (null $ experimentDescription e) $ + writeHtmlParagraph $ + writeHtmlText $ experimentDescription e + forM_ (zip [1..] reporters) $ \(i, reporter) -> + reporterHtml reporter i + file = combine path "index.html" + ((), contents) <- runHtmlWriter html id + UTF8.writeFile file (contents []) + when (experimentVerbose e) $ + do putStr "Generated file " + putStrLn file + +-- | Specifies the directory name, unique or writable. +data DirectoryName = WritableDirectoryName String + -- ^ The directory which is overwritten in + -- case if it existed before. + | UniqueDirectoryName String + -- ^ The directory which is always unique, + -- when a prefix is added to the name + -- in case of need. + +-- | Specifies the file name, unique or writable. +data FileName = WritableFileName String String + -- ^ The file which is overwritten in + -- case if it existed before. The first + -- field defines a name or its prototype. + -- The second field is the file extension. + | UniqueFileName String String + -- ^ The file which is always unique, + -- when a prefix is added to the name + -- in case of need. The first field + -- defines a name or its prototype. + -- The second field is the file exension. + +-- | Resolve the directory name relative to the passed in directory +-- as the first argument, replacing the specified strings according the map. +resolveDirectoryName :: Maybe FilePath -> DirectoryName -> M.Map String String -> IO String +resolveDirectoryName dir (WritableDirectoryName name) map = + return $ replaceName (combineName dir name) map +resolveDirectoryName dir (UniqueDirectoryName name) map = + let x = replaceName name map + loop y i = + do let n = combineName dir y + f1 <- doesFileExist n + f2 <- doesDirectoryExist n + if f1 || f2 + then loop (x ++ "(" ++ show i ++ ")") (i + 1) + else return n + in loop x 2 + +-- | Resolve the file name relative to the passed in directory +-- as the first argument, replacing the specified strings according the map. +resolveFileName :: Maybe FilePath -> FileName -> M.Map String String -> IO String +resolveFileName dir (WritableFileName name ext) map = + return $ replaceName (combineName dir name ++ ext) map +resolveFileName dir (UniqueFileName name ext) map = + let x = replaceName name map + loop y i = + do let n = combineName dir y ++ ext + f1 <- doesFileExist n + f2 <- doesDirectoryExist n + if f1 || f2 + then loop (x ++ "(" ++ show i ++ ")") (i + 1) + else return n + in loop x 2 + +-- | Replace the name according the specified table. +replaceName :: String -> M.Map String String -> String +replaceName name map = name' where + ((), name') = flip runState name $ + forM_ (M.assocs map) $ \(k, v) -> + do a <- get + put $ replace k v a + +-- | Combine the file name with the directory name. +combineName :: Maybe String -> String -> String +combineName dir name = + case dir of + Nothing -> name + Just dir -> combine dir name + +-- | Represent a container for simulation data. +class SeriesContainer c where + + -- | Extract data from the container. + containerData :: c a -> Event a + + -- | Get the signal for the container. + containerSignal :: c a => Maybe (Signal ()) + +instance SeriesContainer Parameter where + + containerData = liftParameter + + containerSignal = const Nothing + +instance SeriesContainer Simulation where + + containerData = liftSimulation + + containerSignal = const Nothing + +instance SeriesContainer Dynamics where + + containerData = liftDynamics + + containerSignal = const Nothing + +instance SeriesContainer Event where + + containerData = id + + containerSignal = const Nothing + +instance SeriesContainer Ref where + + containerData = readRef + + containerSignal = Just . refChanged_ + +instance SeriesContainer Var where + + containerData = readVar + + containerSignal = Just . varChanged_ + +instance SeriesContainer Signalable where + + containerData = readSignalable + + containerSignal = Just . signalableChanged_ + +instance SeriesContainer c => Series (c Double) where + + seriesEntity name s = + SeriesEntity { seriesProviders = + [SeriesProvider { providerName = name, + providerToDouble = + Just $ + containerData s, + providerToDoubleStats = + Just $ + fmap returnSamplingStats $ + containerData s, + providerToDoubleList = + Just $ + fmap return $ + containerData s, + providerToInt = Nothing, + providerToIntStats = Nothing, + providerToIntList = Nothing, + providerToString = + Just $ + fmap show $ + containerData s, + providerSignal = + containerSignal s }] } + +instance SeriesContainer c => Series (c Int) where + + seriesEntity name s = + SeriesEntity { seriesProviders = + [SeriesProvider { providerName = name, + providerToDouble = + Just $ + fmap fromIntegral $ + containerData s, + providerToDoubleStats = + Just $ + fmap returnSamplingStats $ + fmap fromIntegral $ + containerData s, + providerToDoubleList = + Just $ + fmap return $ + fmap fromIntegral $ + containerData s, + providerToInt = + Just $ + containerData s, + providerToIntStats = + Just $ + fmap returnSamplingStats $ + containerData s, + providerToIntList = + Just $ + fmap return $ + containerData s, + providerToString = + Just $ + fmap show $ + containerData s, + providerSignal = + containerSignal s }] } + +instance SeriesContainer c => Series (c String) where + + seriesEntity name s = + SeriesEntity { seriesProviders = + [SeriesProvider { providerName = name, + providerToDouble = Nothing, + providerToDoubleStats = Nothing, + providerToDoubleList = Nothing, + providerToInt = Nothing, + providerToIntStats = Nothing, + providerToIntList = Nothing, + providerToString = + Just $ + containerData s, + providerSignal = + containerSignal s }] } + +instance Series s => Series [s] where + + seriesEntity name s = + SeriesEntity { seriesProviders = + join $ forM (zip [0..] s) $ \(i, s) -> + let name' = name ++ "[" ++ show i ++ "]" + in seriesProviders $ seriesEntity name' s } + +instance (Show i, Ix i, Series s) => Series (Array i s) where + + seriesEntity name s = + SeriesEntity { seriesProviders = + join $ forM (A.assocs s) $ \(i, s) -> + let name' = name ++ "[" ++ show i ++ "]" + in seriesProviders $ seriesEntity name' s } + +instance Series s => Series (V.Vector s) where + + seriesEntity name s = + SeriesEntity { seriesProviders = + join $ forM (zip [0..] (V.toList s)) $ \(i, s) -> + let name' = name ++ "[" ++ show i ++ "]" + in seriesProviders $ seriesEntity name' s } + +-- | Represents a list with the specified subscript. +data SeriesListWithSubscript s = + SeriesListWithSubscript { seriesList :: [s], + seriesListSubscript :: [String] } + +-- | Represents an array with the specified subscript. +data SeriesArrayWithSubscript i s = + SeriesArrayWithSubscript { seriesArray :: Array i s, + seriesArraySubscript :: Array i String } + +-- | Represents a vector with the specified subscript. +data SeriesVectorWithSubscript s = + SeriesVectorWithSubscript { seriesVector :: V.Vector s, + seriesVectorSubscript :: V.Vector String } + +-- | Add the specified subscript to the list. +seriesListWithSubscript :: Series s + => [s] + -- ^ the list to subscript + -> [String] + -- ^ the list of subscripts + -> SeriesListWithSubscript s + -- ^ the subscripted list +seriesListWithSubscript = SeriesListWithSubscript + +-- | Add the specified subscript to the array. +seriesArrayWithSubscript :: (Ix i, Series s) + => Array i s + -- ^ the array to subscript + -> Array i String + -- ^ the array of subscripts + -> SeriesArrayWithSubscript i s + -- ^ the subscripted array +seriesArrayWithSubscript = SeriesArrayWithSubscript + +-- | Add the specified subscript to the vector. +seriesVectorWithSubscript :: Series s + => V.Vector s + -- ^ the vector to subscript + -> V.Vector String + -- ^ the vector of subscripts + -> SeriesVectorWithSubscript s + -- ^ the subscripted vector +seriesVectorWithSubscript = SeriesVectorWithSubscript + +instance Series s => Series (SeriesListWithSubscript s) where + + seriesEntity name s = + SeriesEntity { seriesProviders = do + let xs = seriesList s + ns = seriesListSubscript s + join $ forM (zip3 [1..] xs ns) $ \(i, s, n) -> + let name' = name ++ n + in seriesProviders $ seriesEntity name' s } + +instance (Ix i, Series s) => Series (SeriesArrayWithSubscript i s) where + + seriesEntity name s = + SeriesEntity { seriesProviders = do + let xs = seriesArray s + ns = seriesArraySubscript s + join $ forM (zip (A.assocs xs) (A.elems ns)) $ \((i, s), n) -> + let name' = name ++ n + in seriesProviders $ seriesEntity name' s } + +instance Series s => Series (SeriesVectorWithSubscript s) where + + seriesEntity name s = + SeriesEntity { seriesProviders = do + let xs = seriesVector s + ns = seriesVectorSubscript s + join $ forM (zip (V.toList xs) (V.toList ns)) $ \(x, n) -> + let name' = name ++ n + in seriesProviders $ seriesEntity name' x } + +instance SeriesContainer c => Series (c (SamplingStats Double)) where + + seriesEntity name s = + SeriesEntity { seriesProviders = + [SeriesProvider { providerName = name, + providerToDouble = Nothing, + providerToDoubleStats = + Just $ + containerData s, + providerToDoubleList = Nothing, + providerToInt = Nothing, + providerToIntStats = Nothing, + providerToIntList = Nothing, + providerToString = Nothing, + providerSignal = + containerSignal s } ] } + +instance SeriesContainer c => Series (c (SamplingStats Int)) where + + seriesEntity name s = + SeriesEntity { seriesProviders = + [SeriesProvider { providerName = name, + providerToDouble = Nothing, + providerToDoubleStats = + Just $ + fmap fromIntSamplingStats $ + containerData s, + providerToDoubleList = Nothing, + providerToInt = Nothing, + providerToIntStats = + Just $ + containerData s, + providerToIntList = Nothing, + providerToString = Nothing, + providerSignal = + containerSignal s } ] } + +instance SeriesContainer c => Series (c [Double]) where + + seriesEntity name s = + SeriesEntity { seriesProviders = + [SeriesProvider { providerName = name, + providerToDouble = Nothing, + providerToDoubleStats = + Just $ + fmap listSamplingStats $ + containerData s, + providerToDoubleList = + Just $ + containerData s, + providerToInt = Nothing, + providerToIntStats = Nothing, + providerToIntList = Nothing, + providerToString = + Just $ + fmap show $ + containerData s, + providerSignal = + containerSignal s } ] } + +instance SeriesContainer c => Series (c [Int]) where + + seriesEntity name s = + SeriesEntity { seriesProviders = + [SeriesProvider { providerName = name, + providerToDouble = Nothing, + providerToDoubleStats = + Just $ + fmap fromIntSamplingStats $ + fmap listSamplingStats $ + containerData s, + providerToDoubleList = + Just $ + fmap (map fromIntegral) $ + containerData s, + providerToInt = Nothing, + providerToIntStats = + Just $ + fmap listSamplingStats $ + containerData s, + providerToIntList = + Just $ + containerData s, + providerToString = + Just $ + fmap show $ + containerData s, + providerSignal = + containerSignal s } ] } + +instance (Ix i, SeriesContainer c) => Series (c (Array i Double)) where + + seriesEntity name s = + SeriesEntity { seriesProviders = + [SeriesProvider { providerName = name, + providerToDouble = Nothing, + providerToDoubleStats = + Just $ + fmap listSamplingStats $ + fmap A.elems $ + containerData s, + providerToDoubleList = + Just $ + fmap A.elems $ + containerData s, + providerToInt = Nothing, + providerToIntStats = Nothing, + providerToIntList = Nothing, + providerToString = Nothing, + providerSignal = + containerSignal s } ] } + +instance (Ix i, SeriesContainer c) => Series (c (Array i Int)) where + + seriesEntity name s = + SeriesEntity { seriesProviders = + [SeriesProvider { providerName = name, + providerToDouble = Nothing, + providerToDoubleStats = + Just $ + fmap fromIntSamplingStats $ + fmap listSamplingStats $ + fmap A.elems $ + containerData s, + providerToDoubleList = + Just $ + fmap (map fromIntegral) $ + fmap A.elems $ + containerData s, + providerToInt = Nothing, + providerToIntStats = + Just $ + fmap listSamplingStats $ + fmap A.elems $ + containerData s, + providerToIntList = + Just $ + fmap A.elems $ + containerData s, + providerToString = Nothing, + providerSignal = + containerSignal s } ] } + +instance (Ix i, SeriesContainer c) => Series (c (UArray i Double)) where + + seriesEntity name s = + SeriesEntity { seriesProviders = + [SeriesProvider { providerName = name, + providerToDouble = Nothing, + providerToDoubleStats = + Just $ + fmap listSamplingStats $ + fmap UA.elems $ + containerData s, + providerToDoubleList = + Just $ + fmap UA.elems $ + containerData s, + providerToInt = Nothing, + providerToIntStats = Nothing, + providerToIntList = Nothing, + providerToString = Nothing, + providerSignal = + containerSignal s } ] } + +instance (Ix i, SeriesContainer c) => Series (c (UArray i Int)) where + + seriesEntity name s = + SeriesEntity { seriesProviders = + [SeriesProvider { providerName = name, + providerToDouble = Nothing, + providerToDoubleStats = + Just $ + fmap fromIntSamplingStats $ + fmap listSamplingStats $ + fmap UA.elems $ + containerData s, + providerToDoubleList = + Just $ + fmap (map fromIntegral) $ + fmap UA.elems $ + containerData s, + providerToInt = Nothing, + providerToIntStats = + Just $ + fmap listSamplingStats $ + fmap UA.elems $ + containerData s, + providerToIntList = + Just $ + fmap UA.elems $ + containerData s, + providerToString = Nothing, + providerSignal = + containerSignal s } ] } + +instance SeriesContainer c => Series (c (V.Vector Double)) where + + seriesEntity name s = + SeriesEntity { seriesProviders = + [SeriesProvider { providerName = name, + providerToDouble = Nothing, + providerToDoubleStats = + Just $ + fmap listSamplingStats $ + fmap V.toList $ + containerData s, + providerToDoubleList = + Just $ + fmap V.toList $ + containerData s, + providerToInt = Nothing, + providerToIntStats = Nothing, + providerToIntList = Nothing, + providerToString = + Just $ + fmap show $ + containerData s, + providerSignal = + containerSignal s } ] } + +instance SeriesContainer c => Series (c (V.Vector Int)) where + + seriesEntity name s = + SeriesEntity { seriesProviders = + [SeriesProvider { providerName = name, + providerToDouble = Nothing, + providerToDoubleStats = + Just $ + fmap fromIntSamplingStats $ + fmap listSamplingStats $ + fmap V.toList $ + containerData s, + providerToDoubleList = + Just $ + fmap (map fromIntegral) $ + fmap V.toList $ + containerData s, + providerToInt = Nothing, + providerToIntStats = + Just $ + fmap listSamplingStats $ + fmap V.toList $ + containerData s, + providerToIntList = + Just $ + fmap V.toList $ + containerData s, + providerToString = + Just $ + fmap show $ + containerData s, + providerSignal = + containerSignal s }] } + +instance SeriesContainer c => Series (c (UV.Vector Double)) where + + seriesEntity name s = + SeriesEntity { seriesProviders = + [SeriesProvider { providerName = name, + providerToDouble = Nothing, + providerToDoubleStats = + Just $ + fmap listSamplingStats $ + fmap UV.toList $ + containerData s, + providerToDoubleList = + Just $ + fmap UV.toList $ + containerData s, + providerToInt = Nothing, + providerToIntStats = Nothing, + providerToIntList = Nothing, + providerToString = + Just $ + fmap show $ + containerData s, + providerSignal = + containerSignal s } ] } + +instance SeriesContainer c => Series (c (UV.Vector Int)) where + + seriesEntity name s = + SeriesEntity { seriesProviders = + [SeriesProvider { providerName = name, + providerToDouble = Nothing, + providerToDoubleStats = + Just $ + fmap fromIntSamplingStats $ + fmap listSamplingStats $ + fmap UV.toList $ + containerData s, + providerToDoubleList = + Just $ + fmap (map fromIntegral) $ + fmap UV.toList $ + containerData s, + providerToInt = Nothing, + providerToIntStats = + Just $ + fmap listSamplingStats $ + fmap UV.toList $ + containerData s, + providerToIntList = + Just $ + fmap UV.toList $ + containerData s, + providerToString = + Just $ + fmap show $ + containerData s, + providerSignal = + containerSignal s } ] } diff --git a/aivika-experiment.cabal b/aivika-experiment.cabal --- a/aivika-experiment.cabal +++ b/aivika-experiment.cabal @@ -1,5 +1,5 @@ name: aivika-experiment -version: 0.4 +version: 1.0 synopsis: Simulation experiments for the Aivika library description: This package allows defining simulation experiments for the Aivika @@ -12,7 +12,7 @@ category: Simulation license: BSD3 license-file: LICENSE -copyright: (c) 2012-2013. David Sorokin +copyright: (c) 2012-2014. David Sorokin author: David Sorokin maintainer: David Sorokin homepage: http://github.com/dsorokin/aivika-experiment @@ -27,6 +27,7 @@ library exposed-modules: Simulation.Aivika.Experiment + Simulation.Aivika.Experiment.Types Simulation.Aivika.Experiment.HtmlWriter Simulation.Aivika.Experiment.LastValueView Simulation.Aivika.Experiment.TableView @@ -53,7 +54,7 @@ split >= 0.2.2, network >= 2.3.0.13, parallel-io >= 0.3.2.1, - aivika >= 0.7 + aivika >= 1.0 extensions: FlexibleInstances diff --git a/examples/LinearArray.hs b/examples/LinearArray.hs --- a/examples/LinearArray.hs +++ b/examples/LinearArray.hs @@ -14,23 +14,15 @@ import qualified Data.Vector as V -import Simulation.Aivika.Specs -import Simulation.Aivika.Simulation -import Simulation.Aivika.Dynamics +import Simulation.Aivika import Simulation.Aivika.SystemDynamics - import Simulation.Aivika.Experiment -import Simulation.Aivika.Experiment.LastValueView -import Simulation.Aivika.Experiment.TableView -import Simulation.Aivika.Experiment.ExperimentSpecsView -import Simulation.Aivika.Experiment.FinalStatsView -import Simulation.Aivika.Experiment.TimingStatsView -import Simulation.Aivika.Experiment.FinalTableView specs = Specs { spcStartTime = 0, spcStopTime = 500, spcDT = 0.1, - spcMethod = RungeKutta4 } + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } -- | This is an analog of 'V.generateM' included in the Haskell platform. generateArray :: (Ix i, Monad m) => (i, i) -> (i -> m a) -> m (Array i a) diff --git a/examples/MachRep3.hs b/examples/MachRep3.hs --- a/examples/MachRep3.hs +++ b/examples/MachRep3.hs @@ -19,27 +19,17 @@ import Control.Monad import Control.Monad.Trans -import Simulation.Aivika.Specs -import Simulation.Aivika.Simulation -import Simulation.Aivika.Dynamics -import Simulation.Aivika.Event -import Simulation.Aivika.Ref -import Simulation.Aivika.QueueStrategy -import Simulation.Aivika.Resource -import Simulation.Aivika.Process - +import Simulation.Aivika import Simulation.Aivika.Experiment -import Simulation.Aivika.Experiment.LastValueView -import Simulation.Aivika.Experiment.TableView -import Simulation.Aivika.Experiment.TimingStatsView -import Simulation.Aivika.Experiment.FinalStatsView -import Simulation.Aivika.Experiment.ExperimentSpecsView -import Simulation.Aivika.Experiment.FinalTableView +meanUpTime = 1.0 +meanRepairTime = 0.5 + specs = Specs { spcStartTime = 0.0, spcStopTime = 1000.0, spcDT = 1.0, - spcMethod = RungeKutta4 } + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } description = "Model MachRep3. Variation of models MachRep1, MachRep2. Two machines, but " ++ @@ -68,14 +58,6 @@ outputView $ defaultFinalTableView { finalTableSeries = ["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 -- number of machines currently up @@ -91,14 +73,15 @@ let machine :: ProcessId -> Process () machine pid = - do startUpTime <- liftDynamics time - upTime <- liftIO $ exprnd upRate + do upTime <- + liftParameter $ + randomExponential meanUpTime holdProcess upTime - finishUpTime <- liftDynamics time - liftEvent $ modifyRef totalUpTime - (+ (finishUpTime - startUpTime)) - - liftEvent $ modifyRef nUp $ \a -> a - 1 + liftEvent $ + modifyRef totalUpTime (+ upTime) + + liftEvent $ + modifyRef nUp (+ (-1)) nUp' <- liftEvent $ readRef nUp if nUp' == 1 then passivateProcess @@ -108,17 +91,20 @@ reactivateProcess pid requestResource repairPerson - repairTime <- liftIO $ exprnd repairRate + repairTime <- + liftParameter $ + randomExponential meanRepairTime holdProcess repairTime - liftEvent $ modifyRef nUp $ \a -> a + 1 + liftEvent $ + modifyRef nUp (+ 1) releaseResource repairPerson machine pid - runProcessInStartTime IncludingCurrentEvents + runProcessInStartTimeUsingId IncludingCurrentEvents pid1 (machine pid2) - runProcessInStartTime IncludingCurrentEvents + runProcessInStartTimeUsingId IncludingCurrentEvents pid2 (machine pid1) let result =