module Simulation.Aivika.Experiment.FinalTableView
(FinalTableView(..),
defaultFinalTableView) where
import Control.Monad
import Control.Monad.Trans
import Control.Concurrent.MVar
import qualified Data.Map as M
import Data.IORef
import Data.Maybe
import System.IO
import System.FilePath
import Simulation.Aivika
import Simulation.Aivika.Experiment.Types
import Simulation.Aivika.Experiment.WebPageRenderer
import Simulation.Aivika.Experiment.FileRenderer
import Simulation.Aivika.Experiment.ExperimentWriter
import Simulation.Aivika.Experiment.HtmlWriter
import Simulation.Aivika.Experiment.MRef
data FinalTableView =
FinalTableView { finalTableTitle :: String,
finalTableDescription :: String,
finalTableRunText :: String,
finalTableLinkText :: String,
finalTableFileName :: ExperimentFilePath,
finalTableSeparator :: String,
finalTableFormatter :: ShowS,
finalTablePredicate :: Event Bool,
finalTableTransform :: ResultTransform,
finalTableSeries :: ResultTransform
}
defaultFinalTableView :: FinalTableView
defaultFinalTableView =
FinalTableView { finalTableTitle = "Final Table",
finalTableDescription = "It refers to the CSV file with the results in the final time points.",
finalTableRunText = "Run",
finalTableLinkText = "Download the CSV file",
finalTableFileName = UniqueFilePath "FinalTable.csv",
finalTableSeparator = ",",
finalTableFormatter = id,
finalTablePredicate = return True,
finalTableTransform = expandResults,
finalTableSeries = id }
instance ExperimentView FinalTableView (WebPageRenderer a) where
outputView v =
let reporter exp renderer dir =
do st <- newFinalTable v exp dir
let context =
WebPageContext
WebPageWriter { reporterWriteTOCHtml = finalTableTOCHtml st,
reporterWriteHtml = finalTableHtml st }
return ExperimentReporter { reporterInitialise = return (),
reporterFinalise = finaliseFinalTable st,
reporterSimulate = simulateFinalTable st,
reporterContext = context }
in ExperimentGenerator { generateReporter = reporter }
instance ExperimentView FinalTableView (FileRenderer a) where
outputView v =
let reporter exp renderer dir =
do st <- newFinalTable v exp dir
return ExperimentReporter { reporterInitialise = return (),
reporterFinalise = finaliseFinalTable st,
reporterSimulate = simulateFinalTable st,
reporterContext = FileContext }
in ExperimentGenerator { generateReporter = reporter }
data FinalTableViewState =
FinalTableViewState { finalTableView :: FinalTableView,
finalTableExperiment :: Experiment,
finalTableDir :: FilePath,
finalTableFile :: IORef (Maybe FilePath),
finalTableResults :: MRef (Maybe FinalTableResults) }
data FinalTableResults =
FinalTableResults { finalTableNames :: [String],
finalTableValues :: MRef (M.Map Int [String]) }
newFinalTable :: FinalTableView -> Experiment -> FilePath -> ExperimentWriter FinalTableViewState
newFinalTable view exp dir =
do f <- liftIO $ newIORef Nothing
r <- liftIO $ newMRef Nothing
return FinalTableViewState { finalTableView = view,
finalTableExperiment = exp,
finalTableDir = dir,
finalTableFile = f,
finalTableResults = r }
newFinalTableResults :: [String] -> Experiment -> IO FinalTableResults
newFinalTableResults names exp =
do values <- newMRef M.empty
return FinalTableResults { finalTableNames = names,
finalTableValues = values }
requireFinalTableResults :: FinalTableViewState -> [String] -> IO FinalTableResults
requireFinalTableResults st names =
maybeWriteMRef (finalTableResults st)
(newFinalTableResults names (finalTableExperiment st)) $ \results ->
if (names /= finalTableNames results)
then error "Series with different names are returned for different runs: requireFinalTableResults"
else return results
simulateFinalTable :: FinalTableViewState -> ExperimentData -> Event DisposableEvent
simulateFinalTable st expdata =
do let view = finalTableView st
rs = finalTableSeries view $
finalTableTransform view $
experimentResults expdata
exts = resultsToStringValues rs
signals = experimentPredefinedSignals expdata
signal = filterSignalM (const predicate) $
resultSignalInStopTime signals
names = map resultValueName exts
predicate = finalTablePredicate view
results <- liftIO $ requireFinalTableResults st names
let values = finalTableValues results
handleSignal signal $ \_ ->
do xs <- mapM resultValueData exts
i <- liftParameter simulationIndex
liftIO $ modifyMRef_ values $ return . M.insert i xs
finaliseFinalTable :: FinalTableViewState -> ExperimentWriter ()
finaliseFinalTable st =
do let view = finalTableView st
run = finalTableRunText view
formatter = finalTableFormatter view
title = finalTableTitle view
separator = finalTableSeparator view
results <- liftIO $ readMRef $ finalTableResults st
case results of
Nothing -> return ()
Just results ->
do let names = finalTableNames results
values = finalTableValues results
m <- liftIO $ readMRef values
file <- resolveFilePath (finalTableDir st) $
mapFilePath (flip replaceExtension ".csv") $
expandFilePath (finalTableFileName $ finalTableView st) $
M.fromList [("$TITLE", title)]
liftIO $ do
h <- openFile file WriteMode
hPutStr h $ show run
forM_ names $ \name ->
do hPutStr h separator
hPutStr h $ show name
hPutStrLn h ""
forM_ (M.assocs m) $ \(i, xs) ->
do hPutStr h $ show i
forM_ xs $ \x ->
do hPutStr h separator
hPutStr h $ formatter x
hPutStrLn h ""
hClose h
when (experimentVerbose $ finalTableExperiment st) $
putStr "Generated file " >> putStrLn file
writeIORef (finalTableFile st) $ Just file
finalTableHtml :: FinalTableViewState -> Int -> HtmlWriter ()
finalTableHtml st index =
do header st index
file <- liftIO $ readIORef (finalTableFile st)
case file of
Nothing -> return ()
Just f ->
writeHtmlParagraph $
writeHtmlLink (makeRelative (finalTableDir st) f) $
writeHtmlText (finalTableLinkText $ finalTableView st)
header :: FinalTableViewState -> Int -> HtmlWriter ()
header st index =
do writeHtmlHeader3WithId ("id" ++ show index) $
writeHtmlText (finalTableTitle $ finalTableView st)
let description = finalTableDescription $ finalTableView st
unless (null description) $
writeHtmlParagraph $
writeHtmlText description
finalTableTOCHtml :: FinalTableViewState -> Int -> HtmlWriter ()
finalTableTOCHtml st index =
writeHtmlListItem $
writeHtmlLink ("#id" ++ show index) $
writeHtmlText (finalTableTitle $ finalTableView st)