module Simulation.Aivika.Experiment.TimingStatsView
(TimingStatsView(..),
defaultTimingStatsView) where
import Control.Monad
import Control.Monad.Trans
import qualified Data.Map as M
import Data.IORef
import Data.Maybe
import Data.String.Utils (replace)
import Simulation.Aivika.Experiment
import Simulation.Aivika.Experiment.HtmlWriter
import Simulation.Aivika.Experiment.TimingStatsWriter
import Simulation.Aivika.Dynamics
import Simulation.Aivika.Dynamics.Simulation
import Simulation.Aivika.Dynamics.Signal
import Simulation.Aivika.Dynamics.EventQueue
import Simulation.Aivika.Dynamics.Base
import Simulation.Aivika.Statistics
data TimingStatsView =
TimingStatsView { timingStatsTitle :: String,
timingStatsRunTitle :: String,
timingStatsDescription :: String,
timingStatsWriter :: TimingStatsWriter Double,
timingStatsPredicate :: Dynamics Bool,
timingStatsSeries :: [String]
}
defaultTimingStatsView :: TimingStatsView
defaultTimingStatsView =
TimingStatsView { timingStatsTitle = "Timing Statistics",
timingStatsRunTitle = "$TITLE / Run $RUN_INDEX of $RUN_COUNT",
timingStatsDescription = "The statistical data are gathered in the time points.",
timingStatsWriter = defaultTimingStatsWriter,
timingStatsPredicate = return True,
timingStatsSeries = [] }
instance View 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 }
data TimingStatsViewState =
TimingStatsViewState { timingStatsView :: TimingStatsView,
timingStatsExperiment :: Experiment,
timingStatsMap :: M.Map Int (IORef [(String, IORef (TimingStats Double))]) }
newTimingStats :: TimingStatsView -> Experiment -> IO TimingStatsViewState
newTimingStats view exp =
do let n = experimentRunCount exp
rs <- forM [0..(n 1)] $ \i -> newIORef []
let m = M.fromList $ zip [0..(n 1)] rs
return TimingStatsViewState { timingStatsView = view,
timingStatsExperiment = exp,
timingStatsMap = m }
simulateTimingStats :: TimingStatsViewState -> ExperimentData -> Dynamics (Dynamics ())
simulateTimingStats st expdata =
do let labels = timingStatsSeries $ timingStatsView st
input providers =
flip map providers $ \provider ->
case providerToDouble provider of
Nothing -> error $
"Cannot represent series " ++
providerName provider ++
" as double values: simulateTimingStats"
Just input -> (provider, input)
predicate = timingStatsPredicate $ timingStatsView st
i <- liftSimulation simulationIndex
let r = fromJust $ M.lookup (i 1) $ timingStatsMap st
t <- time
forM_ labels $ \label ->
do let providers = experimentSeriesProviders expdata [label]
pairs = input providers
forM_ pairs $ \(provider, input) ->
do stats <- liftIO $ newIORef emptyTimingStats
let name = providerName provider
liftIO $ modifyIORef r ((:) (name, stats))
let h = filterSignalM (const predicate) $
experimentMixedSignal expdata [provider]
enqueue (experimentQueue expdata) t $
handleSignal_ h $ \_ ->
do t <- time
x <- input
liftIO $ modifyIORef stats $ addTimingStats t x
return $ return ()
timingStatsHtml :: TimingStatsViewState -> Int -> HtmlWriter ()
timingStatsHtml st index =
let n = experimentRunCount $ timingStatsExperiment st
in if n == 1
then timingStatsHtmlSingle st index
else timingStatsHtmlMultiple st index
timingStatsHtmlSingle :: TimingStatsViewState -> Int -> HtmlWriter ()
timingStatsHtmlSingle st index =
do header st index
let r = fromJust $ M.lookup 0 (timingStatsMap st)
pairs <- liftIO $ readIORef r
forM_ (reverse pairs) $ \(name, r) ->
do stats <- liftIO $ readIORef r
let writer = timingStatsWriter (timingStatsView st)
write = timingStatsWrite writer
write writer name stats
timingStatsHtmlMultiple :: TimingStatsViewState -> Int -> HtmlWriter ()
timingStatsHtmlMultiple st index =
do header st index
let n = experimentRunCount $ timingStatsExperiment st
forM_ [0..(n 1)] $ \i ->
do let subtitle =
replace "$RUN_INDEX" (show $ i + 1) $
replace "$RUN_COUNT" (show n) $
replace "$TITLE" (timingStatsTitle $ timingStatsView st)
(timingStatsRunTitle $ timingStatsView st)
writeHtmlHeader4 $
writeHtmlText subtitle
let r = fromJust $ M.lookup i (timingStatsMap st)
pairs <- liftIO $ readIORef r
forM_ (reverse pairs) $ \(name, r) ->
do stats <- liftIO $ readIORef r
let writer = timingStatsWriter (timingStatsView st)
write = timingStatsWrite writer
write writer name stats
header :: TimingStatsViewState -> Int -> HtmlWriter ()
header st index =
do writeHtmlHeader3WithId ("id" ++ show index) $
writeHtmlText (timingStatsTitle $ timingStatsView st)
let description = timingStatsDescription $ timingStatsView st
unless (null description) $
writeHtmlParagraph $
writeHtmlText description
timingStatsTOCHtml :: TimingStatsViewState -> Int -> HtmlWriter ()
timingStatsTOCHtml st index =
writeHtmlListItem $
writeHtmlLink ("#id" ++ show index) $
writeHtmlText (timingStatsTitle $ timingStatsView st)