module Simulation.Aivika.Experiment
(Experiment(..),
defaultExperiment,
runExperiment,
ExperimentData(..),
experimentDataInStartTime,
experimentSeriesProviders,
experimentMixedSignal,
Series(..),
SeriesEntity(..),
SeriesProvider(..),
View(..),
Generator(..),
Reporter(..),
DirectoryName(..),
resolveDirectoryName,
FileName(..),
resolveFileName) where
import Control.Monad
import Control.Monad.State
import qualified Data.Map as M
import Data.Array
import Data.Maybe
import Data.Monoid
import Data.String.Utils (replace)
import System.IO
import System.Directory
import System.FilePath (combine)
import Simulation.Aivika.Dynamics
import Simulation.Aivika.Dynamics.Simulation
import Simulation.Aivika.Dynamics.Signal
import Simulation.Aivika.Dynamics.Ref
import Simulation.Aivika.Dynamics.Var
import Simulation.Aivika.Dynamics.UVar
import Simulation.Aivika.Dynamics.EventQueue
import Simulation.Aivika.Dynamics.Parameter
import Simulation.Aivika.Experiment.HtmlWriter
data Experiment =
Experiment { experimentSpecs :: Specs,
experimentRunCount :: Int,
experimentDirectoryName :: DirectoryName,
experimentTitle :: String,
experimentDescription :: String,
experimentVerbose :: Bool,
experimentGenerators :: [Generator],
experimentIndexHtml :: Experiment -> [Reporter] -> FilePath -> IO ()
}
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 }
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 (Dynamics Double),
providerToInt :: Maybe (Dynamics Int),
providerToString :: Maybe (Dynamics String),
providerSignal :: Maybe (Signal ())
}
data ExperimentData =
ExperimentData { experimentQueue :: EventQueue,
experimentSignalInIntegTimes :: Signal Double,
experimentSignalInStartTime :: Signal Double,
experimentSignalInStopTime :: Signal Double,
experimentSeries :: M.Map String SeriesEntity
}
experimentDataInStartTime :: EventQueue -> [(String, SeriesEntity)] -> Simulation ExperimentData
experimentDataInStartTime q m = runDynamicsInStartTime d where
d = do signalInIntegTimes <- newSignalInIntegTimes q
signalInStartTime <- newSignalInStartTime q
signalInStopTime <- newSignalInStopTime q
let series = M.fromList m
return ExperimentData { experimentQueue = q,
experimentSignalInIntegTimes = signalInIntegTimes,
experimentSignalInStartTime = signalInStartTime,
experimentSignalInStopTime = signalInStopTime,
experimentSeries = series }
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 ->
Dynamics (Dynamics ()),
reporterTOCHtml :: Int -> HtmlWriter (),
reporterHtml :: Int -> HtmlWriter ()
}
runExperiment :: Experiment -> Simulation ExperimentData -> IO ()
runExperiment e simulation =
do let specs = experimentSpecs e
runCount = experimentRunCount e
dirName = experimentDirectoryName e
generators = experimentGenerators e
path <- resolveDirectoryName Nothing dirName M.empty
when (experimentVerbose e) $
do putStr "Using directory "
putStrLn path
createDirectoryIfMissing True path
reporters <- mapM (\x -> generateReporter x e path)
generators
forM_ reporters reporterInitialise
let simulate :: Simulation ()
simulate =
do d <- simulation
fs <- runDynamicsInStartTime $
forM reporters $ \reporter ->
reporterSimulate reporter d
runDynamicsInStopTime $
do updateSignal $
experimentMixedSignal d $
join $ map seriesProviders $
M.elems $ experimentSeries d
sequence_ fs
sequence_ $ runSimulations simulate specs runCount
forM_ reporters reporterFinalise
experimentIndexHtml e e reporters path
return ()
createIndexHtml :: Experiment -> [Reporter] -> FilePath -> IO ()
createIndexHtml e reporters path =
do let html :: HtmlWriter ()
html =
writeHtmlDocumentWithTitle (experimentTitle e) $
do writeHtmlList $
forM_ (zip [1..] reporters) $ \(i, reporter) ->
reporterTOCHtml reporter i
writeHtmlBreak
unless (null $ experimentDescription e) $
writeHtmlParagraph $
writeHtmlText $ experimentDescription e
forM_ (zip [1..] reporters) $ \(i, reporter) ->
reporterHtml reporter i
((), contents) <- runHtmlWriter html id
writeFile (path ++ "/index.html") (contents [])
when (experimentVerbose e) $
do putStr "Generated file "
putStr path
putStrLn "/index.html"
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
instance Series (Dynamics Double) where
seriesEntity name s =
SeriesEntity { seriesProviders =
[SeriesProvider { providerName = name,
providerToDouble = Just s,
providerToInt = Nothing,
providerToString = Just $ fmap show s,
providerSignal = Nothing }] }
instance Series (Dynamics Int) where
seriesEntity name s =
SeriesEntity { seriesProviders =
[SeriesProvider { providerName = name,
providerToDouble = Just $ fmap (fromInteger . toInteger) s,
providerToInt = Just s,
providerToString = Just $ fmap show s,
providerSignal = Nothing }] }
instance Series (Dynamics String) where
seriesEntity name s =
SeriesEntity { seriesProviders =
[SeriesProvider { providerName = name,
providerToDouble = Nothing,
providerToInt = Nothing,
providerToString = Just s,
providerSignal = Nothing }] }
instance Series (Ref Double) where
seriesEntity name s =
SeriesEntity { seriesProviders =
[SeriesProvider { providerName = name,
providerToDouble = Just $ readRef s,
providerToInt = Nothing,
providerToString = Just $ fmap show (readRef s),
providerSignal = Just $ refChanged_ s }] }
instance Series (Ref Int) where
seriesEntity name s =
SeriesEntity { seriesProviders =
[SeriesProvider { providerName = name,
providerToDouble = Just $ fmap (fromInteger . toInteger) (readRef s),
providerToInt = Just $ readRef s,
providerToString = Just $ fmap show (readRef s),
providerSignal = Just $ refChanged_ s }] }
instance Series (Ref String) where
seriesEntity name s =
SeriesEntity { seriesProviders =
[SeriesProvider { providerName = name,
providerToDouble = Nothing,
providerToInt = Nothing,
providerToString = Just $ readRef s,
providerSignal = Just $ refChanged_ s }] }
instance Series (Var Double) where
seriesEntity name s =
SeriesEntity { seriesProviders =
[SeriesProvider { providerName = name,
providerToDouble = Just $ readVar s,
providerToInt = Nothing,
providerToString = Just $ fmap show (readVar s),
providerSignal = Just $ varChanged_ s }] }
instance Series (Var Int) where
seriesEntity name s =
SeriesEntity { seriesProviders =
[SeriesProvider { providerName = name,
providerToDouble = Just $ fmap (fromInteger . toInteger) (readVar s),
providerToInt = Just $ readVar s,
providerToString = Just $ fmap show (readVar s),
providerSignal = Just $ varChanged_ s }] }
instance Series (Var String) where
seriesEntity name s =
SeriesEntity { seriesProviders =
[SeriesProvider { providerName = name,
providerToDouble = Nothing,
providerToInt = Nothing,
providerToString = Just $ readVar s,
providerSignal = Just $ varChanged_ s }] }
instance Series (UVar Double) where
seriesEntity name s =
SeriesEntity { seriesProviders =
[SeriesProvider { providerName = name,
providerToDouble = Just $ readUVar s,
providerToInt = Nothing,
providerToString = Just $ fmap show (readUVar s),
providerSignal = Just $ uvarChanged_ s }] }
instance Series (UVar Int) where
seriesEntity name s =
SeriesEntity { seriesProviders =
[SeriesProvider { providerName = name,
providerToDouble = Just $ fmap (fromInteger . toInteger) (readUVar s),
providerToInt = Just $ readUVar s,
providerToString = Just $ fmap show (readUVar s),
providerSignal = Just $ uvarChanged_ s }] }
instance Series s => Series [s] where
seriesEntity name s =
SeriesEntity { seriesProviders =
join $ forM (zip [1..] s) $ \(i, s) ->
let name' = name ++ "[" ++ show i ++ "]"
in seriesProviders $ seriesEntity name' s }
instance (Show i, Ix i, Series s) => Series (Array i s) where
seriesEntity name s =
SeriesEntity { seriesProviders =
join $ forM (assocs s) $ \(i, s) ->
let name' = name ++ "[" ++ show i ++ "]"
in seriesProviders $ seriesEntity name' s }