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
import Simulation.Aivika.Experiment.HtmlWriter
import Simulation.Aivika.Experiment.Utils (replace)
data Experiment =
Experiment { experimentSpecs :: Specs,
experimentRunCount :: Int,
experimentDirectoryName :: DirectoryName,
experimentTitle :: String,
experimentDescription :: String,
experimentVerbose :: Bool,
experimentGenerators :: [Generator],
experimentIndexHtml :: Experiment -> [Reporter] -> FilePath -> IO (),
experimentNumCapabilities :: IO Int
}
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 }
data Generator =
Generator { generateReporter :: Experiment -> FilePath -> IO Reporter
}
class View v where
outputView :: v -> Generator
class Series s where
seriesEntity :: String -> s -> SeriesEntity
data SeriesEntity =
SeriesEntity { seriesProviders :: [SeriesProvider]
}
data SeriesProvider =
SeriesProvider { providerName :: String,
providerToDouble :: Maybe (Event Double),
providerToDoubleStats :: Maybe (Event (SamplingStats Double)),
providerToDoubleList :: Maybe (Event [Double]),
providerToInt :: Maybe (Event Int),
providerToIntStats :: Maybe (Event (SamplingStats Int)),
providerToIntList :: Maybe (Event [Int]),
providerToString :: Maybe (Event String),
providerSignal :: Maybe (Signal ())
}
data ExperimentData =
ExperimentData { experimentSignalInIntegTimes :: Signal Double,
experimentSignalInStartTime :: Signal Double,
experimentSignalInStopTime :: Signal Double,
experimentSeries :: M.Map String SeriesEntity
}
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 }
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
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
data Reporter =
Reporter { reporterInitialise :: IO (),
reporterFinalise :: IO (),
reporterSimulate :: ExperimentData -> Event (Event ()),
reporterTOCHtml :: Int -> HtmlWriter (),
reporterHtml :: Int -> HtmlWriter ()
}
runExperiment :: Experiment -> Simulation ExperimentData -> IO ()
runExperiment = runExperimentWithExecutor sequence_
runExperimentParallel :: Experiment -> Simulation ExperimentData -> IO ()
runExperimentParallel e = runExperimentWithExecutor executor e
where executor tasks =
do n <- experimentNumCapabilities e
withPool n $ \pool ->
parallel_ pool tasks
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 ()
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
data DirectoryName = WritableDirectoryName String
| UniqueDirectoryName String
data FileName = WritableFileName String String
| UniqueFileName String String
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
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
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
combineName :: Maybe String -> String -> String
combineName dir name =
case dir of
Nothing -> name
Just dir -> combine dir name
class SeriesContainer c where
containerData :: c a -> Event a
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 }
data SeriesListWithSubscript s =
SeriesListWithSubscript { seriesList :: [s],
seriesListSubscript :: [String] }
data SeriesArrayWithSubscript i s =
SeriesArrayWithSubscript { seriesArray :: Array i s,
seriesArraySubscript :: Array i String }
data SeriesVectorWithSubscript s =
SeriesVectorWithSubscript { seriesVector :: V.Vector s,
seriesVectorSubscript :: V.Vector String }
seriesListWithSubscript :: Series s
=> [s]
-> [String]
-> SeriesListWithSubscript s
seriesListWithSubscript = SeriesListWithSubscript
seriesArrayWithSubscript :: (Ix i, Series s)
=> Array i s
-> Array i String
-> SeriesArrayWithSubscript i s
seriesArrayWithSubscript = SeriesArrayWithSubscript
seriesVectorWithSubscript :: Series s
=> V.Vector s
-> V.Vector String
-> SeriesVectorWithSubscript s
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 } ] }