aivika-experiment (empty) → 0.1
raw patch · 9 files changed
+1520/−0 lines, 9 filesdep +MissingHdep +aivikadep +arraysetup-changed
Dependencies added: MissingH, aivika, array, base, containers, directory, filepath, mtl, network
Files
- LICENSE +30/−0
- Setup.lhs +3/−0
- Simulation/Aivika/Experiment.hs +485/−0
- Simulation/Aivika/Experiment/HtmlWriter.hs +384/−0
- Simulation/Aivika/Experiment/LastValueView.hs +178/−0
- Simulation/Aivika/Experiment/TableView.hs +245/−0
- Simulation/Aivika/Experiment/Utils.hs +23/−0
- aivika-experiment.cabal +45/−0
- examples/MachRep3.hs +127/−0
+ LICENSE view
@@ -0,0 +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.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ Simulation/Aivika/Experiment.hs view
@@ -0,0 +1,485 @@++{-# 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 }
+ Simulation/Aivika/Experiment/HtmlWriter.hs view
@@ -0,0 +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>"
+ Simulation/Aivika/Experiment/LastValueView.hs view
@@ -0,0 +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)
+ Simulation/Aivika/Experiment/TableView.hs view
@@ -0,0 +1,245 @@++-- |+-- 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)
+ Simulation/Aivika/Experiment/Utils.hs view
@@ -0,0 +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''+ where (ys, xs'') = break p xs'
+ aivika-experiment.cabal view
@@ -0,0 +1,45 @@+name: aivika-experiment+version: 0.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.4.0.1,+ aivika >= 0.4.3++ extensions: FlexibleInstances+ + ghc-options: -O2
+ examples/MachRep3.hs view
@@ -0,0 +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)]++main = runExperiment experiment model