aivika-experiment 0.1.1 → 0.1.2
raw patch · 10 files changed
+1750/−1518 lines, 10 filesdep +parallel-iosetup-changedPVP ok
version bump matches the API change (PVP)
Dependencies added: parallel-io
API changes (from Hackage documentation)
+ Simulation.Aivika.Experiment: instance Series (Simulation Double)
+ Simulation.Aivika.Experiment: instance Series (Simulation Int)
+ Simulation.Aivika.Experiment: instance Series (Simulation String)
+ Simulation.Aivika.Experiment: runExperimentParallel :: Experiment -> Simulation ExperimentData -> IO ()
+ Simulation.Aivika.Experiment.Histogram: binDoane :: BinningStrategy
+ Simulation.Aivika.Experiment.Histogram: binScott :: BinningStrategy
+ Simulation.Aivika.Experiment.Histogram: binSqrt :: BinningStrategy
+ Simulation.Aivika.Experiment.Histogram: binSturges :: BinningStrategy
+ Simulation.Aivika.Experiment.Histogram: histogram :: BinningStrategy -> [[Double]] -> Histogram
+ Simulation.Aivika.Experiment.Histogram: histogramBinSize :: Double -> [[Double]] -> Histogram
+ Simulation.Aivika.Experiment.Histogram: histogramNumBins :: Int -> [[Double]] -> Histogram
+ Simulation.Aivika.Experiment.Histogram: type BinningStrategy = [Double] -> Int
+ Simulation.Aivika.Experiment.Histogram: type Histogram = [(Double, [Int])]
Files
- LICENSE +30/−30
- Setup.lhs +3/−3
- Simulation/Aivika/Experiment.hs +539/−485
- Simulation/Aivika/Experiment/Histogram.hs +175/−0
- Simulation/Aivika/Experiment/HtmlWriter.hs +384/−384
- Simulation/Aivika/Experiment/LastValueView.hs +178/−178
- Simulation/Aivika/Experiment/TableView.hs +246/−245
- Simulation/Aivika/Experiment/Utils.hs +22/−22
- aivika-experiment.cabal +47/−45
- examples/MachRep3.hs +126/−126
LICENSE view
@@ -1,30 +1,30 @@-Copyright (c) 2012 David Sorokin <david.sorokin@gmail.com> - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: - -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - -2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - -3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS -OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) -HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY -OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF -SUCH DAMAGE. +Copyright (c) 2012 David Sorokin <david.sorokin@gmail.com>++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
Setup.lhs view
@@ -1,3 +1,3 @@-#!/usr/bin/env runhaskell -> import Distribution.Simple -> main = defaultMain +#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
Simulation/Aivika/Experiment.hs view
@@ -1,485 +1,539 @@- -{-# LANGUAGE FlexibleInstances #-} - --- | --- Module : Simulation.Aivika.Experiment --- Copyright : Copyright (c) 2012, David Sorokin <david.sorokin@gmail.com> --- License : BSD3 --- Maintainer : David Sorokin <david.sorokin@gmail.com> --- Stability : experimental --- Tested with: GHC 7.4.1 --- --- 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 simulations 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 - (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 - --- | 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. - } - --- | 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 } - --- | 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. -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 (Dynamics Double), - -- ^ Try to return the data as double values. - providerToInt :: Maybe (Dynamics Int), - -- ^ Try to return the data as integers. - providerToString :: Maybe (Dynamics 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 { experimentQueue :: EventQueue, - -- ^ Return the event queue. - 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 :: 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 } - --- | 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 -> - Dynamics (Dynamics ()), - -- ^ 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 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 () - --- | 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 - ((), contents) <- runHtmlWriter html id - writeFile (path ++ "/index.html") (contents []) - when (experimentVerbose e) $ - do putStr "Generated file " - putStr path - putStrLn "/index.html" - --- | 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 - -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 } ++{-# LANGUAGE FlexibleInstances #-}++-- |+-- Module : Simulation.Aivika.Experiment+-- Copyright : Copyright (c) 2012, David Sorokin <david.sorokin@gmail.com>+-- License : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability : experimental+-- Tested with: GHC 7.4.1+--+-- 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 simulations 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+ (Experiment(..),+ defaultExperiment,+ runExperiment,+ runExperimentParallel,+ ExperimentData(..),+ experimentDataInStartTime,+ experimentSeriesProviders,+ experimentMixedSignal,+ Series(..),+ SeriesEntity(..),+ SeriesProvider(..),+ 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 Data.Array+import Data.Maybe+import Data.Monoid+import Data.String.Utils (replace)++import System.IO+import System.Directory+import System.FilePath (combine)++import GHC.Conc (getNumCapabilities)++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++-- | 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. + }++-- | 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 }++-- | 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.+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 (Dynamics Double),+ -- ^ Try to return the data as double values.+ providerToInt :: Maybe (Dynamics Int),+ -- ^ Try to return the data as integers.+ providerToString :: Maybe (Dynamics 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 { experimentQueue :: EventQueue,+ -- ^ Return the event queue.+ 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 :: 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 }++-- | 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 -> + Dynamics (Dynamics ()),+ -- ^ 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.+runExperimentParallel :: Experiment -> Simulation ExperimentData -> IO ()+runExperimentParallel = runExperimentWithExecutor executor + where executor tasks =+ do n <- getNumCapabilities+ 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 <- runDynamicsInStartTime $+ forM reporters $ \reporter ->+ reporterSimulate reporter d+ runDynamicsInStopTime $+ do updateSignal $ + experimentMixedSignal d $+ join $ map seriesProviders $+ M.elems $ experimentSeries d+ 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+ 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++instance Series (Simulation Double) where+ + seriesEntity name s =+ SeriesEntity { seriesProviders =+ [SeriesProvider { providerName = name,+ providerToDouble = Just $ liftSimulation s,+ providerToInt = Nothing,+ providerToString = Just $ liftSimulation $ fmap show s,+ providerSignal = Nothing }] }++instance Series (Simulation Int) where+ + seriesEntity name s =+ SeriesEntity { seriesProviders =+ [SeriesProvider { providerName = name,+ providerToDouble = Just $ liftSimulation $ fmap fromIntegral s,+ providerToInt = Just $ liftSimulation s,+ providerToString = Just $ liftSimulation $ fmap show s,+ providerSignal = Nothing }] }++instance Series (Simulation String) where+ + seriesEntity name s =+ SeriesEntity { seriesProviders =+ [SeriesProvider { providerName = name,+ providerToDouble = Nothing,+ providerToInt = Nothing,+ providerToString = Just $ liftSimulation s,+ providerSignal = Nothing }] }++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 fromIntegral 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 fromIntegral (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 fromIntegral (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 fromIntegral (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 }
+ Simulation/Aivika/Experiment/Histogram.hs view
@@ -0,0 +1,175 @@++-- | This module computes the histogram by the +-- specified data and strategy applied for such computing.+--+-- The code in this module is essentially based on the +-- <http://hackage.haskell.org/package/Histogram> package+-- by Mike Izbicki, who kindly agreed to re-license +-- his library under BSD3, which allowed me to use his +-- code and comments with some modifications. ++module Simulation.Aivika.Experiment.Histogram + (-- * Creating Histograms+ Histogram(..), + histogram, + histogramBinSize, + histogramNumBins,+ -- * Binning Strategies+ BinningStrategy(..),+ binSturges, + binDoane, + binSqrt, + binScott) where++import Data.List+import Data.Monoid+import qualified Data.Map as Map++import Numeric++---+import System.IO.Unsafe+---++-------------------------------------------------------------------------------++-- | Holds all the information needed to plot the histogram +-- for a list of different series. Each series produces its +-- own item in the resuling @[Int]@ list that may contain+-- zeros.+type Histogram = [(Double, [Int])]++-------------------------------------------------------------------------------+-- Bin counters; check out http://en.wikipedia.org/wiki/Histogram#Number_of_bins_and_width++-- | The strategy applied to calculate the histogram bins.+type BinningStrategy = [Double] -> Int++-- | This is only a helper function to convert strategies that +-- specify bin width into strategies that specify the number of bins.+stratFromBinWidth :: [Double] -> Double -> Int+stratFromBinWidth xs h = ceiling $ (maximum xs - minimum xs) / h++-- | Sturges' binning strategy is the least computational work, +-- but recommended for only normal data.+binSturges :: BinningStrategy+binSturges xs = ceiling $ logBase 2 n + 1+ where n = fromIntegral $ length xs+ +-- | Doane's binning strategy extends Sturges' for non-normal data. +-- It takes a little more time because it must calculate the kurtosis +-- (peakkiness) of the distribution.+binDoane :: BinningStrategy+binDoane xs = ceiling $ 1 + log n + log (1 + a * ((n/6)**(1/2)))+ where + n = fromIntegral $ length xs+ a = kurtosis xs+ +-- | Using the sqrt of the number of samples is not supported by any +-- theory, but is commonly used by excel and other histogram making software.+binSqrt :: BinningStrategy+binSqrt xs = round $ sqrt n+ where + n = fromIntegral $ length xs++-- | Scott's rule is the optimal solution for normal data, but requires +-- more computation than Sturges'.+binScott :: BinningStrategy+binScott xs = stratFromBinWidth xs $ 3.5 * stddev xs / (n**(1/3))+ where + n = fromIntegral $ length xs+ +-------------------------------------------------------------------------------+-- create the histogram data++-- | Creates a histogram by specifying the list of series. Call it with one of +-- the binning strategies that is appropriate to the type of data you have. +-- If you don't know, then try using 'binSturges'.+histogram :: BinningStrategy -> [[Double]] -> Histogram+histogram strat xs = histogramNumBins (strat $ concat xs) xs++-- | Create a histogram by specifying the exact bin size. +-- You probably don't want to use this function, and should use histogram +-- with an appropriate binning strategy.+histogramBinSize :: Double -> [[Double]] -> Histogram+histogramBinSize size = combineBins . map (histBins size . bin size)++-- | Create a histogram by the specified approximated number of bins.+-- You probably don't want to use this function, and should use +-- histogram with an appropriate binning strategy.+histogramNumBins :: Int -> [[Double]] -> Histogram+histogramNumBins n xs =+ histogramBinSize size xs+ where+ size = fromIntegral (firstdigit diff) * (10 ** fromIntegral (exponent10 diff))+ diff = if diff_test > 0+ then diff_test+ else 1+ diff_test = (maximum (map maximum xs) - + minimum (map minimum xs)) / fromIntegral (max 1 n)++ firstdigit dbl = floor $ dbl / (10 ** fromIntegral (exponent10 dbl))+ exponent10 dbl = floor $ logBase 10 dbl++-- | It does all the binning for the histogram.+histBins :: Double -> [Double] -> [(Double, Int)]+histBins size xs = [ (head l, length l) | l <- group (sort xs) ]++-- | It "rounds" every number into the closest number below it +-- that is divisible by size.+bin :: Double -> [Double] -> [Double]+bin size xs @ [_] = xs+bin size xs = map (\x -> size * fromIntegral (floor (x / size)) + size / 2) xs++-- | Combine bins from different histograms (optimized version).+combineBins :: [[(Double, Int)]] -> [(Double, [Int])]+combineBins [xs] = map (\(t, n) -> (t, [n])) xs+combineBins xss = combineBins' xss++-- | Combine bins from different histograms (generic version).+combineBins' :: [[(Double, Int)]] -> [(Double, [Int])]+combineBins' xs = map (merging . sorting) $ + groupping $ ordering $ concat $ numbering xs+ where numbering = zipWith (curry indexing) [1..]+ indexing (i, x) = map (\(t, n) -> (i, t, n)) x+ ordering = sortBy $ \(_, t1, _) (_, t2, _) -> compare t1 t2+ groupping = groupBy $ \(_, t1, _) (_, t2, _) -> t1 == t2+ sorting = sortBy $ \(i1, _, _) (i2, _, _) -> compare i1 i2+ merging zs @ ((_, t, _) : _) = merging' zs t 1 []+ merging' [] t k acc+ | k <= count = merging' [] t (k + 1) (0 : acc)+ | k > count = (t, reverse acc)+ merging' zs @ ((i, _, n) : xs) t k acc+ | i == k = merging' xs t (k + 1) (n : acc)+ | i > k = merging' zs t (k + 1) (0 : acc)+ count = length xs++------------------------------------------------------------------------------+-- simple math functions+-- taken from package hstats, which wouldn't fully compile++-- | Numerically stable mean.+mean :: Floating a => [a] -> a+mean x = fst $ foldl' (\(m, n) x -> (m+(x-m)/(n+1),n+1)) (0,0) x++-- | Standard deviation of sample.+stddev :: (Floating a) => [a] -> a+stddev xs = sqrt $ var xs++-- | Sample variance.+var :: (Floating a) => [a] -> a+var xs = var' 0 0 0 xs / fromIntegral (length xs - 1)+ where+ var' _ _ s [] = s+ var' m n s (x:xs) = var' nm (n + 1) (s + delta * (x - nm)) xs+ where+ delta = x - m+ nm = m + delta / fromIntegral (n + 1)++-- | kurtosis is taken from wikipedia's definition.+kurtosis :: (Floating a) => [a] -> a+kurtosis xs = ((1/n) * sum [(x-x_bar)^4 | x <- xs])+ / ((1/n) * sum [(x-x_bar)^2 | x <- xs])^2 -3+ where + n = fromIntegral $ length xs+ x_bar = mean xs
Simulation/Aivika/Experiment/HtmlWriter.hs view
@@ -1,384 +1,384 @@- --- | --- Module : Simulation.Aivika.Experiment.HtmlWriter --- Copyright : Copyright (c) 2012, David Sorokin <david.sorokin@gmail.com> --- License : BSD3 --- Maintainer : David Sorokin <david.sorokin@gmail.com> --- Stability : experimental --- Tested with: GHC 7.4.1 --- --- This is an utility module that provides an HTML writer. --- - -module Simulation.Aivika.Experiment.HtmlWriter - (HtmlWriter, - runHtmlWriter, - composeHtml, - writeHtml, - writeHtmlLn, - writeHtmlText, - writeHtmlParagraph, - writeHtmlParagraphWithId, - writeHtmlHeader1, - writeHtmlHeader1WithId, - writeHtmlHeader2, - writeHtmlHeader2WithId, - writeHtmlHeader3, - writeHtmlHeader3WithId, - writeHtmlHeader4, - writeHtmlHeader4WithId, - writeHtmlHeader5, - writeHtmlHeader5WithId, - writeHtmlHeader6, - writeHtmlHeader6WithId, - writeHtmlBreak, - writeHtmlLink, - writeHtmlImage, - writeHtmlList, - writeHtmlListItem, - writeHtmlDocumentWithTitle, - encodeHtmlText) where - -import Control.Monad -import Control.Monad.Trans - -import Network.URI - --- | It writes fast an HTML code. -newtype HtmlWriter a = - HtmlWriter { runHtmlWriter :: ShowS -> IO (a, ShowS) - -- ^ Run the HTML writer monad. - } - -instance Monad HtmlWriter where - - return a = HtmlWriter $ \f -> return (a, f) - - (HtmlWriter m) >>= k = HtmlWriter $ \f -> - do (a, f') <- m f - let HtmlWriter m' = k a - m' f' - -instance MonadIO HtmlWriter where - - liftIO m = HtmlWriter $ \f -> - do x <- m - return (x, f) - --- | Write the HTML code. -writeHtml :: String -> HtmlWriter () -writeHtml code = - HtmlWriter $ \f -> return ((), f . (code ++)) - --- | Write the HTML code. -writeHtmlLn :: String -> HtmlWriter () -writeHtmlLn code = - do writeHtml code - writeHtml "\n" - --- | Write the text in HTML. -writeHtmlText :: String -> HtmlWriter () -writeHtmlText text = - HtmlWriter $ \f -> return ((), f . (encodeHtmlText text ++)) - --- | Compose the HTML applying the corresponded transformation. -composeHtml :: ShowS -> HtmlWriter () -composeHtml g = - HtmlWriter $ \f -> return ((), f . g) - --- | Write the HTML link with the specified URI and contents. -writeHtmlLink :: String -> HtmlWriter () -> HtmlWriter () -writeHtmlLink uri inner = - do writeHtml "<a href=\"" - writeHtml $ escapeURIString isUnescapedInURI uri - writeHtml "\">" - inner - writeHtml "</a>" - --- | Write the HTML image with the specified URI. -writeHtmlImage :: String -> HtmlWriter () -writeHtmlImage uri = - do writeHtml "<img src=\"" - writeHtml $ escapeURIString isUnescapedInURI uri - writeHtml "\" />" - --- | Write the @\<p\>@ element with the specified contents. -writeHtmlParagraph :: HtmlWriter () -> HtmlWriter () -writeHtmlParagraph inner = - do writeHtml "<p>" - inner - writeHtml "</p>" - --- | Write the @\<h1\>@ element with the specified contents. -writeHtmlHeader1 :: HtmlWriter () -> HtmlWriter () -writeHtmlHeader1 inner = - do writeHtml "<h1>" - inner - writeHtml "</h1>" - --- | Write the @\<h2\>@ element with the specified contents. -writeHtmlHeader2 :: HtmlWriter () -> HtmlWriter () -writeHtmlHeader2 inner = - do writeHtml "<h2>" - inner - writeHtml "</h2>" - --- | Write the @\<h3\>@ element with the specified contents. -writeHtmlHeader3 :: HtmlWriter () -> HtmlWriter () -writeHtmlHeader3 inner = - do writeHtml "<h3>" - inner - writeHtml "</h3>" - --- | Write the @\<h4\>@ element with the specified contents. -writeHtmlHeader4 :: HtmlWriter () -> HtmlWriter () -writeHtmlHeader4 inner = - do writeHtml "<h4>" - inner - writeHtml "</h4>" - --- | Write the @\<h5\>@ element with the specified contents. -writeHtmlHeader5 :: HtmlWriter () -> HtmlWriter () -writeHtmlHeader5 inner = - do writeHtml "<h5>" - inner - writeHtml "</h5>" - --- | Write the @\<h6\>@ element with the specified contents. -writeHtmlHeader6 :: HtmlWriter () -> HtmlWriter () -writeHtmlHeader6 inner = - do writeHtml "<h6>" - inner - writeHtml "</h6>" - --- | Write the @\<p\>@ element with the specified id and contents. -writeHtmlParagraphWithId :: String -> HtmlWriter () -> HtmlWriter () -writeHtmlParagraphWithId id inner = - do writeHtml "<p id=\"" - writeHtml id - writeHtml "\">" - inner - writeHtml "</p>" - --- | Write the @\<h1\>@ element with the specified id and contents. -writeHtmlHeader1WithId :: String -> HtmlWriter () -> HtmlWriter () -writeHtmlHeader1WithId id inner = - do writeHtml "<h1 id=\"" - writeHtml id - writeHtml "\">" - inner - writeHtml "</h1>" - --- | Write the @\<h2\>@ element with the specified id and contents. -writeHtmlHeader2WithId :: String -> HtmlWriter () -> HtmlWriter () -writeHtmlHeader2WithId id inner = - do writeHtml "<h2 id=\"" - writeHtml id - writeHtml "\">" - inner - writeHtml "</h2>" - --- | Write the @\<h3\>@ element with the specified id and contents. -writeHtmlHeader3WithId :: String -> HtmlWriter () -> HtmlWriter () -writeHtmlHeader3WithId id inner = - do writeHtml "<h3 id=\"" - writeHtml id - writeHtml "\">" - inner - writeHtml "</h3>" - --- | Write the @\<h4\>@ element with the specified id and contents. -writeHtmlHeader4WithId :: String -> HtmlWriter () -> HtmlWriter () -writeHtmlHeader4WithId id inner = - do writeHtml "<h4 id=\"" - writeHtml id - writeHtml "\">" - inner - writeHtml "</h4>" - --- | Write the @\<h5\>@ element with the specified id and contents. -writeHtmlHeader5WithId :: String -> HtmlWriter () -> HtmlWriter () -writeHtmlHeader5WithId id inner = - do writeHtml "<h5 id=\"" - writeHtml id - writeHtml "\">" - inner - writeHtml "</h5>" - --- | Write the @\<h6\>@ element with the specified id and contents. -writeHtmlHeader6WithId :: String -> HtmlWriter () -> HtmlWriter () -writeHtmlHeader6WithId id inner = - do writeHtml "<h6 id=\"" - writeHtml id - writeHtml "\">" - inner - writeHtml "</h6>" - --- | Write the @\<br\>@ element. -writeHtmlBreak :: HtmlWriter () -writeHtmlBreak = - writeHtml "<br />" - --- | Write the list of items wrapped in @\<ul\>@. -writeHtmlList :: HtmlWriter () -> HtmlWriter () -writeHtmlList inner = - do writeHtml "<ul>" - inner - writeHtml "</ul>" - --- | Write the item list wrapped in @\<li\>@. -writeHtmlListItem :: HtmlWriter () -> HtmlWriter () -writeHtmlListItem inner = - do writeHtml "<li>" - inner - writeHtml "</li>" - --- | Write the HTML document with the specified title and contents -writeHtmlDocumentWithTitle :: String -> HtmlWriter () -> HtmlWriter () -writeHtmlDocumentWithTitle title inner = - do writeHtml "<html>" - writeHtml "<head>" - writeHtml "<title>" - writeHtmlText title - writeHtml "</title>" - writeHtmlCss - writeHtml "</head>" - writeHtml "<body>" - writeHtmlHeader1 $ - writeHtmlText title - writeHtml "</h1>" - inner - writeHtml "<br /><p><font size=\"-1\">Automatically generated by " - writeHtml "<a href=\"https://github.com/dsorokin/aivika-experiment\">" - writeHtml "Aivika Experiment</a>" - writeHtml "</font></p>" - writeHtml "</body>" - writeHtml "</html>" - --- | Escape special HTML characters in the 'String'. --- It is based on one function from package Web-Encodings, --- which is licensed under BSD3 but obsolete now. -encodeHtmlText :: String -> String -encodeHtmlText x = join $ map encodeHtmlChar x - --- | Escape a character. -encodeHtmlChar :: Char -> String -encodeHtmlChar '<' = "<" -encodeHtmlChar '>' = ">" -encodeHtmlChar '&' = "&" -encodeHtmlChar '"' = """ -encodeHtmlChar '\'' = "'" -encodeHtmlChar c = [c] - --- | Write the CSS styles -writeHtmlCss :: HtmlWriter () -writeHtmlCss = - do writeHtmlLn "<style type=\"text/css\">" - writeHtmlLn "* { margin: 0; padding: 0 }" - writeHtmlLn "" - writeHtmlLn "html {" - writeHtmlLn " background-color: white;" - writeHtmlLn " width: 100%;" - writeHtmlLn " height: 100%;" - writeHtmlLn "}" - writeHtmlLn "" - writeHtmlLn "body {" - writeHtmlLn " background: white;" - writeHtmlLn " color: black;" - writeHtmlLn " text-align: left;" - writeHtmlLn " min-height: 100%;" - writeHtmlLn " position: relative;" - writeHtmlLn "}" - writeHtmlLn "" - writeHtmlLn "p {" - writeHtmlLn " margin: 0.8em 0;" - writeHtmlLn "}" - writeHtmlLn "" - writeHtmlLn "ul, ol {" - writeHtmlLn " margin: 0.8em 0 0.8em 2em;" - writeHtmlLn "}" - writeHtmlLn "" - writeHtmlLn "dl {" - writeHtmlLn " margin: 0.8em 0;" - writeHtmlLn "}" - writeHtmlLn "" - writeHtmlLn "dt {" - writeHtmlLn " font-weight: bold;" - writeHtmlLn "}" - writeHtmlLn "" - writeHtmlLn "dd {" - writeHtmlLn " margin-left: 2em;" - writeHtmlLn "}" - writeHtmlLn "" - writeHtmlLn "a { text-decoration: none; }" - writeHtmlLn "a[href]:link { color: rgb(196,69,29); }" - writeHtmlLn "a[href]:visited { color: rgb(171,105,84); }" - writeHtmlLn "a[href]:hover { text-decoration:underline; }" - writeHtmlLn "" - writeHtmlLn "body {" - writeHtmlLn " font:13px/1.4 sans-serif;" - writeHtmlLn " *font-size:small; /* for IE */" - writeHtmlLn " *font:x-small; /* for IE in quirks mode */" - writeHtmlLn "}" - writeHtmlLn "" - writeHtmlLn "h1 { font-size: 146.5%; /* 19pt */ } " - writeHtmlLn "h2 { font-size: 131%; /* 17pt */ }" - writeHtmlLn "h3 { font-size: 116%; /* 15pt */ }" - writeHtmlLn "h4 { font-size: 100%; /* 13pt */ }" - writeHtmlLn "h5 { font-size: 100%; /* 13pt */ }" - writeHtmlLn "" - writeHtmlLn "select, input, button, textarea {" - writeHtmlLn " font:99% sans-serif;" - writeHtmlLn "}" - writeHtmlLn "" - writeHtmlLn "table {" - writeHtmlLn " font-size:inherit;" - writeHtmlLn " font:100%;" - writeHtmlLn "}" - writeHtmlLn "" - writeHtmlLn "pre, code, kbd, samp, tt, .src {" - writeHtmlLn " font-family:monospace;" - writeHtmlLn " *font-size:108%;" - writeHtmlLn " line-height: 124%;" - writeHtmlLn "}" - writeHtmlLn "" - writeHtmlLn ".links, .link {" - writeHtmlLn " font-size: 85%; /* 11pt */" - writeHtmlLn "}" - writeHtmlLn ".info {" - writeHtmlLn " font-size: 85%; /* 11pt */" - writeHtmlLn "}" - writeHtmlLn "" - writeHtmlLn ".caption, h1, h2, h3, h4, h5, h6 { " - writeHtmlLn " font-weight: bold;" - writeHtmlLn " color: rgb(78,98,114);" - writeHtmlLn " margin: 0.8em 0 0.4em;" - writeHtmlLn "}" - writeHtmlLn "" - writeHtmlLn "* + h1, * + h2, * + h3, * + h4, * + h5, * + h6 {" - writeHtmlLn " margin-top: 2em;" - writeHtmlLn "}" - writeHtmlLn "" - writeHtmlLn "h1 + h2, h2 + h3, h3 + h4, h4 + h5, h5 + h6 {" - writeHtmlLn " margin-top: inherit;" - writeHtmlLn "}" - writeHtmlLn "" - writeHtmlLn "ul.links {" - writeHtmlLn " list-style: none;" - writeHtmlLn " text-align: left;" - writeHtmlLn " float: right;" - writeHtmlLn " display: inline-table;" - writeHtmlLn " margin: 0 0 0 1em;" - writeHtmlLn "}" - writeHtmlLn "" - writeHtmlLn "ul.links li {" - writeHtmlLn " display: inline;" - writeHtmlLn " border-left: 1px solid #d5d5d5; " - writeHtmlLn " white-space: nowrap;" - writeHtmlLn " padding: 0;" - writeHtmlLn "}" - writeHtmlLn "" - writeHtmlLn "ul.links li a {" - writeHtmlLn " padding: 0.2em 0.5em;" - writeHtmlLn "}" - writeHtmlLn "</style>" ++-- |+-- Module : Simulation.Aivika.Experiment.HtmlWriter+-- Copyright : Copyright (c) 2012, David Sorokin <david.sorokin@gmail.com>+-- License : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability : experimental+-- Tested with: GHC 7.4.1+--+-- This is an utility module that provides an HTML writer.+--++module Simulation.Aivika.Experiment.HtmlWriter + (HtmlWriter,+ runHtmlWriter,+ composeHtml,+ writeHtml,+ writeHtmlLn,+ writeHtmlText,+ writeHtmlParagraph,+ writeHtmlParagraphWithId,+ writeHtmlHeader1,+ writeHtmlHeader1WithId,+ writeHtmlHeader2,+ writeHtmlHeader2WithId,+ writeHtmlHeader3,+ writeHtmlHeader3WithId,+ writeHtmlHeader4,+ writeHtmlHeader4WithId,+ writeHtmlHeader5,+ writeHtmlHeader5WithId,+ writeHtmlHeader6,+ writeHtmlHeader6WithId,+ writeHtmlBreak,+ writeHtmlLink,+ writeHtmlImage,+ writeHtmlList,+ writeHtmlListItem,+ writeHtmlDocumentWithTitle,+ encodeHtmlText) where++import Control.Monad+import Control.Monad.Trans++import Network.URI++-- | It writes fast an HTML code.+newtype HtmlWriter a = + HtmlWriter { runHtmlWriter :: ShowS -> IO (a, ShowS)+ -- ^ Run the HTML writer monad.+ }++instance Monad HtmlWriter where+ + return a = HtmlWriter $ \f -> return (a, f)+ + (HtmlWriter m) >>= k = HtmlWriter $ \f ->+ do (a, f') <- m f+ let HtmlWriter m' = k a+ m' f'+ +instance MonadIO HtmlWriter where + + liftIO m = HtmlWriter $ \f ->+ do x <- m+ return (x, f)+ +-- | Write the HTML code.+writeHtml :: String -> HtmlWriter ()+writeHtml code = + HtmlWriter $ \f -> return ((), f . (code ++))+ +-- | Write the HTML code.+writeHtmlLn :: String -> HtmlWriter ()+writeHtmlLn code = + do writeHtml code+ writeHtml "\n"+ +-- | Write the text in HTML. +writeHtmlText :: String -> HtmlWriter () +writeHtmlText text =+ HtmlWriter $ \f -> return ((), f . (encodeHtmlText text ++))+ +-- | Compose the HTML applying the corresponded transformation. +composeHtml :: ShowS -> HtmlWriter () +composeHtml g =+ HtmlWriter $ \f -> return ((), f . g)++-- | Write the HTML link with the specified URI and contents.+writeHtmlLink :: String -> HtmlWriter () -> HtmlWriter ()+writeHtmlLink uri inner =+ do writeHtml "<a href=\""+ writeHtml $ escapeURIString isUnescapedInURI uri+ writeHtml "\">"+ inner+ writeHtml "</a>"+ +-- | Write the HTML image with the specified URI.+writeHtmlImage :: String -> HtmlWriter ()+writeHtmlImage uri =+ do writeHtml "<img src=\""+ writeHtml $ escapeURIString isUnescapedInURI uri+ writeHtml "\" />"++-- | Write the @\<p\>@ element with the specified contents. +writeHtmlParagraph :: HtmlWriter () -> HtmlWriter () +writeHtmlParagraph inner =+ do writeHtml "<p>"+ inner+ writeHtml "</p>"+ +-- | Write the @\<h1\>@ element with the specified contents. +writeHtmlHeader1 :: HtmlWriter () -> HtmlWriter () +writeHtmlHeader1 inner =+ do writeHtml "<h1>"+ inner+ writeHtml "</h1>"+ +-- | Write the @\<h2\>@ element with the specified contents. +writeHtmlHeader2 :: HtmlWriter () -> HtmlWriter () +writeHtmlHeader2 inner =+ do writeHtml "<h2>"+ inner+ writeHtml "</h2>"+ +-- | Write the @\<h3\>@ element with the specified contents. +writeHtmlHeader3 :: HtmlWriter () -> HtmlWriter () +writeHtmlHeader3 inner =+ do writeHtml "<h3>"+ inner+ writeHtml "</h3>"+ +-- | Write the @\<h4\>@ element with the specified contents. +writeHtmlHeader4 :: HtmlWriter () -> HtmlWriter () +writeHtmlHeader4 inner =+ do writeHtml "<h4>"+ inner+ writeHtml "</h4>"+ +-- | Write the @\<h5\>@ element with the specified contents. +writeHtmlHeader5 :: HtmlWriter () -> HtmlWriter () +writeHtmlHeader5 inner =+ do writeHtml "<h5>"+ inner+ writeHtml "</h5>"+ +-- | Write the @\<h6\>@ element with the specified contents. +writeHtmlHeader6 :: HtmlWriter () -> HtmlWriter () +writeHtmlHeader6 inner =+ do writeHtml "<h6>"+ inner+ writeHtml "</h6>"+ +-- | Write the @\<p\>@ element with the specified id and contents. +writeHtmlParagraphWithId :: String -> HtmlWriter () -> HtmlWriter () +writeHtmlParagraphWithId id inner =+ do writeHtml "<p id=\""+ writeHtml id+ writeHtml "\">"+ inner+ writeHtml "</p>"+ +-- | Write the @\<h1\>@ element with the specified id and contents. +writeHtmlHeader1WithId :: String -> HtmlWriter () -> HtmlWriter () +writeHtmlHeader1WithId id inner =+ do writeHtml "<h1 id=\""+ writeHtml id+ writeHtml "\">"+ inner+ writeHtml "</h1>"+ +-- | Write the @\<h2\>@ element with the specified id and contents. +writeHtmlHeader2WithId :: String -> HtmlWriter () -> HtmlWriter () +writeHtmlHeader2WithId id inner =+ do writeHtml "<h2 id=\""+ writeHtml id+ writeHtml "\">"+ inner+ writeHtml "</h2>"+ +-- | Write the @\<h3\>@ element with the specified id and contents. +writeHtmlHeader3WithId :: String -> HtmlWriter () -> HtmlWriter () +writeHtmlHeader3WithId id inner =+ do writeHtml "<h3 id=\""+ writeHtml id+ writeHtml "\">"+ inner+ writeHtml "</h3>"+ +-- | Write the @\<h4\>@ element with the specified id and contents. +writeHtmlHeader4WithId :: String -> HtmlWriter () -> HtmlWriter () +writeHtmlHeader4WithId id inner =+ do writeHtml "<h4 id=\""+ writeHtml id+ writeHtml "\">"+ inner+ writeHtml "</h4>"+ +-- | Write the @\<h5\>@ element with the specified id and contents. +writeHtmlHeader5WithId :: String -> HtmlWriter () -> HtmlWriter () +writeHtmlHeader5WithId id inner =+ do writeHtml "<h5 id=\""+ writeHtml id+ writeHtml "\">"+ inner+ writeHtml "</h5>"+ +-- | Write the @\<h6\>@ element with the specified id and contents. +writeHtmlHeader6WithId :: String -> HtmlWriter () -> HtmlWriter () +writeHtmlHeader6WithId id inner =+ do writeHtml "<h6 id=\""+ writeHtml id+ writeHtml "\">"+ inner+ writeHtml "</h6>"+ +-- | Write the @\<br\>@ element.+writeHtmlBreak :: HtmlWriter () +writeHtmlBreak =+ writeHtml "<br />"+ +-- | Write the list of items wrapped in @\<ul\>@. +writeHtmlList :: HtmlWriter () -> HtmlWriter ()+writeHtmlList inner =+ do writeHtml "<ul>"+ inner+ writeHtml "</ul>"++-- | Write the item list wrapped in @\<li\>@. +writeHtmlListItem :: HtmlWriter () -> HtmlWriter ()+writeHtmlListItem inner =+ do writeHtml "<li>"+ inner+ writeHtml "</li>"++-- | Write the HTML document with the specified title and contents+writeHtmlDocumentWithTitle :: String -> HtmlWriter () -> HtmlWriter ()+writeHtmlDocumentWithTitle title inner =+ do writeHtml "<html>"+ writeHtml "<head>"+ writeHtml "<title>"+ writeHtmlText title+ writeHtml "</title>"+ writeHtmlCss + writeHtml "</head>"+ writeHtml "<body>"+ writeHtmlHeader1 $ + writeHtmlText title+ writeHtml "</h1>"+ inner+ writeHtml "<br /><p><font size=\"-1\">Automatically generated by "+ writeHtml "<a href=\"https://github.com/dsorokin/aivika-experiment\">"+ writeHtml "Aivika Experiment</a>"+ writeHtml "</font></p>"+ writeHtml "</body>"+ writeHtml "</html>"++-- | Escape special HTML characters in the 'String'.+-- It is based on one function from package Web-Encodings,+-- which is licensed under BSD3 but obsolete now.+encodeHtmlText :: String -> String+encodeHtmlText x = join $ map encodeHtmlChar x++-- | Escape a character.+encodeHtmlChar :: Char -> String+encodeHtmlChar '<' = "<"+encodeHtmlChar '>' = ">"+encodeHtmlChar '&' = "&"+encodeHtmlChar '"' = """+encodeHtmlChar '\'' = "'"+encodeHtmlChar c = [c]++-- | Write the CSS styles+writeHtmlCss :: HtmlWriter ()+writeHtmlCss =+ do writeHtmlLn "<style type=\"text/css\">"+ writeHtmlLn "* { margin: 0; padding: 0 }"+ writeHtmlLn ""+ writeHtmlLn "html {"+ writeHtmlLn " background-color: white;"+ writeHtmlLn " width: 100%;"+ writeHtmlLn " height: 100%;"+ writeHtmlLn "}"+ writeHtmlLn ""+ writeHtmlLn "body {"+ writeHtmlLn " background: white;"+ writeHtmlLn " color: black;"+ writeHtmlLn " text-align: left;"+ writeHtmlLn " min-height: 100%;"+ writeHtmlLn " position: relative;"+ writeHtmlLn "}"+ writeHtmlLn ""+ writeHtmlLn "p {"+ writeHtmlLn " margin: 0.8em 0;"+ writeHtmlLn "}"+ writeHtmlLn ""+ writeHtmlLn "ul, ol {"+ writeHtmlLn " margin: 0.8em 0 0.8em 2em;"+ writeHtmlLn "}"+ writeHtmlLn ""+ writeHtmlLn "dl {"+ writeHtmlLn " margin: 0.8em 0;"+ writeHtmlLn "}"+ writeHtmlLn ""+ writeHtmlLn "dt {"+ writeHtmlLn " font-weight: bold;"+ writeHtmlLn "}"+ writeHtmlLn ""+ writeHtmlLn "dd {"+ writeHtmlLn " margin-left: 2em;"+ writeHtmlLn "}"+ writeHtmlLn ""+ writeHtmlLn "a { text-decoration: none; }"+ writeHtmlLn "a[href]:link { color: rgb(196,69,29); }"+ writeHtmlLn "a[href]:visited { color: rgb(171,105,84); }"+ writeHtmlLn "a[href]:hover { text-decoration:underline; }"+ writeHtmlLn ""+ writeHtmlLn "body {"+ writeHtmlLn " font:13px/1.4 sans-serif;"+ writeHtmlLn " *font-size:small; /* for IE */"+ writeHtmlLn " *font:x-small; /* for IE in quirks mode */"+ writeHtmlLn "}"+ writeHtmlLn ""+ writeHtmlLn "h1 { font-size: 146.5%; /* 19pt */ } "+ writeHtmlLn "h2 { font-size: 131%; /* 17pt */ }"+ writeHtmlLn "h3 { font-size: 116%; /* 15pt */ }"+ writeHtmlLn "h4 { font-size: 100%; /* 13pt */ }"+ writeHtmlLn "h5 { font-size: 100%; /* 13pt */ }"+ writeHtmlLn ""+ writeHtmlLn "select, input, button, textarea {"+ writeHtmlLn " font:99% sans-serif;"+ writeHtmlLn "}"+ writeHtmlLn ""+ writeHtmlLn "table {"+ writeHtmlLn " font-size:inherit;"+ writeHtmlLn " font:100%;"+ writeHtmlLn "}"+ writeHtmlLn ""+ writeHtmlLn "pre, code, kbd, samp, tt, .src {"+ writeHtmlLn " font-family:monospace;"+ writeHtmlLn " *font-size:108%;"+ writeHtmlLn " line-height: 124%;"+ writeHtmlLn "}"+ writeHtmlLn ""+ writeHtmlLn ".links, .link {"+ writeHtmlLn " font-size: 85%; /* 11pt */"+ writeHtmlLn "}"+ writeHtmlLn ".info {"+ writeHtmlLn " font-size: 85%; /* 11pt */"+ writeHtmlLn "}"+ writeHtmlLn ""+ writeHtmlLn ".caption, h1, h2, h3, h4, h5, h6 { "+ writeHtmlLn " font-weight: bold;"+ writeHtmlLn " color: rgb(78,98,114);"+ writeHtmlLn " margin: 0.8em 0 0.4em;"+ writeHtmlLn "}"+ writeHtmlLn ""+ writeHtmlLn "* + h1, * + h2, * + h3, * + h4, * + h5, * + h6 {"+ writeHtmlLn " margin-top: 2em;"+ writeHtmlLn "}"+ writeHtmlLn ""+ writeHtmlLn "h1 + h2, h2 + h3, h3 + h4, h4 + h5, h5 + h6 {"+ writeHtmlLn " margin-top: inherit;"+ writeHtmlLn "}"+ writeHtmlLn ""+ writeHtmlLn "ul.links {"+ writeHtmlLn " list-style: none;"+ writeHtmlLn " text-align: left;"+ writeHtmlLn " float: right;"+ writeHtmlLn " display: inline-table;"+ writeHtmlLn " margin: 0 0 0 1em;"+ writeHtmlLn "}"+ writeHtmlLn ""+ writeHtmlLn "ul.links li {"+ writeHtmlLn " display: inline;"+ writeHtmlLn " border-left: 1px solid #d5d5d5; "+ writeHtmlLn " white-space: nowrap;"+ writeHtmlLn " padding: 0;"+ writeHtmlLn "}"+ writeHtmlLn ""+ writeHtmlLn "ul.links li a {"+ writeHtmlLn " padding: 0.2em 0.5em;"+ writeHtmlLn "}"+ writeHtmlLn "</style>"
Simulation/Aivika/Experiment/LastValueView.hs view
@@ -1,178 +1,178 @@- --- | --- Module : Simulation.Aivika.Experiment.LastValueView --- Copyright : Copyright (c) 2012, David Sorokin <david.sorokin@gmail.com> --- License : BSD3 --- Maintainer : David Sorokin <david.sorokin@gmail.com> --- Stability : experimental --- Tested with: GHC 7.4.1 --- --- The module defines 'LastValueView' that shows the last values --- for the simulation variables. --- - -module Simulation.Aivika.Experiment.LastValueView - (LastValueView(..), - defaultLastValueView) 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.Dynamics -import Simulation.Aivika.Dynamics.Simulation -import Simulation.Aivika.Dynamics.Signal -import Simulation.Aivika.Dynamics.EventQueue -import Simulation.Aivika.Dynamics.Base - --- | Defines the 'View' that shows the last values of the simulation --- variables. -data LastValueView = - LastValueView { lastValueTitle :: String, - -- ^ The title for the view. - lastValueRunTitle :: String, - -- ^ The run title for the view. It may include - -- special variables @$RUN_INDEX@, @$RUN_COUNT@ and - -- @$TITLE@. - -- - -- An example is - -- - -- @ - -- lastValueRunTitle = \"$TITLE / Run $RUN_INDEX of $RUN_COUNT\" - -- @ - lastValueDescription :: String, - -- ^ The description for the view. - lastValueFormatter :: ShowS, - -- ^ It transforms data before they will be shown. - lastValueSeries :: [String] - -- ^ It contains the labels of the observed series. - } - --- | This is the default view. -defaultLastValueView :: LastValueView -defaultLastValueView = - LastValueView { lastValueTitle = "The Last Values", - lastValueRunTitle = "$TITLE / Run $RUN_INDEX of $RUN_COUNT", - lastValueDescription = [], - lastValueFormatter = id, - lastValueSeries = [] } - -instance View 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 } - --- | The state of the view. -data LastValueViewState = - LastValueViewState { lastValueView :: LastValueView, - lastValueExperiment :: Experiment, - lastValueMap :: M.Map Int (IORef [(String, String)]) } - --- | Create a new state of the view. -newLastValues :: LastValueView -> Experiment -> IO LastValueViewState -newLastValues view exp = - do let n = experimentRunCount exp - rs <- forM [0..(n - 1)] $ \i -> newIORef [] - let m = M.fromList $ zip [0..(n - 1)] rs - return LastValueViewState { lastValueView = view, - lastValueExperiment = exp, - lastValueMap = m } - --- | Get the last values during the simulation. -simulateLastValues :: LastValueViewState -> ExperimentData -> Dynamics (Dynamics ()) -simulateLastValues st expdata = - do let labels = lastValueSeries $ lastValueView st - input = - flip map (experimentSeriesProviders expdata labels) $ \provider -> - case providerToString provider of - Nothing -> error $ - "Cannot represent series " ++ - providerName provider ++ - " as a string: simulateLastValues" - Just input -> (providerName provider, input) - i <- liftSimulation simulationIndex - t <- time - enqueue (experimentQueue expdata) t $ - -- we must subscribe through the event queue; - -- otherwise, we will loose a signal in the start time, - -- because the handleSignal_ function checks the event queue - handleSignal_ (experimentSignalInStopTime expdata) $ \t -> - do let r = fromJust $ M.lookup (i - 1) (lastValueMap st) - output <- forM input $ \(name, input) -> - do x <- input - return (name, x) - liftIO $ writeIORef r output - return $ return () - --- | Get the HTML code. -lastValueHtml :: LastValueViewState -> Int -> HtmlWriter () -lastValueHtml st index = - let n = experimentRunCount $ lastValueExperiment st - in if n == 1 - then lastValueHtmlSingle st index - else lastValueHtmlMultiple st index - --- | Get the HTML code for a single run. -lastValueHtmlSingle :: LastValueViewState -> Int -> HtmlWriter () -lastValueHtmlSingle st index = - do header st index - let r = fromJust $ M.lookup 0 (lastValueMap st) - pairs <- liftIO $ readIORef r - forM_ pairs $ \pair -> - formatPair pair (lastValueFormatter $ lastValueView st) - --- | Get the HTML code for multiple runs -lastValueHtmlMultiple :: LastValueViewState -> Int -> HtmlWriter () -lastValueHtmlMultiple st index = - do header st index - let n = experimentRunCount $ lastValueExperiment st - forM_ [0..(n - 1)] $ \i -> - do let subtitle = - replace "$RUN_INDEX" (show $ i + 1) $ - replace "$RUN_COUNT" (show n) $ - replace "$TITLE" (lastValueTitle $ lastValueView st) - (lastValueRunTitle $ lastValueView st) - writeHtmlHeader4 $ - writeHtmlText subtitle - let r = fromJust $ M.lookup i (lastValueMap st) - pairs <- liftIO $ readIORef r - forM_ pairs $ \pair -> - formatPair pair (lastValueFormatter $ lastValueView st) - -header :: LastValueViewState -> Int -> HtmlWriter () -header st index = - do writeHtmlHeader3WithId ("id" ++ show index) $ - writeHtmlText (lastValueTitle $ lastValueView st) - let description = lastValueDescription $ lastValueView st - unless (null description) $ - writeHtmlParagraph $ - writeHtmlText description - -formatPair :: (String, String) -> ShowS -> HtmlWriter () -formatPair (name, value) formatter = - writeHtmlParagraph $ - do writeHtmlText name - writeHtmlText " = " - writeHtmlText $ formatter value - --- | Get the TOC item -lastValueTOCHtml :: LastValueViewState -> Int -> HtmlWriter () -lastValueTOCHtml st index = - writeHtmlListItem $ - writeHtmlLink ("#id" ++ show index) $ - writeHtmlText (lastValueTitle $ lastValueView st) ++-- |+-- Module : Simulation.Aivika.Experiment.LastValueView+-- Copyright : Copyright (c) 2012, David Sorokin <david.sorokin@gmail.com>+-- License : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability : experimental+-- Tested with: GHC 7.4.1+--+-- The module defines 'LastValueView' that shows the last values+-- for the simulation variables.+--++module Simulation.Aivika.Experiment.LastValueView + (LastValueView(..),+ defaultLastValueView) 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.Dynamics+import Simulation.Aivika.Dynamics.Simulation+import Simulation.Aivika.Dynamics.Signal+import Simulation.Aivika.Dynamics.EventQueue+import Simulation.Aivika.Dynamics.Base++-- | Defines the 'View' that shows the last values of the simulation+-- variables.+data LastValueView =+ LastValueView { lastValueTitle :: String,+ -- ^ The title for the view.+ lastValueRunTitle :: String,+ -- ^ The run title for the view. It may include+ -- special variables @$RUN_INDEX@, @$RUN_COUNT@ and + -- @$TITLE@.+ --+ -- An example is + --+ -- @+ -- lastValueRunTitle = \"$TITLE / Run $RUN_INDEX of $RUN_COUNT\"+ -- @+ lastValueDescription :: String,+ -- ^ The description for the view.+ lastValueFormatter :: ShowS,+ -- ^ It transforms data before they will be shown.+ lastValueSeries :: [String] + -- ^ It contains the labels of the observed series.+ }+ +-- | This is the default view.+defaultLastValueView :: LastValueView+defaultLastValueView = + LastValueView { lastValueTitle = "The Last Values",+ lastValueRunTitle = "$TITLE / Run $RUN_INDEX of $RUN_COUNT",+ lastValueDescription = [],+ lastValueFormatter = id,+ lastValueSeries = [] }+ +instance View 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 }+ +-- | The state of the view.+data LastValueViewState =+ LastValueViewState { lastValueView :: LastValueView,+ lastValueExperiment :: Experiment,+ lastValueMap :: M.Map Int (IORef [(String, String)]) }+ +-- | Create a new state of the view.+newLastValues :: LastValueView -> Experiment -> IO LastValueViewState+newLastValues view exp =+ do let n = experimentRunCount exp+ rs <- forM [0..(n - 1)] $ \i -> newIORef [] + let m = M.fromList $ zip [0..(n - 1)] rs+ return LastValueViewState { lastValueView = view,+ lastValueExperiment = exp,+ lastValueMap = m }+ +-- | Get the last values during the simulation.+simulateLastValues :: LastValueViewState -> ExperimentData -> Dynamics (Dynamics ())+simulateLastValues st expdata =+ do let labels = lastValueSeries $ lastValueView st+ input =+ flip map (experimentSeriesProviders expdata labels) $ \provider ->+ case providerToString provider of+ Nothing -> error $+ "Cannot represent series " +++ providerName provider ++ + " as a string: simulateLastValues"+ Just input -> (providerName provider, input)+ i <- liftSimulation simulationIndex+ t <- time+ enqueue (experimentQueue expdata) t $+ -- we must subscribe through the event queue;+ -- otherwise, we will loose a signal in the start time,+ -- because the handleSignal_ function checks the event queue+ handleSignal_ (experimentSignalInStopTime expdata) $ \t ->+ do let r = fromJust $ M.lookup (i - 1) (lastValueMap st)+ output <- forM input $ \(name, input) ->+ do x <- input+ return (name, x)+ liftIO $ writeIORef r output+ return $ return ()+ +-- | Get the HTML code. +lastValueHtml :: LastValueViewState -> Int -> HtmlWriter () +lastValueHtml st index =+ let n = experimentRunCount $ lastValueExperiment st+ in if n == 1+ then lastValueHtmlSingle st index+ else lastValueHtmlMultiple st index+ +-- | Get the HTML code for a single run.+lastValueHtmlSingle :: LastValueViewState -> Int -> HtmlWriter ()+lastValueHtmlSingle st index =+ do header st index+ let r = fromJust $ M.lookup 0 (lastValueMap st)+ pairs <- liftIO $ readIORef r+ forM_ pairs $ \pair ->+ formatPair pair (lastValueFormatter $ lastValueView st)++-- | Get the HTML code for multiple runs+lastValueHtmlMultiple :: LastValueViewState -> Int -> HtmlWriter ()+lastValueHtmlMultiple st index =+ do header st index+ let n = experimentRunCount $ lastValueExperiment st+ forM_ [0..(n - 1)] $ \i ->+ do let subtitle = + replace "$RUN_INDEX" (show $ i + 1) $+ replace "$RUN_COUNT" (show n) $+ replace "$TITLE" (lastValueTitle $ lastValueView st)+ (lastValueRunTitle $ lastValueView st)+ writeHtmlHeader4 $+ writeHtmlText subtitle+ let r = fromJust $ M.lookup i (lastValueMap st)+ pairs <- liftIO $ readIORef r+ forM_ pairs $ \pair ->+ formatPair pair (lastValueFormatter $ lastValueView st)++header :: LastValueViewState -> Int -> HtmlWriter ()+header st index =+ do writeHtmlHeader3WithId ("id" ++ show index) $+ writeHtmlText (lastValueTitle $ lastValueView st)+ let description = lastValueDescription $ lastValueView st+ unless (null description) $+ writeHtmlParagraph $+ writeHtmlText description++formatPair :: (String, String) -> ShowS -> HtmlWriter ()+formatPair (name, value) formatter =+ writeHtmlParagraph $ + do writeHtmlText name+ writeHtmlText " = "+ writeHtmlText $ formatter value+ +-- | Get the TOC item +lastValueTOCHtml :: LastValueViewState -> Int -> HtmlWriter ()+lastValueTOCHtml st index =+ writeHtmlListItem $+ writeHtmlLink ("#id" ++ show index) $+ writeHtmlText (lastValueTitle $ lastValueView st)
Simulation/Aivika/Experiment/TableView.hs view
@@ -1,245 +1,246 @@- --- | --- Module : Simulation.Aivika.Experiment.TableView --- Copyright : Copyright (c) 2012, David Sorokin <david.sorokin@gmail.com> --- License : BSD3 --- Maintainer : David Sorokin <david.sorokin@gmail.com> --- Stability : experimental --- Tested with: GHC 7.4.1 --- --- The module defines 'TableView' that saves the simulation --- results in the CSV file(s). --- - -module Simulation.Aivika.Experiment.TableView - (TableView(..), - defaultTableView) where - -import Control.Monad -import Control.Monad.Trans - -import qualified Data.Map as M -import Data.IORef -import Data.Maybe - -import System.IO -import System.FilePath - -import Data.String.Utils (replace) - -import Simulation.Aivika.Experiment -import Simulation.Aivika.Experiment.HtmlWriter - -import Simulation.Aivika.Dynamics -import Simulation.Aivika.Dynamics.Simulation -import Simulation.Aivika.Dynamics.Signal -import Simulation.Aivika.Dynamics.EventQueue -import Simulation.Aivika.Dynamics.Base - --- | Defines the 'View' that saves the simulation results --- in the CSV file(s). -data TableView = - TableView { tableTitle :: String, - -- ^ This is a title used in HTML. - tableDescription :: String, - -- ^ This is a description in the HTML. - tableLinkText :: String, - -- ^ It specifies the text for the link - -- which is displayed in the HTML page - -- if there is only one simulation run. - -- The link downloads the corresponded - -- CSV file in the browser. If there are - -- more simulation runs, then this link - -- is not shown. - -- - -- An example is - -- - -- @ - -- tableLinkText = \"Download the CSV file\" - -- @ - tableRunLinkText :: String, - -- ^ It specifies the link text which is - -- displayed in the HTML page if there are - -- many simulation runs. Such a link downloads - -- the CSV file for the corresponded run. - -- To define the text, you can use special - -- variables @$LINK@, @$RUN_INDEX@ and @$RUN_COUNT@. - -- - -- An example is - -- - -- @ - -- tableRunLinkText = \"$LINK / Run $RUN_INDEX of $RUN_COUNT\" - -- @ - -- - -- If there is only one run, then the link of - -- this kind is not displayed. Instead, only one - -- link is shown, which text is defined by the - -- 'tableLinkText' field. - tableFileName :: FileName, - -- ^ It defines the file name for each CSV file. - -- It may include special variables @$TITLE@, - -- @$RUN_INDEX@ and @$RUN_COUNT@. - -- - -- An example is - -- - -- @ - -- tableFileName = UniqueFileName \"$TITLE - $RUN_INDEX\", \".csv\" - -- @ - tableSeparator :: String, - -- ^ It defines the separator for the view. - -- It delimits the cells in the rows of the CSV file. - tableFormatter :: ShowS, - -- ^ It defines the formatter which is applied - -- to all values before they will be written - -- in the CSV file(s). - tablePredicate :: Dynamics Bool, - -- ^ It specifies the predicate that defines - -- when we can save data in the table. - tableSeries :: [String] - -- ^ It contains the labels of data saved - -- in the CSV file(s). - } - --- | The default table view. -defaultTableView :: TableView -defaultTableView = - TableView { tableTitle = "Table", - tableDescription = [], - tableLinkText = "Download the CSV file", - tableRunLinkText = "$LINK / Run $RUN_INDEX of $RUN_COUNT", - tableFileName = UniqueFileName "$TITLE - $RUN_INDEX" ".csv", - tableSeparator = ",", - tableFormatter = id, - tablePredicate = return True, - tableSeries = [] } - -instance View 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 } - --- | The state of the view. -data TableViewState = - TableViewState { tableView :: TableView, - tableExperiment :: Experiment, - tableDir :: FilePath, - tableMap :: M.Map Int FilePath } - --- | Create a new state of the view. -newTable :: TableView -> Experiment -> FilePath -> IO TableViewState -newTable view exp dir = - do let n = experimentRunCount exp - fs <- forM [0..(n - 1)] $ \i -> - resolveFileName (Just dir) (tableFileName view) $ - M.fromList [("$TITLE", tableTitle view), - ("$RUN_INDEX", show $ i + 1), - ("$RUN_COUNT", show n)] - let m = M.fromList $ zip [0..(n - 1)] fs - return TableViewState { tableView = view, - tableExperiment = exp, - tableDir = dir, - tableMap = m } - --- | Write the tables during the simulation. -simulateTable :: TableViewState -> ExperimentData -> Dynamics (Dynamics ()) -simulateTable st expdata = - do let labels = tableSeries $ tableView st - providers = experimentSeriesProviders expdata labels - input = - flip map providers $ \provider -> - case providerToString provider of - Nothing -> error $ - "Cannot represent series " ++ - providerName provider ++ - " as a string: simulateTable" - Just input -> input - separator = tableSeparator $ tableView st - formatter = tableFormatter $ tableView st - predicate = tablePredicate $ tableView st - i <- liftSimulation simulationIndex - -- create a new file - let f = fromJust $ M.lookup (i - 1) (tableMap st) - h <- liftIO $ openFile f WriteMode - -- write a header - liftIO $ - do forM_ (zip [0..] providers) $ \(column, provider) -> - do when (column > 0) $ - hPutStr h separator - hPutStr h $ providerName provider - hPutStrLn h "" - t <- time - enqueue (experimentQueue expdata) t $ - -- we must subscribe through the event queue; - -- otherwise, we will loose a signal in the start time, - -- because the handleSignal_ function checks the event queue - handleSignal_ (experimentMixedSignal expdata providers) $ \t -> - do p <- predicate - when p $ - do forM_ (zip [0..] input) $ \(column, input) -> -- write the row - do x <- input -- write the column - liftIO $ - do when (column > 0) $ - hPutStr h separator - hPutStr h $ formatter x - liftIO $ hPutStrLn h "" - return $ - liftIO $ - do when (experimentVerbose $ tableExperiment st) $ - putStr "Generated file " >> putStrLn f - hClose h -- close the file - --- | Get the HTML code. -tableHtml :: TableViewState -> Int -> HtmlWriter () -tableHtml st index = - let n = experimentRunCount $ tableExperiment st - in if n == 1 - then tableHtmlSingle st index - else tableHtmlMultiple st index - --- | Get the HTML code for a single run. -tableHtmlSingle :: TableViewState -> Int -> HtmlWriter () -tableHtmlSingle st index = - do header st index - let f = fromJust $ M.lookup 0 (tableMap st) - writeHtmlParagraph $ - writeHtmlLink (makeRelative (tableDir st) f) $ - writeHtmlText (tableLinkText $ tableView st) - --- | Get the HTML code for multiple runs -tableHtmlMultiple :: TableViewState -> Int -> HtmlWriter () -tableHtmlMultiple st index = - do header st index - let n = experimentRunCount $ tableExperiment st - forM_ [0..(n - 1)] $ \i -> - do let f = fromJust $ M.lookup i (tableMap st) - sublink = - replace "$RUN_INDEX" (show $ i + 1) $ - replace "$RUN_COUNT" (show n) $ - replace "$LINK" (tableLinkText $ tableView st) - (tableRunLinkText $ tableView st) - writeHtmlParagraph $ - writeHtmlLink (makeRelative (tableDir st) f) $ - writeHtmlText sublink - -header :: TableViewState -> Int -> HtmlWriter () -header st index = - do writeHtmlHeader3WithId ("id" ++ show index) $ - writeHtmlText (tableTitle $ tableView st) - let description = tableDescription $ tableView st - unless (null description) $ - writeHtmlParagraph $ - writeHtmlText description - --- | Get the TOC item -tableTOCHtml :: TableViewState -> Int -> HtmlWriter () -tableTOCHtml st index = - writeHtmlListItem $ - writeHtmlLink ("#id" ++ show index) $ - writeHtmlText (tableTitle $ tableView st) ++-- |+-- Module : Simulation.Aivika.Experiment.TableView+-- Copyright : Copyright (c) 2012, David Sorokin <david.sorokin@gmail.com>+-- License : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability : experimental+-- Tested with: GHC 7.4.1+--+-- The module defines 'TableView' that saves the simulation+-- results in the CSV file(s).+--++module Simulation.Aivika.Experiment.TableView + (TableView(..), + defaultTableView) where++import Control.Monad+import Control.Monad.Trans++import qualified Data.Map as M+import Data.IORef+import Data.Maybe++import System.IO+import System.FilePath++import Data.String.Utils (replace)++import Simulation.Aivika.Experiment+import Simulation.Aivika.Experiment.HtmlWriter++import Simulation.Aivika.Dynamics+import Simulation.Aivika.Dynamics.Simulation+import Simulation.Aivika.Dynamics.Signal+import Simulation.Aivika.Dynamics.EventQueue+import Simulation.Aivika.Dynamics.Base++-- | Defines the 'View' that saves the simulation results+-- in the CSV file(s).+data TableView =+ TableView { tableTitle :: String,+ -- ^ This is a title used in HTML.+ tableDescription :: String,+ -- ^ This is a description in the HTML.+ tableLinkText :: String,+ -- ^ It specifies the text for the link + -- which is displayed in the HTML page+ -- if there is only one simulation run. + -- The link downloads the corresponded + -- CSV file in the browser. If there are+ -- more simulation runs, then this link + -- is not shown.+ --+ -- An example is+ --+ -- @+ -- tableLinkText = \"Download the CSV file\"+ -- @+ tableRunLinkText :: String,+ -- ^ It specifies the link text which is + -- displayed in the HTML page if there are + -- many simulation runs. Such a link downloads + -- the CSV file for the corresponded run. + -- To define the text, you can use special + -- variables @$LINK@, @$RUN_INDEX@ and @$RUN_COUNT@.+ --+ -- An example is + -- + -- @+ -- tableRunLinkText = \"$LINK / Run $RUN_INDEX of $RUN_COUNT\"+ -- @+ -- + -- If there is only one run, then the link of + -- this kind is not displayed. Instead, only one + -- link is shown, which text is defined by the + -- 'tableLinkText' field.+ tableFileName :: FileName,+ -- ^ It defines the file name for each CSV file. + -- It may include special variables @$TITLE@, + -- @$RUN_INDEX@ and @$RUN_COUNT@.+ --+ -- An example is+ --+ -- @+ -- tableFileName = UniqueFileName \"$TITLE - $RUN_INDEX\", \".csv\"+ -- @+ tableSeparator :: String,+ -- ^ It defines the separator for the view. + -- It delimits the cells in the rows of the CSV file.+ tableFormatter :: ShowS,+ -- ^ It defines the formatter which is applied+ -- to all values before they will be written+ -- in the CSV file(s).+ tablePredicate :: Dynamics Bool,+ -- ^ It specifies the predicate that defines+ -- when we can save data in the table.+ tableSeries :: [String] + -- ^ It contains the labels of data saved+ -- in the CSV file(s).+ }+ +-- | The default table view. +defaultTableView :: TableView+defaultTableView = + TableView { tableTitle = "Table",+ tableDescription = [],+ tableLinkText = "Download the CSV file",+ tableRunLinkText = "$LINK / Run $RUN_INDEX of $RUN_COUNT",+ tableFileName = UniqueFileName "$TITLE - $RUN_INDEX" ".csv",+ tableSeparator = ",",+ tableFormatter = id,+ tablePredicate = return True,+ tableSeries = [] }+ +instance View 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 }+ +-- | The state of the view.+data TableViewState =+ TableViewState { tableView :: TableView,+ tableExperiment :: Experiment,+ tableDir :: FilePath, + tableMap :: M.Map Int FilePath }+ +-- | Create a new state of the view.+newTable :: TableView -> Experiment -> FilePath -> IO TableViewState+newTable view exp dir =+ do let n = experimentRunCount exp+ fs <- forM [0..(n - 1)] $ \i -> + resolveFileName (Just dir) (tableFileName view) $+ M.fromList [("$TITLE", tableTitle view),+ ("$RUN_INDEX", show $ i + 1),+ ("$RUN_COUNT", show n)]+ forM_ fs $ flip writeFile [] -- reserve the file names+ let m = M.fromList $ zip [0..(n - 1)] fs+ return TableViewState { tableView = view,+ tableExperiment = exp,+ tableDir = dir, + tableMap = m }+ +-- | Write the tables during the simulation.+simulateTable :: TableViewState -> ExperimentData -> Dynamics (Dynamics ())+simulateTable st expdata =+ do let labels = tableSeries $ tableView st+ providers = experimentSeriesProviders expdata labels+ input =+ flip map providers $ \provider ->+ case providerToString provider of+ Nothing -> error $+ "Cannot represent series " +++ providerName provider ++ + " as a string: simulateTable"+ Just input -> input+ separator = tableSeparator $ tableView st+ formatter = tableFormatter $ tableView st+ predicate = tablePredicate $ tableView st+ i <- liftSimulation simulationIndex+ -- create a new file+ let f = fromJust $ M.lookup (i - 1) (tableMap st)+ h <- liftIO $ openFile f WriteMode+ -- write a header+ liftIO $+ do forM_ (zip [0..] providers) $ \(column, provider) ->+ do when (column > 0) $ + hPutStr h separator+ hPutStr h $ providerName provider+ hPutStrLn h ""+ t <- time+ enqueue (experimentQueue expdata) t $+ -- we must subscribe through the event queue;+ -- otherwise, we will loose a signal in the start time,+ -- because the handleSignal_ function checks the event queue+ handleSignal_ (experimentMixedSignal expdata providers) $ \t ->+ do p <- predicate+ when p $+ do forM_ (zip [0..] input) $ \(column, input) -> -- write the row+ do x <- input -- write the column+ liftIO $+ do when (column > 0) $ + hPutStr h separator+ hPutStr h $ formatter x+ liftIO $ hPutStrLn h ""+ return $ + liftIO $+ do when (experimentVerbose $ tableExperiment st) $+ putStr "Generated file " >> putStrLn f+ hClose h -- close the file+ +-- | Get the HTML code. +tableHtml :: TableViewState -> Int -> HtmlWriter () +tableHtml st index =+ let n = experimentRunCount $ tableExperiment st+ in if n == 1+ then tableHtmlSingle st index+ else tableHtmlMultiple st index+ +-- | Get the HTML code for a single run.+tableHtmlSingle :: TableViewState -> Int -> HtmlWriter ()+tableHtmlSingle st index =+ do header st index+ let f = fromJust $ M.lookup 0 (tableMap st)+ writeHtmlParagraph $+ writeHtmlLink (makeRelative (tableDir st) f) $+ writeHtmlText (tableLinkText $ tableView st)++-- | Get the HTML code for multiple runs+tableHtmlMultiple :: TableViewState -> Int -> HtmlWriter ()+tableHtmlMultiple st index =+ do header st index+ let n = experimentRunCount $ tableExperiment st+ forM_ [0..(n - 1)] $ \i ->+ do let f = fromJust $ M.lookup i (tableMap st)+ sublink = + replace "$RUN_INDEX" (show $ i + 1) $+ replace "$RUN_COUNT" (show n) $+ replace "$LINK" (tableLinkText $ tableView st)+ (tableRunLinkText $ tableView st)+ writeHtmlParagraph $+ writeHtmlLink (makeRelative (tableDir st) f) $+ writeHtmlText sublink++header :: TableViewState -> Int -> HtmlWriter ()+header st index =+ do writeHtmlHeader3WithId ("id" ++ show index) $ + writeHtmlText (tableTitle $ tableView st)+ let description = tableDescription $ tableView st+ unless (null description) $+ writeHtmlParagraph $ + writeHtmlText description++-- | Get the TOC item +tableTOCHtml :: TableViewState -> Int -> HtmlWriter ()+tableTOCHtml st index =+ writeHtmlListItem $+ writeHtmlLink ("#id" ++ show index) $+ writeHtmlText (tableTitle $ tableView st)
Simulation/Aivika/Experiment/Utils.hs view
@@ -1,23 +1,23 @@- --- | --- Module : Simulation.Aivika.Experiment.Utils --- Copyright : Copyright (c) 2012, David Sorokin <david.sorokin@gmail.com> --- License : BSD3 --- Maintainer : David Sorokin <david.sorokin@gmail.com> --- Stability : experimental --- Tested with: GHC 7.4.1 --- --- It defines utility functions missed in the standard library. --- - -module Simulation.Aivika.Experiment.Utils - (divideBy) where - --- | Divide into the groups removing those elements --- that satisfy the predicate. -divideBy :: (a -> Bool) -> [a] -> [[a]] -divideBy p xs = - case dropWhile p xs of - [] -> [] - xs' -> ys : divideBy p xs'' ++-- |+-- Module : Simulation.Aivika.Experiment.Utils+-- Copyright : Copyright (c) 2012, David Sorokin <david.sorokin@gmail.com>+-- License : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability : experimental+-- Tested with: GHC 7.4.1+--+-- It defines utility functions missed in the standard library.+--++module Simulation.Aivika.Experiment.Utils+ (divideBy) where++-- | Divide into the groups removing those elements+-- that satisfy the predicate.+divideBy :: (a -> Bool) -> [a] -> [[a]]+divideBy p xs =+ case dropWhile p xs of+ [] -> []+ xs' -> ys : divideBy p xs'' where (ys, xs'') = break p xs'
aivika-experiment.cabal view
@@ -1,45 +1,47 @@-name: aivika-experiment -version: 0.1.1 -synopsis: Simulation experiments for the Aivika library -description: - This package allows defining simulation experiments for the Aivika - package. Such experiments define in declarative manner what should be - simulated and in which view the simulation results should be - generated. It can be charts, tables and so on. - . - The library is extensible and you can add new views for the results. - . -category: Simulation -license: BSD3 -license-file: LICENSE -copyright: (c) 2012. David Sorokin <david.sorokin@gmail.com> -author: David Sorokin -maintainer: David Sorokin <david.sorokin@gmail.com> -homepage: http://github.com/dsorokin/aivika-experiment -cabal-version: >= 1.2.0 -build-type: Simple -tested-with: GHC == 7.4.1 - -extra-source-files: examples/MachRep3.hs - -library - - exposed-modules: Simulation.Aivika.Experiment - Simulation.Aivika.Experiment.HtmlWriter - Simulation.Aivika.Experiment.LastValueView - Simulation.Aivika.Experiment.TableView - Simulation.Aivika.Experiment.Utils - - build-depends: base >= 3 && < 6, - mtl >= 1.1.0.2, - array >= 0.3.0.0, - containers >= 0.4.0.0, - directory >= 1.1.0.2, - filepath >= 1.3.0.0, - MissingH >= 1.2.0.0, - network >= 2.3.0.13, - aivika >= 0.4.3 - - extensions: FlexibleInstances - - ghc-options: -O2 +name: aivika-experiment+version: 0.1.2+synopsis: Simulation experiments for the Aivika library+description:+ This package allows defining simulation experiments for the Aivika+ package. Such experiments define in declarative manner what should be+ simulated and in which view the simulation results should be + generated. It can be charts, tables and so on.+ .+ The library is extensible and you can add new views for the results.+ .+category: Simulation+license: BSD3+license-file: LICENSE+copyright: (c) 2012. David Sorokin <david.sorokin@gmail.com>+author: David Sorokin+maintainer: David Sorokin <david.sorokin@gmail.com>+homepage: http://github.com/dsorokin/aivika-experiment+cabal-version: >= 1.2.0+build-type: Simple+tested-with: GHC == 7.4.1++extra-source-files: examples/MachRep3.hs++library++ exposed-modules: Simulation.Aivika.Experiment+ Simulation.Aivika.Experiment.HtmlWriter+ Simulation.Aivika.Experiment.LastValueView+ Simulation.Aivika.Experiment.TableView+ Simulation.Aivika.Experiment.Histogram+ Simulation.Aivika.Experiment.Utils+ + build-depends: base >= 3 && < 6,+ mtl >= 1.1.0.2,+ array >= 0.3.0.0,+ containers >= 0.4.0.0,+ directory >= 1.1.0.2,+ filepath >= 1.3.0.0,+ MissingH >= 1.2.0.0,+ network >= 2.3.0.13,+ parallel-io >= 0.3.2.1,+ aivika >= 0.4.3++ extensions: FlexibleInstances+ + ghc-options: -O2
examples/MachRep3.hs view
@@ -1,127 +1,127 @@- --- It corresponds to model MachRep3 described in document --- Introduction to Discrete-Event Simulation and the SimPy Language --- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/DESimIntro.pdf]. --- SimPy is available on [http://simpy.sourceforge.net/]. --- --- The model description is as follows. --- --- Variation of models MachRep1, MachRep2. Two machines, but --- sometimes break down. Up time is exponentially distributed with mean --- 1.0, and repair time is exponentially distributed with mean 0.5. In --- this example, there is only one repairperson, and she is not summoned --- until both machines are down. We find the proportion of up time. It --- should come out to about 0.45. - -module MachRep3Model (model) where - -import System.Random -import Control.Monad -import Control.Monad.Trans - -import Simulation.Aivika.Dynamics -import Simulation.Aivika.Dynamics.Simulation -import Simulation.Aivika.Dynamics.Base -import Simulation.Aivika.Dynamics.EventQueue -import Simulation.Aivika.Dynamics.Ref -import Simulation.Aivika.Dynamics.Resource -import Simulation.Aivika.Dynamics.Process - -import Simulation.Aivika.Experiment -import Simulation.Aivika.Experiment.LastValueView -import Simulation.Aivika.Experiment.TableView - -specs = Specs { spcStartTime = 0.0, - spcStopTime = 1000.0, - spcDT = 1.0, - spcMethod = RungeKutta4 } - -description = - "Variation of models MachRep1, MachRep2. Two machines, but " ++ - "sometimes break down. Up time is exponentially distributed with mean " ++ - "1.0, and repair time is exponentially distributed with mean 0.5. In " ++ - "this example, there is only one repairperson, and she is not summoned " ++ - "until both machines are down. We find the proportion of up time. It " ++ - "should come out to about 0.45." - -experiment :: Experiment -experiment = - defaultExperiment { - experimentSpecs = specs, - experimentRunCount = 3, - experimentDescription = description, - experimentGenerators = - [outputView $ defaultLastValueView { - lastValueDescription = - "It shows the last value of " ++ - "the proportion of up time.", - lastValueSeries = ["x"] }, - outputView $ defaultTableView { - tableDescription = - "These are tables for " ++ - "the proportion of up time.", - tableSeries = ["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 queue <- newQueue - - -- number of machines currently up - nUp <- newRef queue 2 - - -- total up time for all machines - totalUpTime <- newRef queue 0.0 - - repairPerson <- newResource queue 1 - - pid1 <- newProcessID queue - pid2 <- newProcessID queue - - let machine :: ProcessID -> Process () - machine pid = - do startUpTime <- liftDynamics time - upTime <- liftIO $ exprnd upRate - holdProcess upTime - finishUpTime <- liftDynamics time - liftDynamics $ modifyRef totalUpTime - (+ (finishUpTime - startUpTime)) - - liftDynamics $ modifyRef nUp $ \a -> a - 1 - nUp' <- liftDynamics $ readRef nUp - if nUp' == 1 - then passivateProcess - else do n <- liftDynamics $ - resourceCount repairPerson - when (n == 1) $ - liftDynamics $ reactivateProcess pid - - requestResource repairPerson - repairTime <- liftIO $ exprnd repairRate - holdProcess repairTime - liftDynamics $ modifyRef nUp $ \a -> a + 1 - releaseResource repairPerson - - machine pid - - runDynamicsInStartTime $ - do t0 <- starttime - runProcess (machine pid2) pid1 t0 - runProcess (machine pid1) pid2 t0 - - let result = - do x <- readRef totalUpTime - y <- time - return $ x / (2 * y) - - experimentDataInStartTime queue $ - [("x", seriesEntity "The proportion of up time" result)] - ++-- It corresponds to model MachRep3 described in document +-- Introduction to Discrete-Event Simulation and the SimPy Language+-- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/DESimIntro.pdf]. +-- SimPy is available on [http://simpy.sourceforge.net/].+-- +-- The model description is as follows.+--+-- Variation of models MachRep1, MachRep2. Two machines, but+-- sometimes break down. Up time is exponentially distributed with mean+-- 1.0, and repair time is exponentially distributed with mean 0.5. In+-- this example, there is only one repairperson, and she is not summoned+-- until both machines are down. We find the proportion of up time. It+-- should come out to about 0.45.++module MachRep3Model (model) where++import System.Random+import Control.Monad+import Control.Monad.Trans++import Simulation.Aivika.Dynamics+import Simulation.Aivika.Dynamics.Simulation+import Simulation.Aivika.Dynamics.Base+import Simulation.Aivika.Dynamics.EventQueue+import Simulation.Aivika.Dynamics.Ref+import Simulation.Aivika.Dynamics.Resource+import Simulation.Aivika.Dynamics.Process++import Simulation.Aivika.Experiment+import Simulation.Aivika.Experiment.LastValueView+import Simulation.Aivika.Experiment.TableView++specs = Specs { spcStartTime = 0.0,+ spcStopTime = 1000.0,+ spcDT = 1.0,+ spcMethod = RungeKutta4 }++description =+ "Model MachRep3. Variation of models MachRep1, MachRep2. Two machines, but " +++ "sometimes break down. Up time is exponentially distributed with mean " +++ "1.0, and repair time is exponentially distributed with mean 0.5. In " +++ "this example, there is only one repairperson, and she is not summoned " +++ "until both machines are down. We find the proportion of up time. It " +++ "should come out to about 0.45."++experiment :: Experiment+experiment =+ defaultExperiment {+ experimentSpecs = specs,+ experimentRunCount = 3,+ experimentDescription = description,+ experimentGenerators =+ [outputView $ defaultLastValueView {+ lastValueDescription = + "It shows the last value of " +++ "the proportion of up time.",+ lastValueSeries = ["x"] },+ outputView $ defaultTableView {+ tableDescription = + "These are tables for " +++ "the proportion of up time.",+ tableSeries = ["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 queue <- newQueue+ + -- number of machines currently up+ nUp <- newRef queue 2+ + -- total up time for all machines+ totalUpTime <- newRef queue 0.0+ + repairPerson <- newResource queue 1+ + pid1 <- newProcessID queue+ pid2 <- newProcessID queue+ + let machine :: ProcessID -> Process ()+ machine pid =+ do startUpTime <- liftDynamics time+ upTime <- liftIO $ exprnd upRate+ holdProcess upTime+ finishUpTime <- liftDynamics time+ liftDynamics $ modifyRef totalUpTime + (+ (finishUpTime - startUpTime))+ + liftDynamics $ modifyRef nUp $ \a -> a - 1+ nUp' <- liftDynamics $ readRef nUp+ if nUp' == 1+ then passivateProcess+ else do n <- liftDynamics $ + resourceCount repairPerson+ when (n == 1) $ + liftDynamics $ reactivateProcess pid+ + requestResource repairPerson+ repairTime <- liftIO $ exprnd repairRate+ holdProcess repairTime+ liftDynamics $ modifyRef nUp $ \a -> a + 1+ releaseResource repairPerson+ + machine pid++ runDynamicsInStartTime $+ do t0 <- starttime+ runProcess (machine pid2) pid1 t0+ runProcess (machine pid1) pid2 t0+ + let result = + do x <- readRef totalUpTime+ y <- time+ return $ x / (2 * y) + + experimentDataInStartTime queue+ [("x", seriesEntity "The proportion of up time" result)]+ main = runExperiment experiment model