diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2012-2013 David Sorokin +Copyright (c) 2012, 2013, 2014 David Sorokin All rights reserved. diff --git a/Simulation/Aivika/Experiment/Chart.hs b/Simulation/Aivika/Experiment/Chart.hs --- a/Simulation/Aivika/Experiment/Chart.hs +++ b/Simulation/Aivika/Experiment/Chart.hs @@ -1,38 +1,29 @@ -- | -- Module : Simulation.Aivika.Experiment.Chart --- Copyright : Copyright (c) 2012, David Sorokin +-- Copyright : Copyright (c) 2012-2014, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental --- Tested with: GHC 7.4.1 +-- Tested with: GHC 7.6.3 -- --- The module defines some utilities used in the charting. +-- This module re-exports the library functionality. -- module Simulation.Aivika.Experiment.Chart - (colourisePlotLines, - colourisePlotFillBetween, - colourisePlotBars) where - -import Data.Colour -import Data.Colour.Names -import Data.Accessor - -import Graphics.Rendering.Chart - --- | Colourise the plot lines. -colourisePlotLines :: [PlotLines x y -> PlotLines x y] -colourisePlotLines = map mkstyle $ cycle defaultColorSeq - where mkstyle c = plot_lines_style .> line_color ^= c + (-- * Modules + module Simulation.Aivika.Experiment.Chart.TimeSeriesView, + module Simulation.Aivika.Experiment.Chart.XYChartView, + module Simulation.Aivika.Experiment.Chart.FinalXYChartView, + module Simulation.Aivika.Experiment.Chart.DeviationChartView, + module Simulation.Aivika.Experiment.Chart.HistogramView, + module Simulation.Aivika.Experiment.Chart.FinalHistogramView, + module Simulation.Aivika.Experiment.Chart.Utils) where --- | Colourise the filling areas. -colourisePlotFillBetween :: [PlotFillBetween x y -> PlotFillBetween x y] -colourisePlotFillBetween = map mkstyle $ cycle defaultColorSeq - where mkstyle c = plot_fillbetween_style ^= solidFillStyle (dissolve 0.4 c) - --- | Colourise the plot bars. -colourisePlotBars :: PlotBars x y -> PlotBars x y -colourisePlotBars = plot_bars_item_styles ^= map mkstyle (cycle defaultColorSeq) - where mkstyle c = (solidFillStyle c, Just $ solidLine 1.0 $ opaque black) - +import Simulation.Aivika.Experiment.Chart.TimeSeriesView +import Simulation.Aivika.Experiment.Chart.XYChartView +import Simulation.Aivika.Experiment.Chart.FinalXYChartView +import Simulation.Aivika.Experiment.Chart.DeviationChartView +import Simulation.Aivika.Experiment.Chart.HistogramView +import Simulation.Aivika.Experiment.Chart.FinalHistogramView +import Simulation.Aivika.Experiment.Chart.Utils diff --git a/Simulation/Aivika/Experiment/Chart/DeviationChartView.hs b/Simulation/Aivika/Experiment/Chart/DeviationChartView.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Experiment/Chart/DeviationChartView.hs @@ -0,0 +1,338 @@ + +-- | +-- Module : Simulation.Aivika.Experiment.Chart.DeviationChartView +-- Copyright : Copyright (c) 2012-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.6.3 +-- +-- The module defines 'DeviationChartView' that saves the deviation +-- chart in the PNG file. +-- + +module Simulation.Aivika.Experiment.Chart.DeviationChartView + (DeviationChartView(..), + defaultDeviationChartView) where + +import Control.Monad +import Control.Monad.Trans +import Control.Concurrent.MVar +import Control.Lens + +import qualified Data.Map as M +import Data.IORef +import Data.Maybe +import Data.Either +import Data.Array +import Data.Array.IO.Safe +import Data.Default.Class + +import System.IO +import System.FilePath + +import Graphics.Rendering.Chart +import Graphics.Rendering.Chart.Backend.Cairo + +import Simulation.Aivika.Experiment +import Simulation.Aivika.Experiment.HtmlWriter +import Simulation.Aivika.Experiment.Utils (divideBy, replace) +import Simulation.Aivika.Experiment.Chart.Utils (colourisePlotLines, colourisePlotFillBetween) +import Simulation.Aivika.Experiment.SamplingStatsSource + +import Simulation.Aivika.Specs +import Simulation.Aivika.Parameter +import Simulation.Aivika.Simulation +import Simulation.Aivika.Dynamics +import Simulation.Aivika.Event +import Simulation.Aivika.Signal +import Simulation.Aivika.Statistics + +-- | Defines the 'View' that saves the deviation chart +-- in the PNG file. +data DeviationChartView = + DeviationChartView { deviationChartTitle :: String, + -- ^ This is a title used in HTML. + deviationChartDescription :: String, + -- ^ This is a description used in HTML. + deviationChartWidth :: Int, + -- ^ The width of the chart. + deviationChartHeight :: Int, + -- ^ The height of the chart. + deviationChartFileName :: FileName, + -- ^ It defines the file name for the PNG file. + -- It may include special variable @$TITLE@. + -- + -- An example is + -- + -- @ + -- deviationChartFileName = UniqueFileName \"$TITLE\" \".png\" + -- @ + deviationChartSeries :: [Either String String], + -- ^ It contains the labels of data plotted + -- on the chart. + deviationChartPlotTitle :: String, + -- ^ This is a title used in the chart. + -- It may include special variable @$TITLE@. + -- + -- An example is + -- + -- @ + -- deviationChartPlotTitle = \"$TITLE\" + -- @ + deviationChartPlotLines :: [PlotLines Double Double -> + PlotLines Double Double], + -- ^ Probably, an infinite sequence of plot + -- transformations based on which the plot + -- is constructed for each series. Generally, + -- it may not coincide with a sequence of + -- labels as one label may denote a whole list + -- or an array of data providers. + -- + -- Here you can define a colour or style of + -- the plot lines. + deviationChartPlotFillBetween :: [PlotFillBetween Double Double -> + PlotFillBetween Double Double], + -- ^ Corresponds exactly to 'deviationChartPlotLines' + -- but used for plotting the deviation areas + -- by the rule of 3-sigma, while the former + -- is used for plotting the trends of the + -- random processes. + deviationChartBottomAxis :: LayoutAxis Double -> + LayoutAxis Double, + -- ^ A transformation of the bottom axis, + -- after title @time@ is added. + deviationChartLayout :: LayoutLR Double Double Double -> + LayoutLR Double Double Double + -- ^ A transformation of the plot layout, + -- where you can redefine the axes, for example. + } + +-- | The default deviation chart view. +defaultDeviationChartView :: DeviationChartView +defaultDeviationChartView = + DeviationChartView { deviationChartTitle = "Deviation Chart", + deviationChartDescription = "It shows the Deviation chart by rule 3-sigma.", + deviationChartWidth = 640, + deviationChartHeight = 480, + deviationChartFileName = UniqueFileName "$TITLE" ".png", + deviationChartSeries = [], + deviationChartPlotTitle = "$TITLE", + deviationChartPlotLines = colourisePlotLines, + deviationChartPlotFillBetween = colourisePlotFillBetween, + deviationChartBottomAxis = id, + deviationChartLayout = id } + +instance ExperimentView DeviationChartView where + + outputView v = + let reporter exp dir = + do st <- newDeviationChart v exp dir + return ExperimentReporter { reporterInitialise = return (), + reporterFinalise = finaliseDeviationChart st, + reporterSimulate = simulateDeviationChart st, + reporterTOCHtml = deviationChartTOCHtml st, + reporterHtml = deviationChartHtml st } + in ExperimentGenerator { generateReporter = reporter } + +-- | The state of the view. +data DeviationChartViewState = + DeviationChartViewState { deviationChartView :: DeviationChartView, + deviationChartExperiment :: Experiment, + deviationChartDir :: FilePath, + deviationChartFile :: IORef (Maybe FilePath), + deviationChartLock :: MVar (), + deviationChartResults :: IORef (Maybe DeviationChartResults) } + +-- | The deviation chart item. +data DeviationChartResults = + DeviationChartResults { deviationChartTimes :: IOArray Int Double, + deviationChartNames :: [Either String String], + deviationChartStats :: [IOArray Int (SamplingStats Double)] } + +-- | Create a new state of the view. +newDeviationChart :: DeviationChartView -> Experiment -> FilePath -> IO DeviationChartViewState +newDeviationChart view exp dir = + do f <- newIORef Nothing + l <- newMVar () + r <- newIORef Nothing + return DeviationChartViewState { deviationChartView = view, + deviationChartExperiment = exp, + deviationChartDir = dir, + deviationChartFile = f, + deviationChartLock = l, + deviationChartResults = r } + +-- | Create new chart results. +newDeviationChartResults :: [Either String String] -> Experiment -> IO DeviationChartResults +newDeviationChartResults names exp = + do let specs = experimentSpecs exp + bnds = integIterationBnds specs + times <- liftIO $ newListArray bnds (integTimes specs) + stats <- forM names $ \_ -> + liftIO $ newArray bnds emptySamplingStats + return DeviationChartResults { deviationChartTimes = times, + deviationChartNames = names, + deviationChartStats = stats } + +-- | Simulate the specified series. +simulateDeviationChart :: DeviationChartViewState -> ExperimentData -> Event (Event ()) +simulateDeviationChart st expdata = + do let labels = deviationChartSeries $ deviationChartView st + (leftLabels, rightLabels) = partitionEithers labels + (leftProviders, rightProviders) = + (experimentSeriesProviders expdata leftLabels, + experimentSeriesProviders expdata rightLabels) + providerInput providers = + flip map providers $ \provider -> + case providerToDoubleStatsSource provider of + Nothing -> error $ + "Cannot represent series " ++ + providerName provider ++ + " as a source of double values: simulateDeviationChart" + Just input -> (providerName provider, + provider, + samplingStatsSourceData input) + leftInput = providerInput leftProviders + rightInput = providerInput rightProviders + leftNames = flip map leftInput $ \(x, _, _) -> Left x + rightNames = flip map rightInput $ \(x, _, _) -> Right x + input = leftInput ++ rightInput + names = leftNames ++ rightNames + source = flip map input $ \(_, _, x) -> x + exp = deviationChartExperiment st + lock = deviationChartLock st + results <- liftIO $ readIORef (deviationChartResults st) + case results of + Nothing -> + liftIO $ + do results <- newDeviationChartResults names exp + writeIORef (deviationChartResults st) $ Just results + Just results -> + when (names /= deviationChartNames results) $ + error "Series with different names are returned for different runs: simulateDeviationChart" + results <- liftIO $ fmap fromJust $ readIORef (deviationChartResults st) + let stats = deviationChartStats results + h = experimentSignalInIntegTimes expdata + handleSignal_ h $ \_ -> + do xs <- sequence source + i <- liftDynamics integIteration + liftIO $ withMVar lock $ \() -> + forM_ (zip xs stats) $ \(x, stats) -> + do y <- readArray stats i + let y' = addDataToSamplingStats x y + y' `seq` writeArray stats i y' + return $ return () + +-- | Plot the deviation chart after the simulation is complete. +finaliseDeviationChart :: DeviationChartViewState -> IO () +finaliseDeviationChart st = + do let title = deviationChartTitle $ deviationChartView st + plotTitle = + replace "$TITLE" title + (deviationChartPlotTitle $ deviationChartView st) + width = deviationChartWidth $ deviationChartView st + height = deviationChartHeight $ deviationChartView st + plotLines = deviationChartPlotLines $ deviationChartView st + plotFillBetween = deviationChartPlotFillBetween $ deviationChartView st + plotBottomAxis = deviationChartBottomAxis $ deviationChartView st + plotLayout = deviationChartLayout $ deviationChartView st + results <- readIORef $ deviationChartResults st + case results of + Nothing -> return () + Just results -> + do let times = deviationChartTimes results + names = deviationChartNames results + stats = deviationChartStats results + ps1 <- forM (zip3 names stats plotLines) $ \(name, stats, plotLines) -> + do xs <- getAssocs stats + zs <- forM xs $ \(i, stats) -> + do t <- readArray times i + return (t, samplingStatsMean stats) + let p = toPlot $ + plotLines $ + plot_lines_values .~ filterPlotLinesValues zs $ + plot_lines_title .~ either id id name $ + def + case name of + Left _ -> return $ Left p + Right _ -> return $ Right p + ps2 <- forM (zip3 names stats plotFillBetween) $ \(name, stats, plotFillBetween) -> + do xs <- getAssocs stats + zs <- forM xs $ \(i, stats) -> + do t <- readArray times i + let mu = samplingStatsMean stats + sigma = samplingStatsDeviation stats + return (t, (mu - 3 * sigma, mu + 3 * sigma)) + let p = toPlot $ + plotFillBetween $ + plot_fillbetween_values .~ filterPlotFillBetweenValues zs $ + plot_fillbetween_title .~ either id id name $ + def + case name of + Left _ -> return $ Left p + Right _ -> return $ Right p + let ps = join $ flip map (zip ps1 ps2) $ \(p1, p2) -> [p2, p1] + axis = plotBottomAxis $ + laxis_title .~ "time" $ + def + updateLeftAxis = + if null $ lefts ps + then layoutlr_left_axis_visibility .~ AxisVisibility False False False + else id + updateRightAxis = + if null $ rights ps + then layoutlr_right_axis_visibility .~ AxisVisibility False False False + else id + chart = plotLayout . updateLeftAxis . updateRightAxis $ + layoutlr_x_axis .~ axis $ + layoutlr_title .~ plotTitle $ + layoutlr_plots .~ ps $ + def + file <- resolveFileName + (Just $ deviationChartDir st) + (deviationChartFileName $ deviationChartView st) $ + M.fromList [("$TITLE", title)] + let opts = FileOptions (width, height) PNG + renderableToFile opts (toRenderable chart) file + when (experimentVerbose $ deviationChartExperiment st) $ + putStr "Generated file " >> putStrLn file + writeIORef (deviationChartFile st) $ Just file + +-- | Remove the NaN and inifity values. +filterPlotLinesValues :: [(Double, Double)] -> [[(Double, Double)]] +filterPlotLinesValues = + filter (not . null) . + divideBy (\(t, x) -> isNaN x || isInfinite x) + +-- | Remove the NaN and inifity values. +filterPlotFillBetweenValues :: [(Double, (Double, Double))] -> [(Double, (Double, Double))] +filterPlotFillBetweenValues = + filter $ \(t, (x1, x2)) -> not $ isNaN x1 || isInfinite x1 || isNaN x2 || isInfinite x2 + +-- | Get the HTML code. +deviationChartHtml :: DeviationChartViewState -> Int -> HtmlWriter () +deviationChartHtml st index = + do header st index + file <- liftIO $ readIORef (deviationChartFile st) + case file of + Nothing -> return () + Just f -> + writeHtmlParagraph $ + writeHtmlImage (makeRelative (deviationChartDir st) f) + +header :: DeviationChartViewState -> Int -> HtmlWriter () +header st index = + do writeHtmlHeader3WithId ("id" ++ show index) $ + writeHtmlText (deviationChartTitle $ deviationChartView st) + let description = deviationChartDescription $ deviationChartView st + unless (null description) $ + writeHtmlParagraph $ + writeHtmlText description + +-- | Get the TOC item. +deviationChartTOCHtml :: DeviationChartViewState -> Int -> HtmlWriter () +deviationChartTOCHtml st index = + writeHtmlListItem $ + writeHtmlLink ("#id" ++ show index) $ + writeHtmlText (deviationChartTitle $ deviationChartView st) diff --git a/Simulation/Aivika/Experiment/Chart/FinalHistogramView.hs b/Simulation/Aivika/Experiment/Chart/FinalHistogramView.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Experiment/Chart/FinalHistogramView.hs @@ -0,0 +1,289 @@ + +-- | +-- Module : Simulation.Aivika.Experiment.Chart.FinalHistogramView +-- Copyright : Copyright (c) 2012-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.6.3 +-- +-- The module defines 'FinalHistogramView' that draws a histogram +-- by the specified series in final time points collected from different +-- simulation runs. +-- + +module Simulation.Aivika.Experiment.Chart.FinalHistogramView + (FinalHistogramView(..), + defaultFinalHistogramView) where + +import Control.Monad +import Control.Monad.Trans +import Control.Concurrent.MVar +import Control.Lens + +import qualified Data.Map as M +import Data.IORef +import Data.Maybe +import Data.Either +import Data.Array +import Data.Array.IO.Safe +import Data.Default.Class + +import System.IO +import System.FilePath + +import Graphics.Rendering.Chart +import Graphics.Rendering.Chart.Backend.Cairo + +import Simulation.Aivika.Experiment +import Simulation.Aivika.Experiment.HtmlWriter +import Simulation.Aivika.Experiment.Utils (divideBy, replace) +import Simulation.Aivika.Experiment.Chart.Utils (colourisePlotBars) +import Simulation.Aivika.Experiment.Histogram +import Simulation.Aivika.Experiment.ListSource + +import Simulation.Aivika.Specs +import Simulation.Aivika.Parameter +import Simulation.Aivika.Simulation +import Simulation.Aivika.Dynamics +import Simulation.Aivika.Event +import Simulation.Aivika.Signal + +-- | Defines the 'View' that saves the histogram +-- in the PNG file by the specified series in +-- final time points collected from different +-- simulation runs. +data FinalHistogramView = + FinalHistogramView { finalHistogramTitle :: String, + -- ^ This is a title used in HTML. + finalHistogramDescription :: String, + -- ^ This is a description used in HTML. + finalHistogramWidth :: Int, + -- ^ The width of the histogram. + finalHistogramHeight :: Int, + -- ^ The height of the histogram. + finalHistogramFileName :: FileName, + -- ^ It defines the file name for the PNG file. + -- It may include special variable @$TITLE@. + -- + -- An example is + -- + -- @ + -- finalHistogramFileName = UniqueFileName \"$TITLE\" \".png\" + -- @ + finalHistogramPredicate :: Event Bool, + -- ^ It specifies the predicate that defines + -- when we count data when plotting the histogram. + finalHistogramBuild :: [[Double]] -> Histogram, + -- ^ Builds a histogram by the specified list of + -- data series. + finalHistogramSeries :: [String], + -- ^ It contains the labels of data plotted + -- on the histogram. + finalHistogramPlotTitle :: String, + -- ^ This is a title used in the histogram. + -- It may include special variable @$TITLE@. + -- + -- An example is + -- + -- @ + -- finalHistogramPlotTitle = \"$TITLE\" + -- @ + finalHistogramPlotBars :: PlotBars Double Double -> + PlotBars Double Double, + -- ^ A transformation based on which the plot bar + -- is constructed for the series. + -- + -- Here you can define a colour or style of + -- the plot bars. + finalHistogramLayout :: Layout Double Double -> + Layout Double Double + -- ^ A transformation of the plot layout, + -- where you can redefine the axes, for example. + } + +-- | The default histogram view. +defaultFinalHistogramView :: FinalHistogramView +defaultFinalHistogramView = + FinalHistogramView { finalHistogramTitle = "Final Histogram", + finalHistogramDescription = "It shows a histogram by data gathered in the final time points.", + finalHistogramWidth = 640, + finalHistogramHeight = 480, + finalHistogramFileName = UniqueFileName "$TITLE" ".png", + finalHistogramPredicate = return True, + finalHistogramBuild = histogram binSturges, + finalHistogramSeries = [], + finalHistogramPlotTitle = "$TITLE", + finalHistogramPlotBars = colourisePlotBars, + finalHistogramLayout = id } + +instance ExperimentView FinalHistogramView where + + outputView v = + let reporter exp dir = + do st <- newFinalHistogram v exp dir + return ExperimentReporter { reporterInitialise = return (), + reporterFinalise = finaliseFinalHistogram st, + reporterSimulate = simulateFinalHistogram st, + reporterTOCHtml = finalHistogramTOCHtml st, + reporterHtml = finalHistogramHtml st } + in ExperimentGenerator { generateReporter = reporter } + +-- | The state of the view. +data FinalHistogramViewState = + FinalHistogramViewState { finalHistogramView :: FinalHistogramView, + finalHistogramExperiment :: Experiment, + finalHistogramDir :: FilePath, + finalHistogramFile :: IORef (Maybe FilePath), + finalHistogramLock :: MVar (), + finalHistogramResults :: IORef (Maybe FinalHistogramResults) } + +-- | The histogram item. +data FinalHistogramResults = + FinalHistogramResults { finalHistogramNames :: [String], + finalHistogramValues :: [ListRef Double] } + +-- | Create a new state of the view. +newFinalHistogram :: FinalHistogramView -> Experiment -> FilePath -> IO FinalHistogramViewState +newFinalHistogram view exp dir = + do f <- newIORef Nothing + l <- newMVar () + r <- newIORef Nothing + return FinalHistogramViewState { finalHistogramView = view, + finalHistogramExperiment = exp, + finalHistogramDir = dir, + finalHistogramFile = f, + finalHistogramLock = l, + finalHistogramResults = r } + +-- | Create new histogram results. +newFinalHistogramResults :: [String] -> Experiment -> IO FinalHistogramResults +newFinalHistogramResults names exp = + do values <- forM names $ \_ -> liftIO newListRef + return FinalHistogramResults { finalHistogramNames = names, + finalHistogramValues = values } + +-- | Simulation of the specified series. +simulateFinalHistogram :: FinalHistogramViewState -> ExperimentData -> Event (Event ()) +simulateFinalHistogram st expdata = + do let labels = finalHistogramSeries $ finalHistogramView st + providers = experimentSeriesProviders expdata labels + input = + flip map providers $ \provider -> + case providerToDoubleListSource provider of + Nothing -> error $ + "Cannot represent series " ++ + providerName provider ++ + " as a source of double values: simulateFinalHistogram" + Just input -> listSourceData input + names = map providerName providers + predicate = finalHistogramPredicate $ finalHistogramView st + exp = finalHistogramExperiment st + lock = finalHistogramLock st + results <- liftIO $ readIORef (finalHistogramResults st) + case results of + Nothing -> + liftIO $ + do results <- newFinalHistogramResults names exp + writeIORef (finalHistogramResults st) $ Just results + Just results -> + when (names /= finalHistogramNames results) $ + error "Series with different names are returned for different runs: simulateFinalHistogram" + results <- liftIO $ fmap fromJust $ readIORef (finalHistogramResults st) + let values = finalHistogramValues results + h = filterSignalM (const predicate) $ + experimentSignalInStopTime expdata + handleSignal_ h $ \_ -> + do xs <- sequence input + liftIO $ withMVar lock $ \() -> + forM_ (zip xs values) $ \(x, values) -> + addDataToListRef values x + return $ return () + +-- | Plot the histogram after the simulation is complete. +finaliseFinalHistogram :: FinalHistogramViewState -> IO () +finaliseFinalHistogram st = + do let title = finalHistogramTitle $ finalHistogramView st + plotTitle = + replace "$TITLE" title + (finalHistogramPlotTitle $ finalHistogramView st) + width = finalHistogramWidth $ finalHistogramView st + height = finalHistogramHeight $ finalHistogramView st + histogram = finalHistogramBuild $ finalHistogramView st + bars = finalHistogramPlotBars $ finalHistogramView st + layout = finalHistogramLayout $ finalHistogramView st + results <- readIORef $ finalHistogramResults st + case results of + Nothing -> return () + Just results -> + do let names = finalHistogramNames results + values = finalHistogramValues results + xs <- forM values readListRef + let zs = histogramToBars . filterHistogram . histogram $ + map filterData xs + p = plotBars $ + bars $ + plot_bars_values .~ zs $ + plot_bars_titles .~ names $ + def + updateAxes = + if null zs + then let v = AxisVisibility True False False + in \l -> layout_top_axis_visibility .~ v $ + layout_bottom_axis_visibility .~ v $ + layout_left_axis_visibility .~ v $ + layout_right_axis_visibility .~ v $ + l + else id + chart = layout . updateAxes $ + layout_title .~ plotTitle $ + layout_plots .~ [p] $ + def + file <- resolveFileName + (Just $ finalHistogramDir st) + (finalHistogramFileName $ finalHistogramView st) $ + M.fromList [("$TITLE", title)] + let opts = FileOptions (width, height) PNG + renderableToFile opts (toRenderable chart) file + when (experimentVerbose $ finalHistogramExperiment st) $ + putStr "Generated file " >> putStrLn file + writeIORef (finalHistogramFile st) $ Just file + +-- | Remove the NaN and inifity values. +filterData :: [Double] -> [Double] +filterData = filter (\x -> not $ isNaN x || isInfinite x) + +-- | Remove the NaN and inifity values. +filterHistogram :: [(Double, a)] -> [(Double, a)] +filterHistogram = filter (\(x, _) -> not $ isNaN x || isInfinite x) + +-- | Convert a histogram to the bars. +histogramToBars :: [(Double, [Int])] -> [(Double, [Double])] +histogramToBars = map $ \(x, ns) -> (x, map fromIntegral ns) + +-- | Get the HTML code. +finalHistogramHtml :: FinalHistogramViewState -> Int -> HtmlWriter () +finalHistogramHtml st index = + do header st index + file <- liftIO $ readIORef (finalHistogramFile st) + case file of + Nothing -> return () + Just f -> + writeHtmlParagraph $ + writeHtmlImage (makeRelative (finalHistogramDir st) f) + +header :: FinalHistogramViewState -> Int -> HtmlWriter () +header st index = + do writeHtmlHeader3WithId ("id" ++ show index) $ + writeHtmlText (finalHistogramTitle $ finalHistogramView st) + let description = finalHistogramDescription $ finalHistogramView st + unless (null description) $ + writeHtmlParagraph $ + writeHtmlText description + +-- | Get the TOC item. +finalHistogramTOCHtml :: FinalHistogramViewState -> Int -> HtmlWriter () +finalHistogramTOCHtml st index = + writeHtmlListItem $ + writeHtmlLink ("#id" ++ show index) $ + writeHtmlText (finalHistogramTitle $ finalHistogramView st) diff --git a/Simulation/Aivika/Experiment/Chart/FinalXYChartView.hs b/Simulation/Aivika/Experiment/Chart/FinalXYChartView.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Experiment/Chart/FinalXYChartView.hs @@ -0,0 +1,328 @@ + +-- | +-- Module : Simulation.Aivika.Experiment.Chart.FinalXYChartView +-- Copyright : Copyright (c) 2012-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.6.3 +-- +-- The module defines 'FinalXYChartView' that saves the XY chart +-- by final time points for all simulation runs sequentially. +-- + +module Simulation.Aivika.Experiment.Chart.FinalXYChartView + (FinalXYChartView(..), + defaultFinalXYChartView) where + +import Control.Monad +import Control.Monad.Trans +import Control.Concurrent.MVar +import Control.Lens + +import qualified Data.Map as M +import Data.IORef +import Data.Maybe +import Data.Either +import Data.Array +import Data.Array.IO.Safe +import Data.Default.Class + +import System.IO +import System.FilePath + +import Graphics.Rendering.Chart +import Graphics.Rendering.Chart.Backend.Cairo + +import Simulation.Aivika.Experiment +import Simulation.Aivika.Experiment.HtmlWriter +import Simulation.Aivika.Experiment.Utils (divideBy, replace) +import Simulation.Aivika.Experiment.Chart.Utils (colourisePlotLines) + +import Simulation.Aivika.Specs +import Simulation.Aivika.Parameter +import Simulation.Aivika.Simulation +import Simulation.Aivika.Dynamics +import Simulation.Aivika.Event +import Simulation.Aivika.Signal + +-- | Defines the 'View' that saves the XY chart +-- in the PNG file by final time points for all +-- simulation runs sequentially. +data FinalXYChartView = + FinalXYChartView { finalXYChartTitle :: String, + -- ^ This is a title used HTML. + finalXYChartDescription :: String, + -- ^ This is a description used in HTML. + finalXYChartWidth :: Int, + -- ^ The width of the chart. + finalXYChartHeight :: Int, + -- ^ The height of the chart. + finalXYChartFileName :: FileName, + -- ^ It defines the file name for the PNG file. + -- It may include special variable @$TITLE@. + -- + -- An example is + -- + -- @ + -- finalXYChartFileName = UniqueFileName \"$TITLE\" \".png\" + -- @ + finalXYChartPredicate :: Event Bool, + -- ^ It specifies the predicate that defines + -- when we count data when plotting the chart. + finalXYChartXSeries :: Maybe String, + -- ^ It defines a label of the single X series. + -- + -- You must define it, because it is 'Nothing' + -- by default. + finalXYChartYSeries :: [Either String String], + -- ^ It contains the labels of Y series plotted + -- on the chart. + finalXYChartPlotTitle :: String, + -- ^ This is a title used in the chart. + -- It may include special variable @$TITLE@. + -- + -- An example is + -- + -- @ + -- finalXYChartPlotTitle = \"$TITLE\" + -- @ + finalXYChartPlotLines :: [PlotLines Double Double -> + PlotLines Double Double], + -- ^ Probably, an infinite sequence of plot + -- transformations based on which the plot + -- is constructed for each series. Generally, + -- it may not coincide with a sequence of + -- labels as one label may denote a whole list + -- or an array of data providers. + -- + -- Here you can define a colour or style of + -- the plot lines. + finalXYChartBottomAxis :: LayoutAxis Double -> + LayoutAxis Double, + -- ^ A transformation of the bottom axis, + -- after the X title is added. + finalXYChartLayout :: LayoutLR Double Double Double -> + LayoutLR Double Double Double + -- ^ A transformation of the plot layout, + -- where you can redefine the axes, for example. + } + +-- | The default XY chart view. +defaultFinalXYChartView :: FinalXYChartView +defaultFinalXYChartView = + FinalXYChartView { finalXYChartTitle = "Final XY Chart", + finalXYChartDescription = "It shows the XY chart for the results in the final time points.", + finalXYChartWidth = 640, + finalXYChartHeight = 480, + finalXYChartFileName = UniqueFileName "$TITLE" ".png", + finalXYChartPredicate = return True, + finalXYChartXSeries = Nothing, + finalXYChartYSeries = [], + finalXYChartPlotTitle = "$TITLE", + finalXYChartPlotLines = colourisePlotLines, + finalXYChartBottomAxis = id, + finalXYChartLayout = id } + +instance ExperimentView FinalXYChartView where + + outputView v = + let reporter exp dir = + do st <- newFinalXYChart v exp dir + return ExperimentReporter { reporterInitialise = return (), + reporterFinalise = finaliseFinalXYChart st, + reporterSimulate = simulateFinalXYChart st, + reporterTOCHtml = finalXYChartTOCHtml st, + reporterHtml = finalXYChartHtml st } + in ExperimentGenerator { generateReporter = reporter } + +-- | The state of the view. +data FinalXYChartViewState = + FinalXYChartViewState { finalXYChartView :: FinalXYChartView, + finalXYChartExperiment :: Experiment, + finalXYChartDir :: FilePath, + finalXYChartFile :: IORef (Maybe FilePath), + finalXYChartLock :: MVar (), + finalXYChartResults :: IORef (Maybe FinalXYChartResults) } + +-- | The XY chart results. +data FinalXYChartResults = + FinalXYChartResults { finalXYChartXName :: String, + finalXYChartYNames :: [Either String String], + finalXYChartXY :: [IOArray Int (Maybe (Double, Double))] } + +-- | Create a new state of the view. +newFinalXYChart :: FinalXYChartView -> Experiment -> FilePath -> IO FinalXYChartViewState +newFinalXYChart view exp dir = + do f <- newIORef Nothing + l <- newMVar () + r <- newIORef Nothing + return FinalXYChartViewState { finalXYChartView = view, + finalXYChartExperiment = exp, + finalXYChartDir = dir, + finalXYChartFile = f, + finalXYChartLock = l, + finalXYChartResults = r } + +-- | Create new chart results. +newFinalXYChartResults :: String -> [Either String String] -> Experiment -> IO FinalXYChartResults +newFinalXYChartResults xname ynames exp = + do let n = experimentRunCount exp + xy <- forM ynames $ \_ -> + liftIO $ newArray (1, n) Nothing + return FinalXYChartResults { finalXYChartXName = xname, + finalXYChartYNames = ynames, + finalXYChartXY = xy } + +-- | Simulation. +simulateFinalXYChart :: FinalXYChartViewState -> ExperimentData -> Event (Event ()) +simulateFinalXYChart st expdata = + do let ylabels = finalXYChartYSeries $ finalXYChartView st + xlabels = finalXYChartXSeries $ finalXYChartView st + xlabel = flip fromMaybe xlabels $ + error "X series is not provided: simulateFinalXYChart" + (leftYLabels, rightYLabels) = partitionEithers ylabels + leftYProviders = experimentSeriesProviders expdata leftYLabels + rightYProviders = experimentSeriesProviders expdata rightYLabels + xprovider = + case experimentSeriesProviders expdata [xlabel] of + [provider] -> provider + _ -> error $ + "Only a single X series must be" ++ + " provided: simulateFinalXYChart" + providerInput providers = + flip map providers $ \provider -> + case providerToDouble provider of + Nothing -> error $ + "Cannot represent series " ++ + providerName provider ++ + " as double values: simulateFinalXYChart" + Just input -> (providerName provider, input) + leftYInput = providerInput leftYProviders + rightYInput = providerInput rightYProviders + yinput = leftYInput ++ rightYInput + [xinput] = providerInput [xprovider] + leftYNames = map (Left . fst) leftYInput + rightYNames = map (Right . fst) rightYInput + ynames = leftYNames ++ rightYNames + xname = fst xinput + ys = map snd yinput + x = snd xinput + predicate = finalXYChartPredicate $ finalXYChartView st + exp = finalXYChartExperiment st + lock = finalXYChartLock st + results <- liftIO $ readIORef (finalXYChartResults st) + case results of + Nothing -> + liftIO $ + do results <- newFinalXYChartResults xname ynames exp + writeIORef (finalXYChartResults st) $ Just results + Just results -> + let diffnames = + (xname /= finalXYChartXName results) || + (ynames /= finalXYChartYNames results) + in when diffnames $ + error "Series with different names are returned for different runs: simulateFinalXYChart" + results <- liftIO $ fmap fromJust $ readIORef (finalXYChartResults st) + let xys = finalXYChartXY results + h = filterSignalM (const predicate) $ + experimentSignalInStopTime expdata + handleSignal_ h $ \_ -> + do x' <- x + ys' <- sequence ys + i <- liftParameter simulationIndex + liftIO $ withMVar lock $ \() -> + forM_ (zip ys' xys) $ \(y', xy) -> + x' `seq` y' `seq` writeArray xy i $ Just (x', y') + return $ return () + +-- | Plot the XY chart after the simulation is complete. +finaliseFinalXYChart :: FinalXYChartViewState -> IO () +finaliseFinalXYChart st = + do let title = finalXYChartTitle $ finalXYChartView st + plotTitle = + replace "$TITLE" title + (finalXYChartPlotTitle $ finalXYChartView st) + width = finalXYChartWidth $ finalXYChartView st + height = finalXYChartHeight $ finalXYChartView st + plotLines = finalXYChartPlotLines $ finalXYChartView st + plotBottomAxis = finalXYChartBottomAxis $ finalXYChartView st + plotLayout = finalXYChartLayout $ finalXYChartView st + results <- readIORef $ finalXYChartResults st + case results of + Nothing -> return () + Just results -> + do let xname = finalXYChartXName results + ynames = finalXYChartYNames results + xys = finalXYChartXY results + ps <- forM (zip3 ynames xys plotLines) $ \(name, xy, plotLines) -> + do zs <- getElems xy + let p = toPlot $ + plotLines $ + plot_lines_values .~ filterPlotLinesValues zs $ + plot_lines_title .~ either id id name $ + def + r = case name of + Left _ -> Left p + Right _ -> Right p + return r + let axis = plotBottomAxis $ + laxis_title .~ xname $ + def + updateLeftAxis = + if null $ lefts ps + then layoutlr_left_axis_visibility .~ AxisVisibility False False False + else id + updateRightAxis = + if null $ rights ps + then layoutlr_right_axis_visibility .~ AxisVisibility False False False + else id + chart = plotLayout . updateLeftAxis . updateRightAxis $ + layoutlr_x_axis .~ axis $ + layoutlr_title .~ plotTitle $ + layoutlr_plots .~ ps $ + def + file <- resolveFileName + (Just $ finalXYChartDir st) + (finalXYChartFileName $ finalXYChartView st) $ + M.fromList [("$TITLE", title)] + let opts = FileOptions (width, height) PNG + renderableToFile opts (toRenderable chart) file + when (experimentVerbose $ finalXYChartExperiment st) $ + putStr "Generated file " >> putStrLn file + writeIORef (finalXYChartFile st) $ Just file + +-- | Remove the NaN and inifity values. +filterPlotLinesValues :: [Maybe (Double, Double)] -> [[(Double, Double)]] +filterPlotLinesValues = + filter (not . null) . map (map fromJust) . divideBy pred + where pred Nothing = True + pred (Just (x, y)) = isNaN x || isInfinite x || + isNaN y || isInfinite y + +-- | Get the HTML code. +finalXYChartHtml :: FinalXYChartViewState -> Int -> HtmlWriter () +finalXYChartHtml st index = + do header st index + file <- liftIO $ readIORef (finalXYChartFile st) + case file of + Nothing -> return () + Just f -> + writeHtmlParagraph $ + writeHtmlImage (makeRelative (finalXYChartDir st) f) + +header :: FinalXYChartViewState -> Int -> HtmlWriter () +header st index = + do writeHtmlHeader3WithId ("id" ++ show index) $ + writeHtmlText (finalXYChartTitle $ finalXYChartView st) + let description = finalXYChartDescription $ finalXYChartView st + unless (null description) $ + writeHtmlParagraph $ + writeHtmlText description + +-- | Get the TOC item. +finalXYChartTOCHtml :: FinalXYChartViewState -> Int -> HtmlWriter () +finalXYChartTOCHtml st index = + writeHtmlListItem $ + writeHtmlLink ("#id" ++ show index) $ + writeHtmlText (finalXYChartTitle $ finalXYChartView st) diff --git a/Simulation/Aivika/Experiment/Chart/HistogramView.hs b/Simulation/Aivika/Experiment/Chart/HistogramView.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Experiment/Chart/HistogramView.hs @@ -0,0 +1,284 @@ + +-- | +-- Module : Simulation.Aivika.Experiment.Chart.HistogramView +-- Copyright : Copyright (c) 2012-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.6.3 +-- +-- The module defines 'HistogramView' that saves the histogram +-- in the PNG files by all integration time points for each +-- simulation run separately. +-- + +module Simulation.Aivika.Experiment.Chart.HistogramView + (HistogramView(..), + defaultHistogramView) where + +import Control.Monad +import Control.Monad.Trans +import Control.Lens + +import qualified Data.Map as M +import Data.IORef +import Data.Maybe +import Data.Either +import Data.Array +import Data.Default.Class + +import System.IO +import System.FilePath + +import Graphics.Rendering.Chart +import Graphics.Rendering.Chart.Backend.Cairo + +import Simulation.Aivika.Experiment +import Simulation.Aivika.Experiment.HtmlWriter +import Simulation.Aivika.Experiment.Utils (divideBy, replace) +import Simulation.Aivika.Experiment.Chart.Utils (colourisePlotBars) +import Simulation.Aivika.Experiment.Histogram +import Simulation.Aivika.Experiment.ListSource + +import Simulation.Aivika.Specs +import Simulation.Aivika.Parameter +import Simulation.Aivika.Simulation +import Simulation.Aivika.Event +import Simulation.Aivika.Signal + +-- | Defines the 'View' that saves the histogram in +-- the PNG files by all integration time points for +-- each simulation run separately. +data HistogramView = + HistogramView { histogramTitle :: String, + -- ^ This is a title used in HTML. + histogramDescription :: String, + -- ^ This is a description used in HTML. + histogramWidth :: Int, + -- ^ The width of the histogram. + histogramHeight :: Int, + -- ^ The height of the histogram. + histogramFileName :: FileName, + -- ^ It defines the file name for each PNG file. + -- It may include special variables @$TITLE@, + -- @$RUN_INDEX@ and @$RUN_COUNT@. + -- + -- An example is + -- + -- @ + -- histogramFileName = UniqueFileName \"$TITLE - $RUN_INDEX\" \".png\" + -- @ + histogramPredicate :: Event Bool, + -- ^ It specifies the predicate that defines + -- when we count data when plotting the histogram. + histogramBuild :: [[Double]] -> Histogram, + -- ^ Builds a histogram by the specified list of + -- data series. + histogramSeries :: [String], + -- ^ It contains the labels of data for which + -- the histogram is plotted. + histogramPlotTitle :: String, + -- ^ This is a title used in the histogram when + -- simulating a single run. It may include + -- special variable @$TITLE@. + -- + -- An example is + -- + -- @ + -- histogramPlotTitle = \"$TITLE\" + -- @ + histogramRunPlotTitle :: String, + -- ^ The run title for the histogram. It is used + -- when simulating multiple runs and it may + -- include special variables @$RUN_INDEX@, + -- @$RUN_COUNT@ and @$PLOT_TITLE@. + -- + -- An example is + -- + -- @ + -- histogramRunPlotTitle = \"$PLOT_TITLE / Run $RUN_INDEX of $RUN_COUNT\" + -- @ + histogramPlotBars :: PlotBars Double Double -> + PlotBars Double Double, + -- ^ A transformation based on which the plot bar + -- is constructed for the series. + -- + -- Here you can define a colour or style of + -- the plot bars. + histogramLayout :: Layout Double Double -> + Layout Double Double + -- ^ A transformation of the plot layout, + -- where you can redefine the axes, for example. + } + +-- | The default histogram view. +defaultHistogramView :: HistogramView +defaultHistogramView = + HistogramView { histogramTitle = "Histogram", + histogramDescription = "It shows the histogram(s) by data gathered in the integration time points.", + histogramWidth = 640, + histogramHeight = 480, + histogramFileName = UniqueFileName "$TITLE - $RUN_INDEX" ".png", + histogramPredicate = return True, + histogramBuild = histogram binSturges, + histogramSeries = [], + histogramPlotTitle = "$TITLE", + histogramRunPlotTitle = "$PLOT_TITLE / Run $RUN_INDEX of $RUN_COUNT", + histogramPlotBars = colourisePlotBars, + histogramLayout = id } + +instance ExperimentView HistogramView where + + outputView v = + let reporter exp dir = + do st <- newHistogram v exp dir + return ExperimentReporter { reporterInitialise = return (), + reporterFinalise = return (), + reporterSimulate = simulateHistogram st, + reporterTOCHtml = histogramTOCHtml st, + reporterHtml = histogramHtml st } + in ExperimentGenerator { generateReporter = reporter } + +-- | The state of the view. +data HistogramViewState = + HistogramViewState { histogramView :: HistogramView, + histogramExperiment :: Experiment, + histogramDir :: FilePath, + histogramMap :: M.Map Int FilePath } + +-- | Create a new state of the view. +newHistogram :: HistogramView -> Experiment -> FilePath -> IO HistogramViewState +newHistogram view exp dir = + do let n = experimentRunCount exp + fs <- forM [0..(n - 1)] $ \i -> + resolveFileName (Just dir) (histogramFileName view) $ + M.fromList [("$TITLE", histogramTitle 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 HistogramViewState { histogramView = view, + histogramExperiment = exp, + histogramDir = dir, + histogramMap = m } + +-- | Plot the histogram during the simulation. +simulateHistogram :: HistogramViewState -> ExperimentData -> Event (Event ()) +simulateHistogram st expdata = + do let labels = histogramSeries $ histogramView st + providers = experimentSeriesProviders expdata labels + names = map providerName providers + input = + flip map providers $ \provider -> + case providerToDoubleListSource provider of + Nothing -> error $ + "Cannot represent series " ++ + providerName provider ++ + " as a source of double values: simulateHistogram" + Just input -> fmap listDataList $ listSourceData input + n = experimentRunCount $ histogramExperiment st + width = histogramWidth $ histogramView st + height = histogramHeight $ histogramView st + predicate = histogramPredicate $ histogramView st + bars = histogramPlotBars $ histogramView st + layout = histogramLayout $ histogramView st + build = histogramBuild $ histogramView st + i <- liftParameter simulationIndex + let file = fromJust $ M.lookup (i - 1) (histogramMap st) + title = histogramTitle $ histogramView st + plotTitle = + replace "$TITLE" title + (histogramPlotTitle $ histogramView st) + runPlotTitle = + if n == 1 + then plotTitle + else replace "$RUN_INDEX" (show i) $ + replace "$RUN_COUNT" (show n) $ + replace "$PLOT_TITLE" plotTitle + (histogramRunPlotTitle $ histogramView st) + hs <- forM (zip providers input) $ \(provider, input) -> + newSignalHistory $ + mapSignalM (const input) $ + filterSignalM (const predicate) $ + experimentSignalInIntegTimes expdata + return $ + do xs <- forM hs readSignalHistory + let zs = histogramToBars . filterHistogram . build $ + map (filterData . concat . elems . snd) xs + p = plotBars $ + bars $ + plot_bars_values .~ zs $ + plot_bars_titles .~ names $ + def + updateAxes = + if null zs + then let v = AxisVisibility True False False + in \l -> layout_top_axis_visibility .~ v $ + layout_bottom_axis_visibility .~ v $ + layout_left_axis_visibility .~ v $ + layout_right_axis_visibility .~ v $ + l + else id + chart = layout . updateAxes $ + layout_title .~ runPlotTitle $ + layout_plots .~ [p] $ + def + liftIO $ + do let opts = FileOptions (width, height) PNG + renderableToFile opts (toRenderable chart) file + when (experimentVerbose $ histogramExperiment st) $ + putStr "Generated file " >> putStrLn file + +-- | Remove the NaN and inifity values. +filterData :: [Double] -> [Double] +filterData = filter (\x -> not $ isNaN x || isInfinite x) + +-- | Remove the NaN and inifity values. +filterHistogram :: [(Double, a)] -> [(Double, a)] +filterHistogram = filter (\(x, _) -> not $ isNaN x || isInfinite x) + +-- | Convert a histogram to the bars. +histogramToBars :: [(Double, [Int])] -> [(Double, [Double])] +histogramToBars = map $ \(x, ns) -> (x, map fromIntegral ns) + +-- | Get the HTML code. +histogramHtml :: HistogramViewState -> Int -> HtmlWriter () +histogramHtml st index = + let n = experimentRunCount $ histogramExperiment st + in if n == 1 + then histogramHtmlSingle st index + else histogramHtmlMultiple st index + +-- | Get the HTML code for a single run. +histogramHtmlSingle :: HistogramViewState -> Int -> HtmlWriter () +histogramHtmlSingle st index = + do header st index + let f = fromJust $ M.lookup 0 (histogramMap st) + writeHtmlParagraph $ + writeHtmlImage (makeRelative (histogramDir st) f) + +-- | Get the HTML code for multiple runs. +histogramHtmlMultiple :: HistogramViewState -> Int -> HtmlWriter () +histogramHtmlMultiple st index = + do header st index + let n = experimentRunCount $ histogramExperiment st + forM_ [0..(n - 1)] $ \i -> + let f = fromJust $ M.lookup i (histogramMap st) + in writeHtmlParagraph $ + writeHtmlImage (makeRelative (histogramDir st) f) + +header :: HistogramViewState -> Int -> HtmlWriter () +header st index = + do writeHtmlHeader3WithId ("id" ++ show index) $ + writeHtmlText (histogramTitle $ histogramView st) + let description = histogramDescription $ histogramView st + unless (null description) $ + writeHtmlParagraph $ + writeHtmlText description + +-- | Get the TOC item. +histogramTOCHtml :: HistogramViewState -> Int -> HtmlWriter () +histogramTOCHtml st index = + writeHtmlListItem $ + writeHtmlLink ("#id" ++ show index) $ + writeHtmlText (histogramTitle $ histogramView st) diff --git a/Simulation/Aivika/Experiment/Chart/TimeSeriesView.hs b/Simulation/Aivika/Experiment/Chart/TimeSeriesView.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Experiment/Chart/TimeSeriesView.hs @@ -0,0 +1,301 @@ + +-- | +-- Module : Simulation.Aivika.Experiment.Chart.TimeSeriesView +-- Copyright : Copyright (c) 2012-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.6.3 +-- +-- The module defines 'TimeSeriesView' that saves the time series +-- charts as the PNG files. +-- + +module Simulation.Aivika.Experiment.Chart.TimeSeriesView + (TimeSeriesView(..), + defaultTimeSeriesView) where + +import Control.Monad +import Control.Monad.Trans +import Control.Lens + +import qualified Data.Map as M +import Data.IORef +import Data.Maybe +import Data.Either +import Data.Array +import Data.List +import Data.Default.Class + +import System.IO +import System.FilePath + +import Graphics.Rendering.Chart +import Graphics.Rendering.Chart.Backend.Cairo + +import Simulation.Aivika.Experiment +import Simulation.Aivika.Experiment.HtmlWriter +import Simulation.Aivika.Experiment.Utils (divideBy, replace) +import Simulation.Aivika.Experiment.Chart.Utils (colourisePlotLines) + +import Simulation.Aivika.Specs +import Simulation.Aivika.Parameter +import Simulation.Aivika.Simulation +import Simulation.Aivika.Event +import Simulation.Aivika.Signal + +-- | Defines the 'View' that saves the time series charts +-- in the PNG files. +data TimeSeriesView = + TimeSeriesView { timeSeriesTitle :: String, + -- ^ This is a title used in HTML. + timeSeriesDescription :: String, + -- ^ This is a description used in HTML. + timeSeriesWidth :: Int, + -- ^ The width of the chart. + timeSeriesHeight :: Int, + -- ^ The height of the chart. + timeSeriesFileName :: FileName, + -- ^ It defines the file name for each PNG file. + -- It may include special variables @$TITLE@, + -- @$RUN_INDEX@ and @$RUN_COUNT@. + -- + -- An example is + -- + -- @ + -- timeSeriesFileName = UniqueFileName \"$TITLE - $RUN_INDEX\" \".png\" + -- @ + timeSeriesPredicate :: Event Bool, + -- ^ It specifies the predicate that defines + -- when we plot data in the chart. + timeSeries :: [Either String String], + -- ^ It contains the labels of data plotted + -- on the chart. + timeSeriesPlotTitle :: String, + -- ^ This is a title used in the chart when + -- simulating a single run. It may include + -- special variable @$TITLE@. + -- + -- An example is + -- + -- @ + -- timeSeriesPlotTitle = \"$TITLE\" + -- @ + timeSeriesRunPlotTitle :: String, + -- ^ The run title for the chart. It is used + -- when simulating multiple runs and it may + -- include special variables @$RUN_INDEX@, + -- @$RUN_COUNT@ and @$PLOT_TITLE@. + -- + -- An example is + -- + -- @ + -- timeSeriesRunPlotTitle = \"$PLOT_TITLE / Run $RUN_INDEX of $RUN_COUNT\" + -- @ + timeSeriesPlotLines :: [PlotLines Double Double -> + PlotLines Double Double], + -- ^ Probably, an infinite sequence of plot + -- transformations based on which the plot + -- is constructed for each series. Generally, + -- it must not coincide with a sequence of + -- labels as one label may denote a whole list + -- or an array of data providers. + -- + -- Here you can define a colour or style of + -- the plot lines. + timeSeriesBottomAxis :: LayoutAxis Double -> + LayoutAxis Double, + -- ^ A transformation of the bottom axis, + -- after title @time@ is added. + timeSeriesLayout :: LayoutLR Double Double Double -> + LayoutLR Double Double Double + -- ^ A transformation of the plot layout, + -- where you can redefine the axes, for example. + } + +-- | The default time series view. +defaultTimeSeriesView :: TimeSeriesView +defaultTimeSeriesView = + TimeSeriesView { timeSeriesTitle = "Time Series", + timeSeriesDescription = "It shows the Time Series chart(s).", + timeSeriesWidth = 640, + timeSeriesHeight = 480, + timeSeriesFileName = UniqueFileName "$TITLE - $RUN_INDEX" ".png", + timeSeriesPredicate = return True, + timeSeries = [], + timeSeriesPlotTitle = "$TITLE", + timeSeriesRunPlotTitle = "$PLOT_TITLE / Run $RUN_INDEX of $RUN_COUNT", + timeSeriesPlotLines = colourisePlotLines, + timeSeriesBottomAxis = id, + timeSeriesLayout = id } + +instance ExperimentView TimeSeriesView where + + outputView v = + let reporter exp dir = + do st <- newTimeSeries v exp dir + return ExperimentReporter { reporterInitialise = return (), + reporterFinalise = return (), + reporterSimulate = simulateTimeSeries st, + reporterTOCHtml = timeSeriesTOCHtml st, + reporterHtml = timeSeriesHtml st } + in ExperimentGenerator { generateReporter = reporter } + +-- | The state of the view. +data TimeSeriesViewState = + TimeSeriesViewState { timeSeriesView :: TimeSeriesView, + timeSeriesExperiment :: Experiment, + timeSeriesDir :: FilePath, + timeSeriesMap :: M.Map Int FilePath } + +-- | Create a new state of the view. +newTimeSeries :: TimeSeriesView -> Experiment -> FilePath -> IO TimeSeriesViewState +newTimeSeries view exp dir = + do let n = experimentRunCount exp + fs <- forM [0..(n - 1)] $ \i -> + resolveFileName (Just dir) (timeSeriesFileName view) $ + M.fromList [("$TITLE", timeSeriesTitle 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 TimeSeriesViewState { timeSeriesView = view, + timeSeriesExperiment = exp, + timeSeriesDir = dir, + timeSeriesMap = m } + +-- | Plot the time series chart during the simulation. +simulateTimeSeries :: TimeSeriesViewState -> ExperimentData -> Event (Event ()) +simulateTimeSeries st expdata = + do let labels = timeSeries $ timeSeriesView st + (leftLabels, rightLabels) = partitionEithers labels + (leftProviders, rightProviders) = + (experimentSeriesProviders expdata leftLabels, + experimentSeriesProviders expdata rightLabels) + providerInput providers = + flip map providers $ \provider -> + case providerToDouble provider of + Nothing -> error $ + "Cannot represent series " ++ + providerName provider ++ + " as double values: simulateTimeSeries" + Just input -> (providerName provider, provider, input) + leftInput = providerInput leftProviders + rightInput = providerInput rightProviders + n = experimentRunCount $ timeSeriesExperiment st + width = timeSeriesWidth $ timeSeriesView st + height = timeSeriesHeight $ timeSeriesView st + predicate = timeSeriesPredicate $ timeSeriesView st + plotLines = timeSeriesPlotLines $ timeSeriesView st + plotBottomAxis = timeSeriesBottomAxis $ timeSeriesView st + plotLayout = timeSeriesLayout $ timeSeriesView st + i <- liftParameter simulationIndex + let file = fromJust $ M.lookup (i - 1) (timeSeriesMap st) + title = timeSeriesTitle $ timeSeriesView st + plotTitle = + replace "$TITLE" title + (timeSeriesPlotTitle $ timeSeriesView st) + runPlotTitle = + if n == 1 + then plotTitle + else replace "$RUN_INDEX" (show i) $ + replace "$RUN_COUNT" (show n) $ + replace "$PLOT_TITLE" plotTitle + (timeSeriesRunPlotTitle $ timeSeriesView st) + inputHistory input = + forM input $ \(name, provider, input) -> + let transform () = + do x <- predicate + if x then input else return (1/0) -- the infinite values will be ignored then + in newSignalHistory $ + mapSignalM transform $ + experimentMixedSignal expdata [provider] + leftHs <- inputHistory leftInput + rightHs <- inputHistory rightInput + return $ + do let plots hs input plotLineTails = + do ps <- + forM (zip3 hs input (head plotLineTails)) $ + \(h, (name, provider, input), plotLines) -> + do (ts, xs) <- readSignalHistory h + return $ + toPlot $ + plotLines $ + plot_lines_values .~ filterPlotLinesValues (zip (elems ts) (elems xs)) $ + plot_lines_title .~ name $ + def + return (ps, drop (length hs) plotLineTails) + (leftPs, plotLineTails) <- plots leftHs leftInput (tails plotLines) + (rightPs, plotLineTails) <- plots rightHs rightInput plotLineTails + let leftPs' = map Left leftPs + rightPs' = map Right rightPs + ps' = leftPs' ++ rightPs' + axis = plotBottomAxis $ + laxis_title .~ "time" $ + def + updateLeftAxis = + if null leftPs + then layoutlr_left_axis_visibility .~ AxisVisibility False False False + else id + updateRightAxis = + if null rightPs + then layoutlr_right_axis_visibility .~ AxisVisibility False False False + else id + chart = plotLayout . updateLeftAxis . updateRightAxis $ + layoutlr_x_axis .~ axis $ + layoutlr_title .~ runPlotTitle $ + layoutlr_plots .~ ps' $ + def + liftIO $ + do let opts = FileOptions (width, height) PNG + renderableToFile opts (toRenderable chart) file + when (experimentVerbose $ timeSeriesExperiment st) $ + putStr "Generated file " >> putStrLn file + +-- | Remove the NaN and inifity values. +filterPlotLinesValues :: [(Double, Double)] -> [[(Double, Double)]] +filterPlotLinesValues = + filter (not . null) . + divideBy (\(t, x) -> isNaN x || isInfinite x) + +-- | Get the HTML code. +timeSeriesHtml :: TimeSeriesViewState -> Int -> HtmlWriter () +timeSeriesHtml st index = + let n = experimentRunCount $ timeSeriesExperiment st + in if n == 1 + then timeSeriesHtmlSingle st index + else timeSeriesHtmlMultiple st index + +-- | Get the HTML code for a single run. +timeSeriesHtmlSingle :: TimeSeriesViewState -> Int -> HtmlWriter () +timeSeriesHtmlSingle st index = + do header st index + let f = fromJust $ M.lookup 0 (timeSeriesMap st) + writeHtmlParagraph $ + writeHtmlImage (makeRelative (timeSeriesDir st) f) + +-- | Get the HTML code for multiple runs. +timeSeriesHtmlMultiple :: TimeSeriesViewState -> Int -> HtmlWriter () +timeSeriesHtmlMultiple st index = + do header st index + let n = experimentRunCount $ timeSeriesExperiment st + forM_ [0..(n - 1)] $ \i -> + let f = fromJust $ M.lookup i (timeSeriesMap st) + in writeHtmlParagraph $ + writeHtmlImage (makeRelative (timeSeriesDir st) f) + +header :: TimeSeriesViewState -> Int -> HtmlWriter () +header st index = + do writeHtmlHeader3WithId ("id" ++ show index) $ + writeHtmlText (timeSeriesTitle $ timeSeriesView st) + let description = timeSeriesDescription $ timeSeriesView st + unless (null description) $ + writeHtmlParagraph $ + writeHtmlText description + +-- | Get the TOC item. +timeSeriesTOCHtml :: TimeSeriesViewState -> Int -> HtmlWriter () +timeSeriesTOCHtml st index = + writeHtmlListItem $ + writeHtmlLink ("#id" ++ show index) $ + writeHtmlText (timeSeriesTitle $ timeSeriesView st) diff --git a/Simulation/Aivika/Experiment/Chart/Utils.hs b/Simulation/Aivika/Experiment/Chart/Utils.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Experiment/Chart/Utils.hs @@ -0,0 +1,39 @@ + +-- | +-- Module : Simulation.Aivika.Experiment.Chart.Utils +-- Copyright : Copyright (c) 2012-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.6.3 +-- +-- The module defines some utilities used in the charting. +-- + +module Simulation.Aivika.Experiment.Chart.Utils + (colourisePlotLines, + colourisePlotFillBetween, + colourisePlotBars) where + +import Control.Lens + +import Data.Colour +import Data.Colour.Names + +import Graphics.Rendering.Chart + +-- | Colourise the plot lines. +colourisePlotLines :: [PlotLines x y -> PlotLines x y] +colourisePlotLines = map mkstyle $ cycle defaultColorSeq + where mkstyle c = plot_lines_style . line_color .~ c + +-- | Colourise the filling areas. +colourisePlotFillBetween :: [PlotFillBetween x y -> PlotFillBetween x y] +colourisePlotFillBetween = map mkstyle $ cycle defaultColorSeq + where mkstyle c = plot_fillbetween_style .~ solidFillStyle (dissolve 0.4 c) + +-- | Colourise the plot bars. +colourisePlotBars :: PlotBars x y -> PlotBars x y +colourisePlotBars = plot_bars_item_styles .~ map mkstyle (cycle defaultColorSeq) + where mkstyle c = (solidFillStyle c, Just $ solidLine 1.0 $ opaque black) + diff --git a/Simulation/Aivika/Experiment/Chart/XYChartView.hs b/Simulation/Aivika/Experiment/Chart/XYChartView.hs new file mode 100644 --- /dev/null +++ b/Simulation/Aivika/Experiment/Chart/XYChartView.hs @@ -0,0 +1,320 @@ + +-- | +-- Module : Simulation.Aivika.Experiment.Chart.XYChartView +-- Copyright : Copyright (c) 2012-2014, David Sorokin +-- License : BSD3 +-- Maintainer : David Sorokin +-- Stability : experimental +-- Tested with: GHC 7.6.3 +-- +-- The module defines 'XYChartView' that saves the XY charts +-- in the PNG files. +-- + +module Simulation.Aivika.Experiment.Chart.XYChartView + (XYChartView(..), + defaultXYChartView) where + +import Control.Monad +import Control.Monad.Trans +import Control.Lens + +import qualified Data.Map as M +import Data.IORef +import Data.Maybe +import Data.Either +import Data.Array +import Data.Monoid +import Data.List +import Data.Default.Class + +import System.IO +import System.FilePath + +import Graphics.Rendering.Chart +import Graphics.Rendering.Chart.Backend.Cairo + +import Simulation.Aivika.Experiment +import Simulation.Aivika.Experiment.HtmlWriter +import Simulation.Aivika.Experiment.Utils (divideBy, replace) +import Simulation.Aivika.Experiment.Chart.Utils (colourisePlotLines) + +import Simulation.Aivika.Specs +import Simulation.Aivika.Parameter +import Simulation.Aivika.Simulation +import Simulation.Aivika.Event +import Simulation.Aivika.Signal + +-- | Defines the 'View' that saves the XY charts +-- in the PNG files. +data XYChartView = + XYChartView { xyChartTitle :: String, + -- ^ This is a title used in HTML. + xyChartDescription :: String, + -- ^ This is a description used in HTML. + xyChartWidth :: Int, + -- ^ The width of the chart. + xyChartHeight :: Int, + -- ^ The height of the chart. + xyChartFileName :: FileName, + -- ^ It defines the file name for each PNG file. + -- It may include special variables @$TITLE@, + -- @$RUN_INDEX@ and @$RUN_COUNT@. + -- + -- An example is + -- + -- @ + -- xyChartFileName = UniqueFileName \"$TITLE - $RUN_INDEX\" \".png\" + -- @ + xyChartPredicate :: Event Bool, + -- ^ It specifies the predicate that defines + -- when we plot data in the chart. + xyChartXSeries :: Maybe String, + -- ^ This is a label of the X series. + -- + -- You must define it, because it is 'Nothing' + -- by default. + xyChartYSeries :: [Either String String], + -- ^ It contains the labels of Y series plotted + -- on the XY chart. + xyChartPlotTitle :: String, + -- ^ This is a title used in the chart when + -- simulating a single run. It may include + -- special variable @$TITLE@. + -- + -- An example is + -- + -- @ + -- xyChartPlotTitle = \"$TITLE\" + -- @ + xyChartRunPlotTitle :: String, + -- ^ The run title for the chart. It is used + -- when simulating multiple runs and it may + -- include special variables @$RUN_INDEX@, + -- @$RUN_COUNT@ and @$PLOT_TITLE@. + -- + -- An example is + -- + -- @ + -- xyChartRunPlotTitle = \"$PLOT_TITLE / Run $RUN_INDEX of $RUN_COUNT\" + -- @ + xyChartPlotLines :: [PlotLines Double Double -> + PlotLines Double Double], + -- ^ Probably, an infinite sequence of plot + -- transformations based on which the plot + -- is constructed for each Y series. Generally, + -- it may not coincide with a sequence of + -- Y labels as one label may denote a whole list + -- or an array of data providers. + -- + -- Here you can define a colour or style of + -- the plot lines. + xyChartBottomAxis :: LayoutAxis Double -> + LayoutAxis Double, + -- ^ A transformation of the bottom axis, + -- after the X title is added. + xyChartLayout :: LayoutLR Double Double Double -> + LayoutLR Double Double Double + -- ^ A transformation of the plot layout, + -- where you can redefine the axes, for example. + } + +-- | The default time series view. +defaultXYChartView :: XYChartView +defaultXYChartView = + XYChartView { xyChartTitle = "XY Chart", + xyChartDescription = "It shows the XY chart(s).", + xyChartWidth = 640, + xyChartHeight = 480, + xyChartFileName = UniqueFileName "$TITLE - $RUN_INDEX" ".png", + xyChartPredicate = return True, + xyChartXSeries = Nothing, + xyChartYSeries = [], + xyChartPlotTitle = "$TITLE", + xyChartRunPlotTitle = "$PLOT_TITLE / Run $RUN_INDEX of $RUN_COUNT", + xyChartPlotLines = colourisePlotLines, + xyChartBottomAxis = id, + xyChartLayout = id } + +instance ExperimentView XYChartView where + + outputView v = + let reporter exp dir = + do st <- newXYChart v exp dir + return ExperimentReporter { reporterInitialise = return (), + reporterFinalise = return (), + reporterSimulate = simulateXYChart st, + reporterTOCHtml = xyChartTOCHtml st, + reporterHtml = xyChartHtml st } + in ExperimentGenerator { generateReporter = reporter } + +-- | The state of the view. +data XYChartViewState = + XYChartViewState { xyChartView :: XYChartView, + xyChartExperiment :: Experiment, + xyChartDir :: FilePath, + xyChartMap :: M.Map Int FilePath } + +-- | Create a new state of the view. +newXYChart :: XYChartView -> Experiment -> FilePath -> IO XYChartViewState +newXYChart view exp dir = + do let n = experimentRunCount exp + fs <- forM [0..(n - 1)] $ \i -> + resolveFileName (Just dir) (xyChartFileName view) $ + M.fromList [("$TITLE", xyChartTitle 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 XYChartViewState { xyChartView = view, + xyChartExperiment = exp, + xyChartDir = dir, + xyChartMap = m } + +-- | Plot the XY chart during the simulation. +simulateXYChart :: XYChartViewState -> ExperimentData -> Event (Event ()) +simulateXYChart st expdata = + do let ylabels = xyChartYSeries $ xyChartView st + xlabels = xyChartXSeries $ xyChartView st + xlabel = flip fromMaybe xlabels $ + error "X series is not provided: simulateXYChart" + (leftYLabels, rightYLabels) = partitionEithers ylabels + leftYProviders = experimentSeriesProviders expdata leftYLabels + rightYProviders = experimentSeriesProviders expdata rightYLabels + xprovider = + case experimentSeriesProviders expdata [xlabel] of + [provider] -> provider + _ -> error $ + "Only a single X series must be" ++ + " provided: simulateXYChart" + providerInput providers = + flip map providers $ \provider -> + case providerToDouble provider of + Nothing -> error $ + "Cannot represent series " ++ + providerName provider ++ + " as double values: simulateXYChart" + Just input -> (providerName provider, provider, input) + leftYInput = providerInput leftYProviders + rightYInput = providerInput rightYProviders + [(xname, _, x)] = providerInput [xprovider] + n = experimentRunCount $ xyChartExperiment st + width = xyChartWidth $ xyChartView st + height = xyChartHeight $ xyChartView st + predicate = xyChartPredicate $ xyChartView st + plotLines = xyChartPlotLines $ xyChartView st + plotBottomAxis = xyChartBottomAxis $ xyChartView st + plotLayout = xyChartLayout $ xyChartView st + i <- liftParameter simulationIndex + let file = fromJust $ M.lookup (i - 1) (xyChartMap st) + title = xyChartTitle $ xyChartView st + plotTitle = + replace "$TITLE" title + (xyChartPlotTitle $ xyChartView st) + runPlotTitle = + if n == 1 + then plotTitle + else replace "$RUN_INDEX" (show i) $ + replace "$RUN_COUNT" (show n) $ + replace "$PLOT_TITLE" plotTitle + (xyChartRunPlotTitle $ xyChartView st) + inputHistory input = + forM input $ \(name, provider, y) -> + let transform () = + do p <- predicate + if p + then liftM2 (,) x y + else return (1/0, 1/0) -- such values will be ignored then + in newSignalHistory $ + mapSignalM transform $ + experimentMixedSignal expdata [provider] <> + experimentMixedSignal expdata [xprovider] + leftHs <- inputHistory leftYInput + rightHs <- inputHistory rightYInput + return $ + do let plots hs input plotLineTails = + do ps <- + forM (zip3 hs input (head plotLineTails)) $ + \(h, (name, provider, input), plotLines) -> + do (ts, zs) <- readSignalHistory h + return $ + toPlot $ + plotLines $ + plot_lines_values .~ filterPlotLinesValues (elems zs) $ + plot_lines_title .~ name $ + def + return (ps, drop (length hs) plotLineTails) + (leftPs, plotLineTails) <- plots leftHs leftYInput (tails plotLines) + (rightPs, plotLineTails) <- plots rightHs rightYInput plotLineTails + let leftPs' = map Left leftPs + rightPs' = map Right rightPs + ps' = leftPs' ++ rightPs' + axis = plotBottomAxis $ + laxis_title .~ providerName xprovider $ + def + updateLeftAxis = + if null leftPs + then layoutlr_left_axis_visibility .~ AxisVisibility False False False + else id + updateRightAxis = + if null rightPs + then layoutlr_right_axis_visibility .~ AxisVisibility False False False + else id + chart = plotLayout . updateLeftAxis . updateRightAxis $ + layoutlr_x_axis .~ axis $ + layoutlr_title .~ runPlotTitle $ + layoutlr_plots .~ ps' $ + def + liftIO $ + do let opts = FileOptions (width, height) PNG + renderableToFile opts (toRenderable chart) file + when (experimentVerbose $ xyChartExperiment st) $ + putStr "Generated file " >> putStrLn file + +-- | Remove the NaN and inifity values. +filterPlotLinesValues :: [(Double, Double)] -> [[(Double, Double)]] +filterPlotLinesValues = + filter (not . null) . + divideBy (\(x, y) -> isNaN x || isInfinite x || isNaN y || isInfinite y) + +-- | Get the HTML code. +xyChartHtml :: XYChartViewState -> Int -> HtmlWriter () +xyChartHtml st index = + let n = experimentRunCount $ xyChartExperiment st + in if n == 1 + then xyChartHtmlSingle st index + else xyChartHtmlMultiple st index + +-- | Get the HTML code for a single run. +xyChartHtmlSingle :: XYChartViewState -> Int -> HtmlWriter () +xyChartHtmlSingle st index = + do header st index + let f = fromJust $ M.lookup 0 (xyChartMap st) + writeHtmlParagraph $ + writeHtmlImage (makeRelative (xyChartDir st) f) + +-- | Get the HTML code for multiple runs. +xyChartHtmlMultiple :: XYChartViewState -> Int -> HtmlWriter () +xyChartHtmlMultiple st index = + do header st index + let n = experimentRunCount $ xyChartExperiment st + forM_ [0..(n - 1)] $ \i -> + let f = fromJust $ M.lookup i (xyChartMap st) + in writeHtmlParagraph $ + writeHtmlImage (makeRelative (xyChartDir st) f) + +header :: XYChartViewState -> Int -> HtmlWriter () +header st index = + do writeHtmlHeader3WithId ("id" ++ show index) $ + writeHtmlText (xyChartTitle $ xyChartView st) + let description = xyChartDescription $ xyChartView st + unless (null description) $ + writeHtmlParagraph $ + writeHtmlText description + +-- | Get the TOC item. +xyChartTOCHtml :: XYChartViewState -> Int -> HtmlWriter () +xyChartTOCHtml st index = + writeHtmlListItem $ + writeHtmlLink ("#id" ++ show index) $ + writeHtmlText (xyChartTitle $ xyChartView st) diff --git a/Simulation/Aivika/Experiment/DeviationChartView.hs b/Simulation/Aivika/Experiment/DeviationChartView.hs deleted file mode 100644 --- a/Simulation/Aivika/Experiment/DeviationChartView.hs +++ /dev/null @@ -1,327 +0,0 @@ - --- | --- Module : Simulation.Aivika.Experiment.DeviationChartView --- Copyright : Copyright (c) 2012-2013, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.6.3 --- --- The module defines 'DeviationChartView' that saves the deviation --- chart in the PNG file. --- - -module Simulation.Aivika.Experiment.DeviationChartView - (DeviationChartView(..), - defaultDeviationChartView) where - -import Control.Monad -import Control.Monad.Trans -import Control.Concurrent.MVar - -import qualified Data.Map as M -import Data.IORef -import Data.Maybe -import Data.Either -import Data.Array -import Data.Array.IO.Safe - -import Data.Accessor - -import System.IO -import System.FilePath - -import Graphics.Rendering.Chart - -import Simulation.Aivika.Experiment -import Simulation.Aivika.Experiment.HtmlWriter -import Simulation.Aivika.Experiment.Utils (divideBy, replace) -import Simulation.Aivika.Experiment.Chart (colourisePlotLines, colourisePlotFillBetween) -import Simulation.Aivika.Experiment.SamplingStatsSource - -import Simulation.Aivika.Specs -import Simulation.Aivika.Simulation -import Simulation.Aivika.Dynamics -import Simulation.Aivika.Event -import Simulation.Aivika.Signal -import Simulation.Aivika.Statistics - --- | Defines the 'View' that saves the deviation chart --- in the PNG file. -data DeviationChartView = - DeviationChartView { deviationChartTitle :: String, - -- ^ This is a title used in HTML. - deviationChartDescription :: String, - -- ^ This is a description used in HTML. - deviationChartWidth :: Int, - -- ^ The width of the chart. - deviationChartHeight :: Int, - -- ^ The height of the chart. - deviationChartFileName :: FileName, - -- ^ It defines the file name for the PNG file. - -- It may include special variable @$TITLE@. - -- - -- An example is - -- - -- @ - -- deviationChartFileName = UniqueFileName \"$TITLE\" \".png\" - -- @ - deviationChartSeries :: [Either String String], - -- ^ It contains the labels of data plotted - -- on the chart. - deviationChartPlotTitle :: String, - -- ^ This is a title used in the chart. - -- It may include special variable @$TITLE@. - -- - -- An example is - -- - -- @ - -- deviationChartPlotTitle = \"$TITLE\" - -- @ - deviationChartPlotLines :: [PlotLines Double Double -> - PlotLines Double Double], - -- ^ Probably, an infinite sequence of plot - -- transformations based on which the plot - -- is constructed for each series. Generally, - -- it may not coincide with a sequence of - -- labels as one label may denote a whole list - -- or an array of data providers. - -- - -- Here you can define a colour or style of - -- the plot lines. - deviationChartPlotFillBetween :: [PlotFillBetween Double Double -> - PlotFillBetween Double Double], - -- ^ Corresponds exactly to 'deviationChartPlotLines' - -- but used for plotting the deviation areas - -- by the rule of 3-sigma, while the former - -- is used for plotting the trends of the - -- random processes. - deviationChartBottomAxis :: LayoutAxis Double -> - LayoutAxis Double, - -- ^ A transformation of the bottom axis, - -- after title @time@ is added. - deviationChartLayout :: Layout1 Double Double -> - Layout1 Double Double - -- ^ A transformation of the plot layout, - -- where you can redefine the axes, for example. - } - --- | The default deviation chart view. -defaultDeviationChartView :: DeviationChartView -defaultDeviationChartView = - DeviationChartView { deviationChartTitle = "Deviation Chart", - deviationChartDescription = "It shows the Deviation chart by rule 3-sigma.", - deviationChartWidth = 640, - deviationChartHeight = 480, - deviationChartFileName = UniqueFileName "$TITLE" ".png", - deviationChartSeries = [], - deviationChartPlotTitle = "$TITLE", - deviationChartPlotLines = colourisePlotLines, - deviationChartPlotFillBetween = colourisePlotFillBetween, - deviationChartBottomAxis = id, - deviationChartLayout = id } - -instance View DeviationChartView where - - outputView v = - let reporter exp dir = - do st <- newDeviationChart v exp dir - return Reporter { reporterInitialise = return (), - reporterFinalise = finaliseDeviationChart st, - reporterSimulate = simulateDeviationChart st, - reporterTOCHtml = deviationChartTOCHtml st, - reporterHtml = deviationChartHtml st } - in Generator { generateReporter = reporter } - --- | The state of the view. -data DeviationChartViewState = - DeviationChartViewState { deviationChartView :: DeviationChartView, - deviationChartExperiment :: Experiment, - deviationChartDir :: FilePath, - deviationChartFile :: IORef (Maybe FilePath), - deviationChartLock :: MVar (), - deviationChartResults :: IORef (Maybe DeviationChartResults) } - --- | The deviation chart item. -data DeviationChartResults = - DeviationChartResults { deviationChartTimes :: IOArray Int Double, - deviationChartNames :: [Either String String], - deviationChartStats :: [IOArray Int (SamplingStats Double)] } - --- | Create a new state of the view. -newDeviationChart :: DeviationChartView -> Experiment -> FilePath -> IO DeviationChartViewState -newDeviationChart view exp dir = - do f <- newIORef Nothing - l <- newMVar () - r <- newIORef Nothing - return DeviationChartViewState { deviationChartView = view, - deviationChartExperiment = exp, - deviationChartDir = dir, - deviationChartFile = f, - deviationChartLock = l, - deviationChartResults = r } - --- | Create new chart results. -newDeviationChartResults :: [Either String String] -> Experiment -> IO DeviationChartResults -newDeviationChartResults names exp = - do let specs = experimentSpecs exp - bnds = integIterationBnds specs - times <- liftIO $ newListArray bnds (integTimes specs) - stats <- forM names $ \_ -> - liftIO $ newArray bnds emptySamplingStats - return DeviationChartResults { deviationChartTimes = times, - deviationChartNames = names, - deviationChartStats = stats } - --- | Simulate the specified series. -simulateDeviationChart :: DeviationChartViewState -> ExperimentData -> Event (Event ()) -simulateDeviationChart st expdata = - do let labels = deviationChartSeries $ deviationChartView st - (leftLabels, rightLabels) = partitionEithers labels - (leftProviders, rightProviders) = - (experimentSeriesProviders expdata leftLabels, - experimentSeriesProviders expdata rightLabels) - providerInput providers = - flip map providers $ \provider -> - case providerToDoubleStatsSource provider of - Nothing -> error $ - "Cannot represent series " ++ - providerName provider ++ - " as a source of double values: simulateDeviationChart" - Just input -> (providerName provider, - provider, - samplingStatsSourceData input) - leftInput = providerInput leftProviders - rightInput = providerInput rightProviders - leftNames = flip map leftInput $ \(x, _, _) -> Left x - rightNames = flip map rightInput $ \(x, _, _) -> Right x - input = leftInput ++ rightInput - names = leftNames ++ rightNames - source = flip map input $ \(_, _, x) -> x - exp = deviationChartExperiment st - lock = deviationChartLock st - results <- liftIO $ readIORef (deviationChartResults st) - case results of - Nothing -> - liftIO $ - do results <- newDeviationChartResults names exp - writeIORef (deviationChartResults st) $ Just results - Just results -> - when (names /= deviationChartNames results) $ - error "Series with different names are returned for different runs: simulateDeviationChart" - results <- liftIO $ fmap fromJust $ readIORef (deviationChartResults st) - let stats = deviationChartStats results - h = experimentSignalInIntegTimes expdata - handleSignal_ h $ \_ -> - do xs <- sequence source - i <- liftDynamics integIteration - liftIO $ withMVar lock $ \() -> - forM_ (zip xs stats) $ \(x, stats) -> - do y <- readArray stats i - let y' = addDataToSamplingStats x y - y' `seq` writeArray stats i y' - return $ return () - --- | Plot the deviation chart after the simulation is complete. -finaliseDeviationChart :: DeviationChartViewState -> IO () -finaliseDeviationChart st = - do let title = deviationChartTitle $ deviationChartView st - plotTitle = - replace "$TITLE" title - (deviationChartPlotTitle $ deviationChartView st) - width = deviationChartWidth $ deviationChartView st - height = deviationChartHeight $ deviationChartView st - plotLines = deviationChartPlotLines $ deviationChartView st - plotFillBetween = deviationChartPlotFillBetween $ deviationChartView st - plotBottomAxis = deviationChartBottomAxis $ deviationChartView st - plotLayout = deviationChartLayout $ deviationChartView st - results <- readIORef $ deviationChartResults st - case results of - Nothing -> return () - Just results -> - do let times = deviationChartTimes results - names = deviationChartNames results - stats = deviationChartStats results - ps1 <- forM (zip3 names stats plotLines) $ \(name, stats, plotLines) -> - do xs <- getAssocs stats - zs <- forM xs $ \(i, stats) -> - do t <- readArray times i - return (t, samplingStatsMean stats) - let p = toPlot $ - plotLines $ - plot_lines_values ^= filterPlotLinesValues zs $ - plot_lines_title ^= either id id name $ - defaultPlotLines - case name of - Left _ -> return $ Left p - Right _ -> return $ Right p - ps2 <- forM (zip3 names stats plotFillBetween) $ \(name, stats, plotFillBetween) -> - do xs <- getAssocs stats - zs <- forM xs $ \(i, stats) -> - do t <- readArray times i - let mu = samplingStatsMean stats - sigma = samplingStatsDeviation stats - return (t, (mu - 3 * sigma, mu + 3 * sigma)) - let p = toPlot $ - plotFillBetween $ - plot_fillbetween_values ^= filterPlotFillBetweenValues zs $ - plot_fillbetween_title ^= either id id name $ - defaultPlotFillBetween - case name of - Left _ -> return $ Left p - Right _ -> return $ Right p - let ps = join $ flip map (zip ps1 ps2) $ \(p1, p2) -> [p2, p1] - axis = plotBottomAxis $ - laxis_title ^= "time" $ - defaultLayoutAxis - chart = plotLayout $ - layout1_bottom_axis ^= axis $ - layout1_title ^= plotTitle $ - layout1_plots ^= ps $ - defaultLayout1 - file <- resolveFileName - (Just $ deviationChartDir st) - (deviationChartFileName $ deviationChartView st) $ - M.fromList [("$TITLE", title)] - renderableToPNGFile (toRenderable chart) width height file - when (experimentVerbose $ deviationChartExperiment st) $ - putStr "Generated file " >> putStrLn file - writeIORef (deviationChartFile st) $ Just file - --- | Remove the NaN and inifity values. -filterPlotLinesValues :: [(Double, Double)] -> [[(Double, Double)]] -filterPlotLinesValues = - filter (not . null) . - divideBy (\(t, x) -> isNaN x || isInfinite x) - --- | Remove the NaN and inifity values. -filterPlotFillBetweenValues :: [(Double, (Double, Double))] -> [(Double, (Double, Double))] -filterPlotFillBetweenValues = - filter $ \(t, (x1, x2)) -> not $ isNaN x1 || isInfinite x1 || isNaN x2 || isInfinite x2 - --- | Get the HTML code. -deviationChartHtml :: DeviationChartViewState -> Int -> HtmlWriter () -deviationChartHtml st index = - do header st index - file <- liftIO $ readIORef (deviationChartFile st) - case file of - Nothing -> return () - Just f -> - writeHtmlParagraph $ - writeHtmlImage (makeRelative (deviationChartDir st) f) - -header :: DeviationChartViewState -> Int -> HtmlWriter () -header st index = - do writeHtmlHeader3WithId ("id" ++ show index) $ - writeHtmlText (deviationChartTitle $ deviationChartView st) - let description = deviationChartDescription $ deviationChartView st - unless (null description) $ - writeHtmlParagraph $ - writeHtmlText description - --- | Get the TOC item. -deviationChartTOCHtml :: DeviationChartViewState -> Int -> HtmlWriter () -deviationChartTOCHtml st index = - writeHtmlListItem $ - writeHtmlLink ("#id" ++ show index) $ - writeHtmlText (deviationChartTitle $ deviationChartView st) diff --git a/Simulation/Aivika/Experiment/FinalHistogramView.hs b/Simulation/Aivika/Experiment/FinalHistogramView.hs deleted file mode 100644 --- a/Simulation/Aivika/Experiment/FinalHistogramView.hs +++ /dev/null @@ -1,277 +0,0 @@ - --- | --- Module : Simulation.Aivika.Experiment.FinalHistogramView --- Copyright : Copyright (c) 2012, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.4.1 --- --- The module defines 'FinalHistogramView' that draws a histogram --- by the specified series in final time points collected from different --- simulation runs. --- - -module Simulation.Aivika.Experiment.FinalHistogramView - (FinalHistogramView(..), - defaultFinalHistogramView) where - -import Control.Monad -import Control.Monad.Trans -import Control.Concurrent.MVar - -import qualified Data.Map as M -import Data.IORef -import Data.Maybe -import Data.Either -import Data.Array -import Data.Array.IO.Safe - -import Data.Accessor - -import System.IO -import System.FilePath - -import Graphics.Rendering.Chart - -import Simulation.Aivika.Experiment -import Simulation.Aivika.Experiment.HtmlWriter -import Simulation.Aivika.Experiment.Utils (divideBy, replace) -import Simulation.Aivika.Experiment.Chart (colourisePlotBars) -import Simulation.Aivika.Experiment.Histogram -import Simulation.Aivika.Experiment.ListSource - -import Simulation.Aivika.Specs -import Simulation.Aivika.Simulation -import Simulation.Aivika.Dynamics -import Simulation.Aivika.Event -import Simulation.Aivika.Signal - --- | Defines the 'View' that saves the histogram --- in the PNG file by the specified series in --- final time points collected from different --- simulation runs. -data FinalHistogramView = - FinalHistogramView { finalHistogramTitle :: String, - -- ^ This is a title used in HTML. - finalHistogramDescription :: String, - -- ^ This is a description used in HTML. - finalHistogramWidth :: Int, - -- ^ The width of the histogram. - finalHistogramHeight :: Int, - -- ^ The height of the histogram. - finalHistogramFileName :: FileName, - -- ^ It defines the file name for the PNG file. - -- It may include special variable @$TITLE@. - -- - -- An example is - -- - -- @ - -- finalHistogramFileName = UniqueFileName \"$TITLE\" \".png\" - -- @ - finalHistogramPredicate :: Event Bool, - -- ^ It specifies the predicate that defines - -- when we count data when plotting the histogram. - finalHistogramBuild :: [[Double]] -> Histogram, - -- ^ Builds a histogram by the specified list of - -- data series. - finalHistogramSeries :: [String], - -- ^ It contains the labels of data plotted - -- on the histogram. - finalHistogramPlotTitle :: String, - -- ^ This is a title used in the histogram. - -- It may include special variable @$TITLE@. - -- - -- An example is - -- - -- @ - -- finalHistogramPlotTitle = \"$TITLE\" - -- @ - finalHistogramPlotBars :: PlotBars Double Double -> - PlotBars Double Double, - -- ^ A transformation based on which the plot bar - -- is constructed for the series. - -- - -- Here you can define a colour or style of - -- the plot bars. - finalHistogramLayout :: Layout1 Double Double -> - Layout1 Double Double - -- ^ A transformation of the plot layout, - -- where you can redefine the axes, for example. - } - --- | The default histogram view. -defaultFinalHistogramView :: FinalHistogramView -defaultFinalHistogramView = - FinalHistogramView { finalHistogramTitle = "Final Histogram", - finalHistogramDescription = "It shows a histogram by data gathered in the final time points.", - finalHistogramWidth = 640, - finalHistogramHeight = 480, - finalHistogramFileName = UniqueFileName "$TITLE" ".png", - finalHistogramPredicate = return True, - finalHistogramBuild = histogram binSturges, - finalHistogramSeries = [], - finalHistogramPlotTitle = "$TITLE", - finalHistogramPlotBars = colourisePlotBars, - finalHistogramLayout = id } - -instance View FinalHistogramView where - - outputView v = - let reporter exp dir = - do st <- newFinalHistogram v exp dir - return Reporter { reporterInitialise = return (), - reporterFinalise = finaliseFinalHistogram st, - reporterSimulate = simulateFinalHistogram st, - reporterTOCHtml = finalHistogramTOCHtml st, - reporterHtml = finalHistogramHtml st } - in Generator { generateReporter = reporter } - --- | The state of the view. -data FinalHistogramViewState = - FinalHistogramViewState { finalHistogramView :: FinalHistogramView, - finalHistogramExperiment :: Experiment, - finalHistogramDir :: FilePath, - finalHistogramFile :: IORef (Maybe FilePath), - finalHistogramLock :: MVar (), - finalHistogramResults :: IORef (Maybe FinalHistogramResults) } - --- | The histogram item. -data FinalHistogramResults = - FinalHistogramResults { finalHistogramNames :: [String], - finalHistogramValues :: [ListRef Double] } - --- | Create a new state of the view. -newFinalHistogram :: FinalHistogramView -> Experiment -> FilePath -> IO FinalHistogramViewState -newFinalHistogram view exp dir = - do f <- newIORef Nothing - l <- newMVar () - r <- newIORef Nothing - return FinalHistogramViewState { finalHistogramView = view, - finalHistogramExperiment = exp, - finalHistogramDir = dir, - finalHistogramFile = f, - finalHistogramLock = l, - finalHistogramResults = r } - --- | Create new histogram results. -newFinalHistogramResults :: [String] -> Experiment -> IO FinalHistogramResults -newFinalHistogramResults names exp = - do values <- forM names $ \_ -> liftIO newListRef - return FinalHistogramResults { finalHistogramNames = names, - finalHistogramValues = values } - --- | Simulation of the specified series. -simulateFinalHistogram :: FinalHistogramViewState -> ExperimentData -> Event (Event ()) -simulateFinalHistogram st expdata = - do let labels = finalHistogramSeries $ finalHistogramView st - providers = experimentSeriesProviders expdata labels - input = - flip map providers $ \provider -> - case providerToDoubleListSource provider of - Nothing -> error $ - "Cannot represent series " ++ - providerName provider ++ - " as a source of double values: simulateFinalHistogram" - Just input -> listSourceData input - names = map providerName providers - predicate = finalHistogramPredicate $ finalHistogramView st - exp = finalHistogramExperiment st - lock = finalHistogramLock st - results <- liftIO $ readIORef (finalHistogramResults st) - case results of - Nothing -> - liftIO $ - do results <- newFinalHistogramResults names exp - writeIORef (finalHistogramResults st) $ Just results - Just results -> - when (names /= finalHistogramNames results) $ - error "Series with different names are returned for different runs: simulateFinalHistogram" - results <- liftIO $ fmap fromJust $ readIORef (finalHistogramResults st) - let values = finalHistogramValues results - h = filterSignalM (const predicate) $ - experimentSignalInStopTime expdata - handleSignal_ h $ \_ -> - do xs <- sequence input - liftIO $ withMVar lock $ \() -> - forM_ (zip xs values) $ \(x, values) -> - addDataToListRef values x - return $ return () - --- | Plot the histogram after the simulation is complete. -finaliseFinalHistogram :: FinalHistogramViewState -> IO () -finaliseFinalHistogram st = - do let title = finalHistogramTitle $ finalHistogramView st - plotTitle = - replace "$TITLE" title - (finalHistogramPlotTitle $ finalHistogramView st) - width = finalHistogramWidth $ finalHistogramView st - height = finalHistogramHeight $ finalHistogramView st - histogram = finalHistogramBuild $ finalHistogramView st - bars = finalHistogramPlotBars $ finalHistogramView st - layout = finalHistogramLayout $ finalHistogramView st - results <- readIORef $ finalHistogramResults st - case results of - Nothing -> return () - Just results -> - do let names = finalHistogramNames results - values = finalHistogramValues results - xs <- forM values readListRef - let zs = histogramToBars . filterHistogram . histogram $ - map filterData xs - p = plotBars $ - bars $ - plot_bars_values ^= zs $ - plot_bars_titles ^= names $ - defaultPlotBars - let chart = layout $ - layout1_title ^= plotTitle $ - layout1_plots ^= [Left p] $ - defaultLayout1 - file <- resolveFileName - (Just $ finalHistogramDir st) - (finalHistogramFileName $ finalHistogramView st) $ - M.fromList [("$TITLE", title)] - renderableToPNGFile (toRenderable chart) width height file - when (experimentVerbose $ finalHistogramExperiment st) $ - putStr "Generated file " >> putStrLn file - writeIORef (finalHistogramFile st) $ Just file - --- | Remove the NaN and inifity values. -filterData :: [Double] -> [Double] -filterData = filter (\x -> not $ isNaN x || isInfinite x) - --- | Remove the NaN and inifity values. -filterHistogram :: [(Double, a)] -> [(Double, a)] -filterHistogram = filter (\(x, _) -> not $ isNaN x || isInfinite x) - --- | Convert a histogram to the bars. -histogramToBars :: [(Double, [Int])] -> [(Double, [Double])] -histogramToBars = map $ \(x, ns) -> (x, map fromIntegral ns) - --- | Get the HTML code. -finalHistogramHtml :: FinalHistogramViewState -> Int -> HtmlWriter () -finalHistogramHtml st index = - do header st index - file <- liftIO $ readIORef (finalHistogramFile st) - case file of - Nothing -> return () - Just f -> - writeHtmlParagraph $ - writeHtmlImage (makeRelative (finalHistogramDir st) f) - -header :: FinalHistogramViewState -> Int -> HtmlWriter () -header st index = - do writeHtmlHeader3WithId ("id" ++ show index) $ - writeHtmlText (finalHistogramTitle $ finalHistogramView st) - let description = finalHistogramDescription $ finalHistogramView st - unless (null description) $ - writeHtmlParagraph $ - writeHtmlText description - --- | Get the TOC item. -finalHistogramTOCHtml :: FinalHistogramViewState -> Int -> HtmlWriter () -finalHistogramTOCHtml st index = - writeHtmlListItem $ - writeHtmlLink ("#id" ++ show index) $ - writeHtmlText (finalHistogramTitle $ finalHistogramView st) diff --git a/Simulation/Aivika/Experiment/FinalXYChartView.hs b/Simulation/Aivika/Experiment/FinalXYChartView.hs deleted file mode 100644 --- a/Simulation/Aivika/Experiment/FinalXYChartView.hs +++ /dev/null @@ -1,317 +0,0 @@ - --- | --- Module : Simulation.Aivika.Experiment.FinalXYChartView --- Copyright : Copyright (c) 2012, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.4.1 --- --- The module defines 'FinalXYChartView' that saves the XY chart --- by final time points for all simulation runs sequentially. --- - -module Simulation.Aivika.Experiment.FinalXYChartView - (FinalXYChartView(..), - defaultFinalXYChartView) where - -import Control.Monad -import Control.Monad.Trans -import Control.Concurrent.MVar - -import qualified Data.Map as M -import Data.IORef -import Data.Maybe -import Data.Either -import Data.Array -import Data.Array.IO.Safe - -import Data.Accessor - -import System.IO -import System.FilePath - -import Graphics.Rendering.Chart - -import Simulation.Aivika.Experiment -import Simulation.Aivika.Experiment.HtmlWriter -import Simulation.Aivika.Experiment.Utils (divideBy, replace) -import Simulation.Aivika.Experiment.Chart (colourisePlotLines) - -import Simulation.Aivika.Specs -import Simulation.Aivika.Simulation -import Simulation.Aivika.Dynamics -import Simulation.Aivika.Event -import Simulation.Aivika.Signal - --- | Defines the 'View' that saves the XY chart --- in the PNG file by final time points for all --- simulation runs sequentially. -data FinalXYChartView = - FinalXYChartView { finalXYChartTitle :: String, - -- ^ This is a title used HTML. - finalXYChartDescription :: String, - -- ^ This is a description used in HTML. - finalXYChartWidth :: Int, - -- ^ The width of the chart. - finalXYChartHeight :: Int, - -- ^ The height of the chart. - finalXYChartFileName :: FileName, - -- ^ It defines the file name for the PNG file. - -- It may include special variable @$TITLE@. - -- - -- An example is - -- - -- @ - -- finalXYChartFileName = UniqueFileName \"$TITLE\" \".png\" - -- @ - finalXYChartPredicate :: Event Bool, - -- ^ It specifies the predicate that defines - -- when we count data when plotting the chart. - finalXYChartXSeries :: Maybe String, - -- ^ It defines a label of the single X series. - -- - -- You must define it, because it is 'Nothing' - -- by default. - finalXYChartYSeries :: [Either String String], - -- ^ It contains the labels of Y series plotted - -- on the chart. - finalXYChartPlotTitle :: String, - -- ^ This is a title used in the chart. - -- It may include special variable @$TITLE@. - -- - -- An example is - -- - -- @ - -- finalXYChartPlotTitle = \"$TITLE\" - -- @ - finalXYChartPlotLines :: [PlotLines Double Double -> - PlotLines Double Double], - -- ^ Probably, an infinite sequence of plot - -- transformations based on which the plot - -- is constructed for each series. Generally, - -- it may not coincide with a sequence of - -- labels as one label may denote a whole list - -- or an array of data providers. - -- - -- Here you can define a colour or style of - -- the plot lines. - finalXYChartBottomAxis :: LayoutAxis Double -> - LayoutAxis Double, - -- ^ A transformation of the bottom axis, - -- after the X title is added. - finalXYChartLayout :: Layout1 Double Double -> - Layout1 Double Double - -- ^ A transformation of the plot layout, - -- where you can redefine the axes, for example. - } - --- | The default XY chart view. -defaultFinalXYChartView :: FinalXYChartView -defaultFinalXYChartView = - FinalXYChartView { finalXYChartTitle = "Final XY Chart", - finalXYChartDescription = "It shows the XY chart for the results in the final time points.", - finalXYChartWidth = 640, - finalXYChartHeight = 480, - finalXYChartFileName = UniqueFileName "$TITLE" ".png", - finalXYChartPredicate = return True, - finalXYChartXSeries = Nothing, - finalXYChartYSeries = [], - finalXYChartPlotTitle = "$TITLE", - finalXYChartPlotLines = colourisePlotLines, - finalXYChartBottomAxis = id, - finalXYChartLayout = id } - -instance View FinalXYChartView where - - outputView v = - let reporter exp dir = - do st <- newFinalXYChart v exp dir - return Reporter { reporterInitialise = return (), - reporterFinalise = finaliseFinalXYChart st, - reporterSimulate = simulateFinalXYChart st, - reporterTOCHtml = finalXYChartTOCHtml st, - reporterHtml = finalXYChartHtml st } - in Generator { generateReporter = reporter } - --- | The state of the view. -data FinalXYChartViewState = - FinalXYChartViewState { finalXYChartView :: FinalXYChartView, - finalXYChartExperiment :: Experiment, - finalXYChartDir :: FilePath, - finalXYChartFile :: IORef (Maybe FilePath), - finalXYChartLock :: MVar (), - finalXYChartResults :: IORef (Maybe FinalXYChartResults) } - --- | The XY chart results. -data FinalXYChartResults = - FinalXYChartResults { finalXYChartXName :: String, - finalXYChartYNames :: [Either String String], - finalXYChartXY :: [IOArray Int (Maybe (Double, Double))] } - --- | Create a new state of the view. -newFinalXYChart :: FinalXYChartView -> Experiment -> FilePath -> IO FinalXYChartViewState -newFinalXYChart view exp dir = - do f <- newIORef Nothing - l <- newMVar () - r <- newIORef Nothing - return FinalXYChartViewState { finalXYChartView = view, - finalXYChartExperiment = exp, - finalXYChartDir = dir, - finalXYChartFile = f, - finalXYChartLock = l, - finalXYChartResults = r } - --- | Create new chart results. -newFinalXYChartResults :: String -> [Either String String] -> Experiment -> IO FinalXYChartResults -newFinalXYChartResults xname ynames exp = - do let n = experimentRunCount exp - xy <- forM ynames $ \_ -> - liftIO $ newArray (1, n) Nothing - return FinalXYChartResults { finalXYChartXName = xname, - finalXYChartYNames = ynames, - finalXYChartXY = xy } - --- | Simulation. -simulateFinalXYChart :: FinalXYChartViewState -> ExperimentData -> Event (Event ()) -simulateFinalXYChart st expdata = - do let ylabels = finalXYChartYSeries $ finalXYChartView st - xlabels = finalXYChartXSeries $ finalXYChartView st - xlabel = flip fromMaybe xlabels $ - error "X series is not provided: simulateFinalXYChart" - (leftYLabels, rightYLabels) = partitionEithers ylabels - leftYProviders = experimentSeriesProviders expdata leftYLabels - rightYProviders = experimentSeriesProviders expdata rightYLabels - xprovider = - case experimentSeriesProviders expdata [xlabel] of - [provider] -> provider - _ -> error $ - "Only a single X series must be" ++ - " provided: simulateFinalXYChart" - providerInput providers = - flip map providers $ \provider -> - case providerToDouble provider of - Nothing -> error $ - "Cannot represent series " ++ - providerName provider ++ - " as double values: simulateFinalXYChart" - Just input -> (providerName provider, input) - leftYInput = providerInput leftYProviders - rightYInput = providerInput rightYProviders - yinput = leftYInput ++ rightYInput - [xinput] = providerInput [xprovider] - leftYNames = map (Left . fst) leftYInput - rightYNames = map (Right . fst) rightYInput - ynames = leftYNames ++ rightYNames - xname = fst xinput - ys = map snd yinput - x = snd xinput - predicate = finalXYChartPredicate $ finalXYChartView st - exp = finalXYChartExperiment st - lock = finalXYChartLock st - results <- liftIO $ readIORef (finalXYChartResults st) - case results of - Nothing -> - liftIO $ - do results <- newFinalXYChartResults xname ynames exp - writeIORef (finalXYChartResults st) $ Just results - Just results -> - let diffnames = - (xname /= finalXYChartXName results) || - (ynames /= finalXYChartYNames results) - in when diffnames $ - error "Series with different names are returned for different runs: simulateFinalXYChart" - results <- liftIO $ fmap fromJust $ readIORef (finalXYChartResults st) - let xys = finalXYChartXY results - h = filterSignalM (const predicate) $ - experimentSignalInStopTime expdata - handleSignal_ h $ \_ -> - do x' <- x - ys' <- sequence ys - i <- liftSimulation simulationIndex - liftIO $ withMVar lock $ \() -> - forM_ (zip ys' xys) $ \(y', xy) -> - x' `seq` y' `seq` writeArray xy i $ Just (x', y') - return $ return () - --- | Plot the XY chart after the simulation is complete. -finaliseFinalXYChart :: FinalXYChartViewState -> IO () -finaliseFinalXYChart st = - do let title = finalXYChartTitle $ finalXYChartView st - plotTitle = - replace "$TITLE" title - (finalXYChartPlotTitle $ finalXYChartView st) - width = finalXYChartWidth $ finalXYChartView st - height = finalXYChartHeight $ finalXYChartView st - plotLines = finalXYChartPlotLines $ finalXYChartView st - plotBottomAxis = finalXYChartBottomAxis $ finalXYChartView st - plotLayout = finalXYChartLayout $ finalXYChartView st - results <- readIORef $ finalXYChartResults st - case results of - Nothing -> return () - Just results -> - do let xname = finalXYChartXName results - ynames = finalXYChartYNames results - xys = finalXYChartXY results - ps <- forM (zip3 ynames xys plotLines) $ \(name, xy, plotLines) -> - do zs <- getElems xy - let p = toPlot $ - plotLines $ - plot_lines_values ^= filterPlotLinesValues zs $ - plot_lines_title ^= either id id name $ - defaultPlotLines - r = case name of - Left _ -> Left p - Right _ -> Right p - return r - let axis = plotBottomAxis $ - laxis_title ^= xname $ - defaultLayoutAxis - chart = plotLayout $ - layout1_bottom_axis ^= axis $ - layout1_title ^= plotTitle $ - layout1_plots ^= ps $ - defaultLayout1 - file <- resolveFileName - (Just $ finalXYChartDir st) - (finalXYChartFileName $ finalXYChartView st) $ - M.fromList [("$TITLE", title)] - renderableToPNGFile (toRenderable chart) width height file - when (experimentVerbose $ finalXYChartExperiment st) $ - putStr "Generated file " >> putStrLn file - writeIORef (finalXYChartFile st) $ Just file - --- | Remove the NaN and inifity values. -filterPlotLinesValues :: [Maybe (Double, Double)] -> [[(Double, Double)]] -filterPlotLinesValues = - filter (not . null) . map (map fromJust) . divideBy pred - where pred Nothing = True - pred (Just (x, y)) = isNaN x || isInfinite x || - isNaN y || isInfinite y - --- | Get the HTML code. -finalXYChartHtml :: FinalXYChartViewState -> Int -> HtmlWriter () -finalXYChartHtml st index = - do header st index - file <- liftIO $ readIORef (finalXYChartFile st) - case file of - Nothing -> return () - Just f -> - writeHtmlParagraph $ - writeHtmlImage (makeRelative (finalXYChartDir st) f) - -header :: FinalXYChartViewState -> Int -> HtmlWriter () -header st index = - do writeHtmlHeader3WithId ("id" ++ show index) $ - writeHtmlText (finalXYChartTitle $ finalXYChartView st) - let description = finalXYChartDescription $ finalXYChartView st - unless (null description) $ - writeHtmlParagraph $ - writeHtmlText description - --- | Get the TOC item. -finalXYChartTOCHtml :: FinalXYChartViewState -> Int -> HtmlWriter () -finalXYChartTOCHtml st index = - writeHtmlListItem $ - writeHtmlLink ("#id" ++ show index) $ - writeHtmlText (finalXYChartTitle $ finalXYChartView st) diff --git a/Simulation/Aivika/Experiment/HistogramView.hs b/Simulation/Aivika/Experiment/HistogramView.hs deleted file mode 100644 --- a/Simulation/Aivika/Experiment/HistogramView.hs +++ /dev/null @@ -1,272 +0,0 @@ - --- | --- Module : Simulation.Aivika.Experiment.HistogramView --- Copyright : Copyright (c) 2012, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.4.1 --- --- The module defines 'HistogramView' that saves the histogram --- in the PNG files by all integration time points for each --- simulation run separately. --- - -module Simulation.Aivika.Experiment.HistogramView - (HistogramView(..), - defaultHistogramView) where - -import Control.Monad -import Control.Monad.Trans - -import qualified Data.Map as M -import Data.IORef -import Data.Maybe -import Data.Either -import Data.Array - -import Data.Accessor - -import System.IO -import System.FilePath - -import Graphics.Rendering.Chart - -import Simulation.Aivika.Experiment -import Simulation.Aivika.Experiment.HtmlWriter -import Simulation.Aivika.Experiment.Utils (divideBy, replace) -import Simulation.Aivika.Experiment.Chart (colourisePlotBars) -import Simulation.Aivika.Experiment.Histogram -import Simulation.Aivika.Experiment.ListSource - -import Simulation.Aivika.Specs -import Simulation.Aivika.Simulation -import Simulation.Aivika.Event -import Simulation.Aivika.Signal - --- | Defines the 'View' that saves the histogram in --- the PNG files by all integration time points for --- each simulation run separately. -data HistogramView = - HistogramView { histogramTitle :: String, - -- ^ This is a title used in HTML. - histogramDescription :: String, - -- ^ This is a description used in HTML. - histogramWidth :: Int, - -- ^ The width of the histogram. - histogramHeight :: Int, - -- ^ The height of the histogram. - histogramFileName :: FileName, - -- ^ It defines the file name for each PNG file. - -- It may include special variables @$TITLE@, - -- @$RUN_INDEX@ and @$RUN_COUNT@. - -- - -- An example is - -- - -- @ - -- histogramFileName = UniqueFileName \"$TITLE - $RUN_INDEX\" \".png\" - -- @ - histogramPredicate :: Event Bool, - -- ^ It specifies the predicate that defines - -- when we count data when plotting the histogram. - histogramBuild :: [[Double]] -> Histogram, - -- ^ Builds a histogram by the specified list of - -- data series. - histogramSeries :: [String], - -- ^ It contains the labels of data for which - -- the histogram is plotted. - histogramPlotTitle :: String, - -- ^ This is a title used in the histogram when - -- simulating a single run. It may include - -- special variable @$TITLE@. - -- - -- An example is - -- - -- @ - -- histogramPlotTitle = \"$TITLE\" - -- @ - histogramRunPlotTitle :: String, - -- ^ The run title for the histogram. It is used - -- when simulating multiple runs and it may - -- include special variables @$RUN_INDEX@, - -- @$RUN_COUNT@ and @$PLOT_TITLE@. - -- - -- An example is - -- - -- @ - -- histogramRunPlotTitle = \"$PLOT_TITLE / Run $RUN_INDEX of $RUN_COUNT\" - -- @ - histogramPlotBars :: PlotBars Double Double -> - PlotBars Double Double, - -- ^ A transformation based on which the plot bar - -- is constructed for the series. - -- - -- Here you can define a colour or style of - -- the plot bars. - histogramLayout :: Layout1 Double Double -> - Layout1 Double Double - -- ^ A transformation of the plot layout, - -- where you can redefine the axes, for example. - } - --- | The default histogram view. -defaultHistogramView :: HistogramView -defaultHistogramView = - HistogramView { histogramTitle = "Histogram", - histogramDescription = "It shows the histogram(s) by data gathered in the integration time points.", - histogramWidth = 640, - histogramHeight = 480, - histogramFileName = UniqueFileName "$TITLE - $RUN_INDEX" ".png", - histogramPredicate = return True, - histogramBuild = histogram binSturges, - histogramSeries = [], - histogramPlotTitle = "$TITLE", - histogramRunPlotTitle = "$PLOT_TITLE / Run $RUN_INDEX of $RUN_COUNT", - histogramPlotBars = colourisePlotBars, - histogramLayout = id } - -instance View HistogramView where - - outputView v = - let reporter exp dir = - do st <- newHistogram v exp dir - return Reporter { reporterInitialise = return (), - reporterFinalise = return (), - reporterSimulate = simulateHistogram st, - reporterTOCHtml = histogramTOCHtml st, - reporterHtml = histogramHtml st } - in Generator { generateReporter = reporter } - --- | The state of the view. -data HistogramViewState = - HistogramViewState { histogramView :: HistogramView, - histogramExperiment :: Experiment, - histogramDir :: FilePath, - histogramMap :: M.Map Int FilePath } - --- | Create a new state of the view. -newHistogram :: HistogramView -> Experiment -> FilePath -> IO HistogramViewState -newHistogram view exp dir = - do let n = experimentRunCount exp - fs <- forM [0..(n - 1)] $ \i -> - resolveFileName (Just dir) (histogramFileName view) $ - M.fromList [("$TITLE", histogramTitle 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 HistogramViewState { histogramView = view, - histogramExperiment = exp, - histogramDir = dir, - histogramMap = m } - --- | Plot the histogram during the simulation. -simulateHistogram :: HistogramViewState -> ExperimentData -> Event (Event ()) -simulateHistogram st expdata = - do let labels = histogramSeries $ histogramView st - providers = experimentSeriesProviders expdata labels - names = map providerName providers - input = - flip map providers $ \provider -> - case providerToDoubleListSource provider of - Nothing -> error $ - "Cannot represent series " ++ - providerName provider ++ - " as a source of double values: simulateHistogram" - Just input -> fmap listDataList $ listSourceData input - n = experimentRunCount $ histogramExperiment st - width = histogramWidth $ histogramView st - height = histogramHeight $ histogramView st - predicate = histogramPredicate $ histogramView st - bars = histogramPlotBars $ histogramView st - layout = histogramLayout $ histogramView st - build = histogramBuild $ histogramView st - i <- liftSimulation simulationIndex - let file = fromJust $ M.lookup (i - 1) (histogramMap st) - title = histogramTitle $ histogramView st - plotTitle = - replace "$TITLE" title - (histogramPlotTitle $ histogramView st) - runPlotTitle = - if n == 1 - then plotTitle - else replace "$RUN_INDEX" (show i) $ - replace "$RUN_COUNT" (show n) $ - replace "$PLOT_TITLE" plotTitle - (histogramRunPlotTitle $ histogramView st) - hs <- forM (zip providers input) $ \(provider, input) -> - newSignalHistory $ - mapSignalM (const input) $ - filterSignalM (const predicate) $ - experimentSignalInIntegTimes expdata - return $ - do xs <- forM hs readSignalHistory - let zs = histogramToBars . filterHistogram . build $ - map (filterData . concat . elems . snd) xs - p = plotBars $ - bars $ - plot_bars_values ^= zs $ - plot_bars_titles ^= names $ - defaultPlotBars - chart = layout $ - layout1_title ^= runPlotTitle $ - layout1_plots ^= [Left p] $ - defaultLayout1 - liftIO $ - do renderableToPNGFile (toRenderable chart) width height file - when (experimentVerbose $ histogramExperiment st) $ - putStr "Generated file " >> putStrLn file - --- | Remove the NaN and inifity values. -filterData :: [Double] -> [Double] -filterData = filter (\x -> not $ isNaN x || isInfinite x) - --- | Remove the NaN and inifity values. -filterHistogram :: [(Double, a)] -> [(Double, a)] -filterHistogram = filter (\(x, _) -> not $ isNaN x || isInfinite x) - --- | Convert a histogram to the bars. -histogramToBars :: [(Double, [Int])] -> [(Double, [Double])] -histogramToBars = map $ \(x, ns) -> (x, map fromIntegral ns) - --- | Get the HTML code. -histogramHtml :: HistogramViewState -> Int -> HtmlWriter () -histogramHtml st index = - let n = experimentRunCount $ histogramExperiment st - in if n == 1 - then histogramHtmlSingle st index - else histogramHtmlMultiple st index - --- | Get the HTML code for a single run. -histogramHtmlSingle :: HistogramViewState -> Int -> HtmlWriter () -histogramHtmlSingle st index = - do header st index - let f = fromJust $ M.lookup 0 (histogramMap st) - writeHtmlParagraph $ - writeHtmlImage (makeRelative (histogramDir st) f) - --- | Get the HTML code for multiple runs. -histogramHtmlMultiple :: HistogramViewState -> Int -> HtmlWriter () -histogramHtmlMultiple st index = - do header st index - let n = experimentRunCount $ histogramExperiment st - forM_ [0..(n - 1)] $ \i -> - let f = fromJust $ M.lookup i (histogramMap st) - in writeHtmlParagraph $ - writeHtmlImage (makeRelative (histogramDir st) f) - -header :: HistogramViewState -> Int -> HtmlWriter () -header st index = - do writeHtmlHeader3WithId ("id" ++ show index) $ - writeHtmlText (histogramTitle $ histogramView st) - let description = histogramDescription $ histogramView st - unless (null description) $ - writeHtmlParagraph $ - writeHtmlText description - --- | Get the TOC item. -histogramTOCHtml :: HistogramViewState -> Int -> HtmlWriter () -histogramTOCHtml st index = - writeHtmlListItem $ - writeHtmlLink ("#id" ++ show index) $ - writeHtmlText (histogramTitle $ histogramView st) diff --git a/Simulation/Aivika/Experiment/TimeSeriesView.hs b/Simulation/Aivika/Experiment/TimeSeriesView.hs deleted file mode 100644 --- a/Simulation/Aivika/Experiment/TimeSeriesView.hs +++ /dev/null @@ -1,290 +0,0 @@ - --- | --- Module : Simulation.Aivika.Experiment.TimeSeriesView --- Copyright : Copyright (c) 2012, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.4.1 --- --- The module defines 'TimeSeriesView' that saves the time series --- charts as the PNG files. --- - -module Simulation.Aivika.Experiment.TimeSeriesView - (TimeSeriesView(..), - defaultTimeSeriesView) where - -import Control.Monad -import Control.Monad.Trans - -import qualified Data.Map as M -import Data.IORef -import Data.Maybe -import Data.Either -import Data.Array -import Data.List - -import Data.Accessor - -import System.IO -import System.FilePath - -import Graphics.Rendering.Chart - -import Simulation.Aivika.Experiment -import Simulation.Aivika.Experiment.HtmlWriter -import Simulation.Aivika.Experiment.Utils (divideBy, replace) -import Simulation.Aivika.Experiment.Chart (colourisePlotLines) - -import Simulation.Aivika.Specs -import Simulation.Aivika.Simulation -import Simulation.Aivika.Event -import Simulation.Aivika.Signal - --- | Defines the 'View' that saves the time series charts --- in the PNG files. -data TimeSeriesView = - TimeSeriesView { timeSeriesTitle :: String, - -- ^ This is a title used in HTML. - timeSeriesDescription :: String, - -- ^ This is a description used in HTML. - timeSeriesWidth :: Int, - -- ^ The width of the chart. - timeSeriesHeight :: Int, - -- ^ The height of the chart. - timeSeriesFileName :: FileName, - -- ^ It defines the file name for each PNG file. - -- It may include special variables @$TITLE@, - -- @$RUN_INDEX@ and @$RUN_COUNT@. - -- - -- An example is - -- - -- @ - -- timeSeriesFileName = UniqueFileName \"$TITLE - $RUN_INDEX\" \".png\" - -- @ - timeSeriesPredicate :: Event Bool, - -- ^ It specifies the predicate that defines - -- when we plot data in the chart. - timeSeries :: [Either String String], - -- ^ It contains the labels of data plotted - -- on the chart. - timeSeriesPlotTitle :: String, - -- ^ This is a title used in the chart when - -- simulating a single run. It may include - -- special variable @$TITLE@. - -- - -- An example is - -- - -- @ - -- timeSeriesPlotTitle = \"$TITLE\" - -- @ - timeSeriesRunPlotTitle :: String, - -- ^ The run title for the chart. It is used - -- when simulating multiple runs and it may - -- include special variables @$RUN_INDEX@, - -- @$RUN_COUNT@ and @$PLOT_TITLE@. - -- - -- An example is - -- - -- @ - -- timeSeriesRunPlotTitle = \"$PLOT_TITLE / Run $RUN_INDEX of $RUN_COUNT\" - -- @ - timeSeriesPlotLines :: [PlotLines Double Double -> - PlotLines Double Double], - -- ^ Probably, an infinite sequence of plot - -- transformations based on which the plot - -- is constructed for each series. Generally, - -- it must not coincide with a sequence of - -- labels as one label may denote a whole list - -- or an array of data providers. - -- - -- Here you can define a colour or style of - -- the plot lines. - timeSeriesBottomAxis :: LayoutAxis Double -> - LayoutAxis Double, - -- ^ A transformation of the bottom axis, - -- after title @time@ is added. - timeSeriesLayout :: Layout1 Double Double -> - Layout1 Double Double - -- ^ A transformation of the plot layout, - -- where you can redefine the axes, for example. - } - --- | The default time series view. -defaultTimeSeriesView :: TimeSeriesView -defaultTimeSeriesView = - TimeSeriesView { timeSeriesTitle = "Time Series", - timeSeriesDescription = "It shows the Time Series chart(s).", - timeSeriesWidth = 640, - timeSeriesHeight = 480, - timeSeriesFileName = UniqueFileName "$TITLE - $RUN_INDEX" ".png", - timeSeriesPredicate = return True, - timeSeries = [], - timeSeriesPlotTitle = "$TITLE", - timeSeriesRunPlotTitle = "$PLOT_TITLE / Run $RUN_INDEX of $RUN_COUNT", - timeSeriesPlotLines = colourisePlotLines, - timeSeriesBottomAxis = id, - timeSeriesLayout = id } - -instance View TimeSeriesView where - - outputView v = - let reporter exp dir = - do st <- newTimeSeries v exp dir - return Reporter { reporterInitialise = return (), - reporterFinalise = return (), - reporterSimulate = simulateTimeSeries st, - reporterTOCHtml = timeSeriesTOCHtml st, - reporterHtml = timeSeriesHtml st } - in Generator { generateReporter = reporter } - --- | The state of the view. -data TimeSeriesViewState = - TimeSeriesViewState { timeSeriesView :: TimeSeriesView, - timeSeriesExperiment :: Experiment, - timeSeriesDir :: FilePath, - timeSeriesMap :: M.Map Int FilePath } - --- | Create a new state of the view. -newTimeSeries :: TimeSeriesView -> Experiment -> FilePath -> IO TimeSeriesViewState -newTimeSeries view exp dir = - do let n = experimentRunCount exp - fs <- forM [0..(n - 1)] $ \i -> - resolveFileName (Just dir) (timeSeriesFileName view) $ - M.fromList [("$TITLE", timeSeriesTitle 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 TimeSeriesViewState { timeSeriesView = view, - timeSeriesExperiment = exp, - timeSeriesDir = dir, - timeSeriesMap = m } - --- | Plot the time series chart during the simulation. -simulateTimeSeries :: TimeSeriesViewState -> ExperimentData -> Event (Event ()) -simulateTimeSeries st expdata = - do let labels = timeSeries $ timeSeriesView st - (leftLabels, rightLabels) = partitionEithers labels - (leftProviders, rightProviders) = - (experimentSeriesProviders expdata leftLabels, - experimentSeriesProviders expdata rightLabels) - providerInput providers = - flip map providers $ \provider -> - case providerToDouble provider of - Nothing -> error $ - "Cannot represent series " ++ - providerName provider ++ - " as double values: simulateTimeSeries" - Just input -> (providerName provider, provider, input) - leftInput = providerInput leftProviders - rightInput = providerInput rightProviders - n = experimentRunCount $ timeSeriesExperiment st - width = timeSeriesWidth $ timeSeriesView st - height = timeSeriesHeight $ timeSeriesView st - predicate = timeSeriesPredicate $ timeSeriesView st - plotLines = timeSeriesPlotLines $ timeSeriesView st - plotBottomAxis = timeSeriesBottomAxis $ timeSeriesView st - plotLayout = timeSeriesLayout $ timeSeriesView st - i <- liftSimulation simulationIndex - let file = fromJust $ M.lookup (i - 1) (timeSeriesMap st) - title = timeSeriesTitle $ timeSeriesView st - plotTitle = - replace "$TITLE" title - (timeSeriesPlotTitle $ timeSeriesView st) - runPlotTitle = - if n == 1 - then plotTitle - else replace "$RUN_INDEX" (show i) $ - replace "$RUN_COUNT" (show n) $ - replace "$PLOT_TITLE" plotTitle - (timeSeriesRunPlotTitle $ timeSeriesView st) - inputHistory input = - forM input $ \(name, provider, input) -> - let transform () = - do x <- predicate - if x then input else return (1/0) -- the infinite values will be ignored then - in newSignalHistory $ - mapSignalM transform $ - experimentMixedSignal expdata [provider] - leftHs <- inputHistory leftInput - rightHs <- inputHistory rightInput - return $ - do let plots hs input plotLineTails = - do ps <- - forM (zip3 hs input (head plotLineTails)) $ - \(h, (name, provider, input), plotLines) -> - do (ts, xs) <- readSignalHistory h - return $ - toPlot $ - plotLines $ - plot_lines_values ^= filterPlotLinesValues (zip (elems ts) (elems xs)) $ - plot_lines_title ^= name $ - defaultPlotLines - return (ps, drop (length hs) plotLineTails) - (leftPs, plotLineTails) <- plots leftHs leftInput (tails plotLines) - (rightPs, plotLineTails) <- plots rightHs rightInput plotLineTails - let leftPs' = map Left leftPs - rightPs' = map Right rightPs - ps' = leftPs' ++ rightPs' - axis = plotBottomAxis $ - laxis_title ^= "time" $ - defaultLayoutAxis - chart = plotLayout $ - layout1_bottom_axis ^= axis $ - layout1_title ^= runPlotTitle $ - layout1_plots ^= ps' $ - defaultLayout1 - liftIO $ - do renderableToPNGFile (toRenderable chart) width height file - when (experimentVerbose $ timeSeriesExperiment st) $ - putStr "Generated file " >> putStrLn file - --- | Remove the NaN and inifity values. -filterPlotLinesValues :: [(Double, Double)] -> [[(Double, Double)]] -filterPlotLinesValues = - filter (not . null) . - divideBy (\(t, x) -> isNaN x || isInfinite x) - --- | Get the HTML code. -timeSeriesHtml :: TimeSeriesViewState -> Int -> HtmlWriter () -timeSeriesHtml st index = - let n = experimentRunCount $ timeSeriesExperiment st - in if n == 1 - then timeSeriesHtmlSingle st index - else timeSeriesHtmlMultiple st index - --- | Get the HTML code for a single run. -timeSeriesHtmlSingle :: TimeSeriesViewState -> Int -> HtmlWriter () -timeSeriesHtmlSingle st index = - do header st index - let f = fromJust $ M.lookup 0 (timeSeriesMap st) - writeHtmlParagraph $ - writeHtmlImage (makeRelative (timeSeriesDir st) f) - --- | Get the HTML code for multiple runs. -timeSeriesHtmlMultiple :: TimeSeriesViewState -> Int -> HtmlWriter () -timeSeriesHtmlMultiple st index = - do header st index - let n = experimentRunCount $ timeSeriesExperiment st - forM_ [0..(n - 1)] $ \i -> - let f = fromJust $ M.lookup i (timeSeriesMap st) - in writeHtmlParagraph $ - writeHtmlImage (makeRelative (timeSeriesDir st) f) - -header :: TimeSeriesViewState -> Int -> HtmlWriter () -header st index = - do writeHtmlHeader3WithId ("id" ++ show index) $ - writeHtmlText (timeSeriesTitle $ timeSeriesView st) - let description = timeSeriesDescription $ timeSeriesView st - unless (null description) $ - writeHtmlParagraph $ - writeHtmlText description - --- | Get the TOC item. -timeSeriesTOCHtml :: TimeSeriesViewState -> Int -> HtmlWriter () -timeSeriesTOCHtml st index = - writeHtmlListItem $ - writeHtmlLink ("#id" ++ show index) $ - writeHtmlText (timeSeriesTitle $ timeSeriesView st) diff --git a/Simulation/Aivika/Experiment/XYChartView.hs b/Simulation/Aivika/Experiment/XYChartView.hs deleted file mode 100644 --- a/Simulation/Aivika/Experiment/XYChartView.hs +++ /dev/null @@ -1,309 +0,0 @@ - --- | --- Module : Simulation.Aivika.Experiment.XYChartView --- Copyright : Copyright (c) 2012, David Sorokin --- License : BSD3 --- Maintainer : David Sorokin --- Stability : experimental --- Tested with: GHC 7.4.1 --- --- The module defines 'XYChartView' that saves the XY charts --- in the PNG files. --- - -module Simulation.Aivika.Experiment.XYChartView - (XYChartView(..), - defaultXYChartView) where - -import Control.Monad -import Control.Monad.Trans - -import qualified Data.Map as M -import Data.IORef -import Data.Maybe -import Data.Either -import Data.Array -import Data.Monoid -import Data.List - -import Data.Accessor - -import System.IO -import System.FilePath - -import Graphics.Rendering.Chart - -import Simulation.Aivika.Experiment -import Simulation.Aivika.Experiment.HtmlWriter -import Simulation.Aivika.Experiment.Utils (divideBy, replace) -import Simulation.Aivika.Experiment.Chart (colourisePlotLines) - -import Simulation.Aivika.Specs -import Simulation.Aivika.Simulation -import Simulation.Aivika.Event -import Simulation.Aivika.Signal - --- | Defines the 'View' that saves the XY charts --- in the PNG files. -data XYChartView = - XYChartView { xyChartTitle :: String, - -- ^ This is a title used in HTML. - xyChartDescription :: String, - -- ^ This is a description used in HTML. - xyChartWidth :: Int, - -- ^ The width of the chart. - xyChartHeight :: Int, - -- ^ The height of the chart. - xyChartFileName :: FileName, - -- ^ It defines the file name for each PNG file. - -- It may include special variables @$TITLE@, - -- @$RUN_INDEX@ and @$RUN_COUNT@. - -- - -- An example is - -- - -- @ - -- xyChartFileName = UniqueFileName \"$TITLE - $RUN_INDEX\" \".png\" - -- @ - xyChartPredicate :: Event Bool, - -- ^ It specifies the predicate that defines - -- when we plot data in the chart. - xyChartXSeries :: Maybe String, - -- ^ This is a label of the X series. - -- - -- You must define it, because it is 'Nothing' - -- by default. - xyChartYSeries :: [Either String String], - -- ^ It contains the labels of Y series plotted - -- on the XY chart. - xyChartPlotTitle :: String, - -- ^ This is a title used in the chart when - -- simulating a single run. It may include - -- special variable @$TITLE@. - -- - -- An example is - -- - -- @ - -- xyChartPlotTitle = \"$TITLE\" - -- @ - xyChartRunPlotTitle :: String, - -- ^ The run title for the chart. It is used - -- when simulating multiple runs and it may - -- include special variables @$RUN_INDEX@, - -- @$RUN_COUNT@ and @$PLOT_TITLE@. - -- - -- An example is - -- - -- @ - -- xyChartRunPlotTitle = \"$PLOT_TITLE / Run $RUN_INDEX of $RUN_COUNT\" - -- @ - xyChartPlotLines :: [PlotLines Double Double -> - PlotLines Double Double], - -- ^ Probably, an infinite sequence of plot - -- transformations based on which the plot - -- is constructed for each Y series. Generally, - -- it may not coincide with a sequence of - -- Y labels as one label may denote a whole list - -- or an array of data providers. - -- - -- Here you can define a colour or style of - -- the plot lines. - xyChartBottomAxis :: LayoutAxis Double -> - LayoutAxis Double, - -- ^ A transformation of the bottom axis, - -- after the X title is added. - xyChartLayout :: Layout1 Double Double -> - Layout1 Double Double - -- ^ A transformation of the plot layout, - -- where you can redefine the axes, for example. - } - --- | The default time series view. -defaultXYChartView :: XYChartView -defaultXYChartView = - XYChartView { xyChartTitle = "XY Chart", - xyChartDescription = "It shows the XY chart(s).", - xyChartWidth = 640, - xyChartHeight = 480, - xyChartFileName = UniqueFileName "$TITLE - $RUN_INDEX" ".png", - xyChartPredicate = return True, - xyChartXSeries = Nothing, - xyChartYSeries = [], - xyChartPlotTitle = "$TITLE", - xyChartRunPlotTitle = "$PLOT_TITLE / Run $RUN_INDEX of $RUN_COUNT", - xyChartPlotLines = colourisePlotLines, - xyChartBottomAxis = id, - xyChartLayout = id } - -instance View XYChartView where - - outputView v = - let reporter exp dir = - do st <- newXYChart v exp dir - return Reporter { reporterInitialise = return (), - reporterFinalise = return (), - reporterSimulate = simulateXYChart st, - reporterTOCHtml = xyChartTOCHtml st, - reporterHtml = xyChartHtml st } - in Generator { generateReporter = reporter } - --- | The state of the view. -data XYChartViewState = - XYChartViewState { xyChartView :: XYChartView, - xyChartExperiment :: Experiment, - xyChartDir :: FilePath, - xyChartMap :: M.Map Int FilePath } - --- | Create a new state of the view. -newXYChart :: XYChartView -> Experiment -> FilePath -> IO XYChartViewState -newXYChart view exp dir = - do let n = experimentRunCount exp - fs <- forM [0..(n - 1)] $ \i -> - resolveFileName (Just dir) (xyChartFileName view) $ - M.fromList [("$TITLE", xyChartTitle 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 XYChartViewState { xyChartView = view, - xyChartExperiment = exp, - xyChartDir = dir, - xyChartMap = m } - --- | Plot the XY chart during the simulation. -simulateXYChart :: XYChartViewState -> ExperimentData -> Event (Event ()) -simulateXYChart st expdata = - do let ylabels = xyChartYSeries $ xyChartView st - xlabels = xyChartXSeries $ xyChartView st - xlabel = flip fromMaybe xlabels $ - error "X series is not provided: simulateXYChart" - (leftYLabels, rightYLabels) = partitionEithers ylabels - leftYProviders = experimentSeriesProviders expdata leftYLabels - rightYProviders = experimentSeriesProviders expdata rightYLabels - xprovider = - case experimentSeriesProviders expdata [xlabel] of - [provider] -> provider - _ -> error $ - "Only a single X series must be" ++ - " provided: simulateXYChart" - providerInput providers = - flip map providers $ \provider -> - case providerToDouble provider of - Nothing -> error $ - "Cannot represent series " ++ - providerName provider ++ - " as double values: simulateXYChart" - Just input -> (providerName provider, provider, input) - leftYInput = providerInput leftYProviders - rightYInput = providerInput rightYProviders - [(xname, _, x)] = providerInput [xprovider] - n = experimentRunCount $ xyChartExperiment st - width = xyChartWidth $ xyChartView st - height = xyChartHeight $ xyChartView st - predicate = xyChartPredicate $ xyChartView st - plotLines = xyChartPlotLines $ xyChartView st - plotBottomAxis = xyChartBottomAxis $ xyChartView st - plotLayout = xyChartLayout $ xyChartView st - i <- liftSimulation simulationIndex - let file = fromJust $ M.lookup (i - 1) (xyChartMap st) - title = xyChartTitle $ xyChartView st - plotTitle = - replace "$TITLE" title - (xyChartPlotTitle $ xyChartView st) - runPlotTitle = - if n == 1 - then plotTitle - else replace "$RUN_INDEX" (show i) $ - replace "$RUN_COUNT" (show n) $ - replace "$PLOT_TITLE" plotTitle - (xyChartRunPlotTitle $ xyChartView st) - inputHistory input = - forM input $ \(name, provider, y) -> - let transform () = - do p <- predicate - if p - then liftM2 (,) x y - else return (1/0, 1/0) -- such values will be ignored then - in newSignalHistory $ - mapSignalM transform $ - experimentMixedSignal expdata [provider] <> - experimentMixedSignal expdata [xprovider] - leftHs <- inputHistory leftYInput - rightHs <- inputHistory rightYInput - return $ - do let plots hs input plotLineTails = - do ps <- - forM (zip3 hs input (head plotLineTails)) $ - \(h, (name, provider, input), plotLines) -> - do (ts, zs) <- readSignalHistory h - return $ - toPlot $ - plotLines $ - plot_lines_values ^= filterPlotLinesValues (elems zs) $ - plot_lines_title ^= name $ - defaultPlotLines - return (ps, drop (length hs) plotLineTails) - (leftPs, plotLineTails) <- plots leftHs leftYInput (tails plotLines) - (rightPs, plotLineTails) <- plots rightHs rightYInput plotLineTails - let leftPs' = map Left leftPs - rightPs' = map Right rightPs - ps' = leftPs' ++ rightPs' - axis = plotBottomAxis $ - laxis_title ^= providerName xprovider $ - defaultLayoutAxis - chart = plotLayout $ - layout1_bottom_axis ^= axis $ - layout1_title ^= runPlotTitle $ - layout1_plots ^= ps' $ - defaultLayout1 - liftIO $ - do renderableToPNGFile (toRenderable chart) width height file - when (experimentVerbose $ xyChartExperiment st) $ - putStr "Generated file " >> putStrLn file - --- | Remove the NaN and inifity values. -filterPlotLinesValues :: [(Double, Double)] -> [[(Double, Double)]] -filterPlotLinesValues = - filter (not . null) . - divideBy (\(x, y) -> isNaN x || isInfinite x || isNaN y || isInfinite y) - --- | Get the HTML code. -xyChartHtml :: XYChartViewState -> Int -> HtmlWriter () -xyChartHtml st index = - let n = experimentRunCount $ xyChartExperiment st - in if n == 1 - then xyChartHtmlSingle st index - else xyChartHtmlMultiple st index - --- | Get the HTML code for a single run. -xyChartHtmlSingle :: XYChartViewState -> Int -> HtmlWriter () -xyChartHtmlSingle st index = - do header st index - let f = fromJust $ M.lookup 0 (xyChartMap st) - writeHtmlParagraph $ - writeHtmlImage (makeRelative (xyChartDir st) f) - --- | Get the HTML code for multiple runs. -xyChartHtmlMultiple :: XYChartViewState -> Int -> HtmlWriter () -xyChartHtmlMultiple st index = - do header st index - let n = experimentRunCount $ xyChartExperiment st - forM_ [0..(n - 1)] $ \i -> - let f = fromJust $ M.lookup i (xyChartMap st) - in writeHtmlParagraph $ - writeHtmlImage (makeRelative (xyChartDir st) f) - -header :: XYChartViewState -> Int -> HtmlWriter () -header st index = - do writeHtmlHeader3WithId ("id" ++ show index) $ - writeHtmlText (xyChartTitle $ xyChartView st) - let description = xyChartDescription $ xyChartView st - unless (null description) $ - writeHtmlParagraph $ - writeHtmlText description - --- | Get the TOC item. -xyChartTOCHtml :: XYChartViewState -> Int -> HtmlWriter () -xyChartTOCHtml st index = - writeHtmlListItem $ - writeHtmlLink ("#id" ++ show index) $ - writeHtmlText (xyChartTitle $ xyChartView st) diff --git a/aivika-experiment-chart.cabal b/aivika-experiment-chart.cabal --- a/aivika-experiment-chart.cabal +++ b/aivika-experiment-chart.cabal @@ -1,5 +1,5 @@ name: aivika-experiment-chart -version: 0.4 +version: 1.0 synopsis: Simulation experiments with charting for the Aivika library description: This package complements the Aivika and Aivika Experiment packages with @@ -12,7 +12,7 @@ category: Simulation license: BSD3 license-file: LICENSE -copyright: (c) 2012-2013. David Sorokin +copyright: (c) 2012-2014. David Sorokin author: David Sorokin maintainer: David Sorokin homepage: http://github.com/dsorokin/aivika-experiment-chart @@ -31,24 +31,27 @@ library - exposed-modules: Simulation.Aivika.Experiment.TimeSeriesView - Simulation.Aivika.Experiment.XYChartView - Simulation.Aivika.Experiment.FinalXYChartView - Simulation.Aivika.Experiment.DeviationChartView - Simulation.Aivika.Experiment.HistogramView - Simulation.Aivika.Experiment.FinalHistogramView - Simulation.Aivika.Experiment.Chart + exposed-modules: Simulation.Aivika.Experiment.Chart + Simulation.Aivika.Experiment.Chart.TimeSeriesView + Simulation.Aivika.Experiment.Chart.XYChartView + Simulation.Aivika.Experiment.Chart.FinalXYChartView + Simulation.Aivika.Experiment.Chart.DeviationChartView + Simulation.Aivika.Experiment.Chart.HistogramView + Simulation.Aivika.Experiment.Chart.FinalHistogramView + Simulation.Aivika.Experiment.Chart.Utils build-depends: base >= 3 && < 6, mtl >= 1.1.0.2, array >= 0.3.0.0, containers >= 0.4.0.0, filepath >= 1.3.0.0, - Chart >= 0.16, + Chart >= 1.2, + Chart-cairo >= 1.2, split >= 0.2.2, - data-accessor >= 0.2.2.3, + lens >= 3.9, + data-default-class < 0.1, colour >= 2.3.3, - aivika >= 0.7, - aivika-experiment >= 0.4 + aivika >= 1.0, + aivika-experiment >= 1.0 ghc-options: -O2 diff --git a/examples/BassDiffusion.hs b/examples/BassDiffusion.hs --- a/examples/BassDiffusion.hs +++ b/examples/BassDiffusion.hs @@ -4,17 +4,9 @@ import Control.Monad import Control.Monad.Trans -import Simulation.Aivika.Specs -import Simulation.Aivika.Simulation -import Simulation.Aivika.Event -import Simulation.Aivika.Dynamics -import Simulation.Aivika.Agent -import Simulation.Aivika.Ref - +import Simulation.Aivika import Simulation.Aivika.Experiment -import Simulation.Aivika.Experiment.DeviationChartView -import Simulation.Aivika.Experiment.TimeSeriesView -import Simulation.Aivika.Experiment.ExperimentSpecsView +import Simulation.Aivika.Experiment.Chart n = 100 -- the number of agents @@ -25,7 +17,8 @@ specs = Specs { spcStartTime = 0.0, spcStopTime = 8.0, spcDT = 0.1, - spcMethod = RungeKutta4 } + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } experiment :: Experiment experiment = @@ -40,7 +33,8 @@ Left "adopters"] }, outputView $ defaultTimeSeriesView { timeSeries = [Left "potentialAdopters", - Left "adopters"] } ] } + Left "adopters"] } ] + } exprnd :: Double -> IO Double exprnd lambda = @@ -80,7 +74,7 @@ t <- liftIO $ exprnd advertisingEffectiveness let st = personPotentialAdopter p st' = personAdopter p - addTimeout st t $ activateState st' + addTimeout st t $ selectState st' setStateActivation (personAdopter p) $ do modifyRef adopters $ \a -> a + 1 -- add a timer that works while the state is active @@ -88,10 +82,10 @@ addTimer (personAdopter p) t $ do i <- liftIO $ getStdRandom $ randomR (1, n) let p' = ps ! i - st <- agentState (personAgent p') + st <- selectedState (personAgent p') when (st == Just (personPotentialAdopter p')) $ do b <- liftIO $ boolrnd adoptionFraction - when b $ activateState (personAdopter p') + when b $ selectState (personAdopter p') setStateDeactivation (personPotentialAdopter p) $ modifyRef potentialAdopters $ \a -> a - 1 setStateDeactivation (personAdopter p) $ @@ -103,7 +97,7 @@ definePerson p ps potentialAdopters adopters activatePerson :: Person -> Event () -activatePerson p = activateState (personPotentialAdopter p) +activatePerson p = selectState (personPotentialAdopter p) activatePersons :: Array Int Person -> Event () activatePersons ps = diff --git a/examples/ChemicalReaction.hs b/examples/ChemicalReaction.hs --- a/examples/ChemicalReaction.hs +++ b/examples/ChemicalReaction.hs @@ -1,22 +1,16 @@ {-# LANGUAGE RecursiveDo #-} -import Simulation.Aivika.Specs -import Simulation.Aivika.Simulation -import Simulation.Aivika.Dynamics +import Simulation.Aivika import Simulation.Aivika.SystemDynamics - import Simulation.Aivika.Experiment -import Simulation.Aivika.Experiment.LastValueView -import Simulation.Aivika.Experiment.TableView -import Simulation.Aivika.Experiment.TimeSeriesView -import Simulation.Aivika.Experiment.XYChartView -import Simulation.Aivika.Experiment.ExperimentSpecsView +import Simulation.Aivika.Experiment.Chart specs = Specs { spcStartTime = 0, spcStopTime = 13, spcDT = 0.01, - spcMethod = RungeKutta4 } + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } experiment :: Experiment experiment = diff --git a/examples/DifferenceEquations.hs b/examples/DifferenceEquations.hs --- a/examples/DifferenceEquations.hs +++ b/examples/DifferenceEquations.hs @@ -1,22 +1,16 @@ {-# LANGUAGE RecursiveDo #-} -import Simulation.Aivika.Specs -import Simulation.Aivika.Simulation -import Simulation.Aivika.Dynamics -import Simulation.Aivika.Dynamics.Random +import Simulation.Aivika import Simulation.Aivika.SystemDynamics - import Simulation.Aivika.Experiment -import Simulation.Aivika.Experiment.TableView -import Simulation.Aivika.Experiment.TimeSeriesView -import Simulation.Aivika.Experiment.ExperimentSpecsView -import Simulation.Aivika.Experiment.TimingStatsView +import Simulation.Aivika.Experiment.Chart specs = Specs { spcStartTime = 0, spcStopTime = 10000, spcDT = 1, - spcMethod = RungeKutta4 } + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } experiment :: Experiment experiment = @@ -45,13 +39,13 @@ model :: Simulation ExperimentData model = - mdo x <- newNormalDynamics 3 0.8 - sumX <- sumDynamics x 0 - sumX2 <- sumDynamics (x * x) 0 + mdo x <- memoRandomNormalDynamics 3 0.8 + sumX <- diffsum x 0 + sumX2 <- diffsum (x * x) 0 -- it would be much more efficient to say: -- let n = fmap fromIntegral integIteration - n <- sumDynamics 1 0 + n <- diffsum 1 0 let avg = ifDynamics (n .>. 0) (sumX / n) 0 let std = ifDynamics (n .>. 1) (sqrt ((sumX2 - sumX * avg) / (n - 1))) 0 diff --git a/examples/Financial.hs b/examples/Financial.hs --- a/examples/Financial.hs +++ b/examples/Financial.hs @@ -19,40 +19,27 @@ import Control.Monad --- from package aivika -import Simulation.Aivika.Specs -import Simulation.Aivika.Simulation -import Simulation.Aivika.Dynamics +import Simulation.Aivika import Simulation.Aivika.SystemDynamics -import Simulation.Aivika.Parameter.Random - --- from package aivika-experiment import Simulation.Aivika.Experiment -import Simulation.Aivika.Experiment.ExperimentSpecsView -import Simulation.Aivika.Experiment.TableView -import Simulation.Aivika.Experiment.FinalStatsView - --- from package aivika-experiment-chart -import Simulation.Aivika.Experiment.DeviationChartView -import Simulation.Aivika.Experiment.FinalHistogramView -import Simulation.Aivika.Experiment.TimeSeriesView +import Simulation.Aivika.Experiment.Chart -- | The model parameters. data Parameters = - Parameters { paramsTaxDepreciationTime :: Simulation Double, - paramsTaxRate :: Simulation Double, - paramsAveragePayableDelay :: Simulation Double, - paramsBillingProcessingTime :: Simulation Double, - paramsBuildingTime :: Simulation Double, - paramsDebtFinancingFraction :: Simulation Double, - paramsDebtRetirementTime :: Simulation Double, - paramsDiscountRate :: Simulation Double, - paramsFractionalLossRate :: Simulation Double, - paramsInterestRate :: Simulation Double, - paramsPrice :: Simulation Double, - paramsProductionCapacity :: Simulation Double, - paramsRequiredInvestment :: Simulation Double, - paramsVariableProductionCost :: Simulation Double } + Parameters { paramsTaxDepreciationTime :: Parameter Double, + paramsTaxRate :: Parameter Double, + paramsAveragePayableDelay :: Parameter Double, + paramsBillingProcessingTime :: Parameter Double, + paramsBuildingTime :: Parameter Double, + paramsDebtFinancingFraction :: Parameter Double, + paramsDebtRetirementTime :: Parameter Double, + paramsDiscountRate :: Parameter Double, + paramsFractionalLossRate :: Parameter Double, + paramsInterestRate :: Parameter Double, + paramsPrice :: Parameter Double, + paramsProductionCapacity :: Parameter Double, + paramsRequiredInvestment :: Parameter Double, + paramsVariableProductionCost :: Parameter Double } -- | The default model parameters. defaultParams :: Parameters @@ -75,15 +62,15 @@ -- | Random parameters for the Monte-Carlo simulation. randomParams :: IO Parameters randomParams = - do averagePayableDelay <- newRandomParameter 0.07 0.11 - billingProcessingTime <- newRandomParameter 0.03 0.05 - buildingTime <- newRandomParameter 0.8 1.2 - fractionalLossRate <- newRandomParameter 0.05 0.08 - interestRate <- newRandomParameter 0.09 0.15 - price <- newRandomParameter 0.9 1.2 - productionCapacity <- newRandomParameter 2200 2600 - requiredInvestment <- newRandomParameter 1800 2200 - variableProductionCost <- newRandomParameter 0.5 0.7 + do averagePayableDelay <- memoParameter $ randomUniform 0.07 0.11 + billingProcessingTime <- memoParameter $ randomUniform 0.03 0.05 + buildingTime <- memoParameter $ randomUniform 0.8 1.2 + fractionalLossRate <- memoParameter $ randomUniform 0.05 0.08 + interestRate <- memoParameter $ randomUniform 0.09 0.15 + price <- memoParameter $ randomUniform 0.9 1.2 + productionCapacity <- memoParameter $ randomUniform 2200 2600 + requiredInvestment <- memoParameter $ randomUniform 1800 2200 + variableProductionCost <- memoParameter $ randomUniform 0.5 0.7 return defaultParams { paramsAveragePayableDelay = averagePayableDelay, paramsBillingProcessingTime = billingProcessingTime, paramsBuildingTime = buildingTime, @@ -97,8 +84,7 @@ -- | This is the model itself that returns experimental data. model :: Parameters -> Simulation ExperimentData model params = - mdo let liftParam :: (Parameters -> Simulation a) -> Dynamics a - liftParam f = liftSimulation $ f params + mdo let getParameter f = liftParameter $ f params -- the equations below are given in an arbitrary order! @@ -109,30 +95,28 @@ production = availableCapacity availableCapacity = ifDynamics (time .>=. buildingTime) productionCapacity 0 - taxDepreciationTime = liftParam paramsTaxDepreciationTime - taxRate = liftParam paramsTaxRate + taxDepreciationTime = getParameter paramsTaxDepreciationTime + taxRate = getParameter paramsTaxRate accountsReceivable <- integ (billings - cashReceipts - losses) (billings / (1 / averagePayableDelay + fractionalLossRate)) - let averagePayableDelay = - liftParam paramsAveragePayableDelay + let averagePayableDelay = getParameter paramsAveragePayableDelay awaitingBilling <- integ (price * production - billings) (price * production * billingProcessingTime) - let billingProcessingTime = - liftParam paramsBillingProcessingTime + let billingProcessingTime = getParameter paramsBillingProcessingTime billings = awaitingBilling / billingProcessingTime borrowing = newInvestment * debtFinancingFraction - buildingTime = liftParam paramsBuildingTime + buildingTime = getParameter paramsBuildingTime cashReceipts = accountsReceivable / averagePayableDelay debt <- integ (borrowing - principalRepayment) 0 - let debtFinancingFraction = liftParam paramsDebtFinancingFraction - debtRetirementTime = liftParam paramsDebtRetirementTime + let debtFinancingFraction = getParameter paramsDebtFinancingFraction + debtRetirementTime = getParameter paramsDebtRetirementTime directCosts = production * variableProductionCost - discountRate = liftParam paramsDiscountRate - fractionalLossRate = liftParam paramsFractionalLossRate + discountRate = getParameter paramsDiscountRate + fractionalLossRate = getParameter paramsFractionalLossRate grossIncome = billings interestPayments = debt * interestRate - interestRate = liftParam paramsInterestRate + interestRate = getParameter paramsInterestRate losses = accountsReceivable * fractionalLossRate netCashFlow = cashReceipts + borrowing - newInvestment - directCosts - interestPayments @@ -142,12 +126,12 @@ 0 (requiredInvestment / buildingTime) npvCashFlow <- npv netCashFlow discountRate 0 1 npvIncome <- npv netIncome discountRate 0 1 - let price = liftParam paramsPrice + let price = getParameter paramsPrice principalRepayment = debt / debtRetirementTime - productionCapacity = liftParam paramsProductionCapacity - requiredInvestment = liftParam paramsRequiredInvestment + productionCapacity = getParameter paramsProductionCapacity + requiredInvestment = getParameter paramsRequiredInvestment taxes = taxableIncome * taxRate - variableProductionCost = liftParam paramsVariableProductionCost + variableProductionCost = getParameter paramsVariableProductionCost experimentDataInStartTime [(netIncomeName, seriesEntity "Net income" netIncome), @@ -162,7 +146,7 @@ npvCashFlowName = "npvCashFlow" -- the simulation specs -specs = Specs 0 5 0.015625 RungeKutta4 +specs = Specs 0 5 0.015625 RungeKutta4 SimpleGenerator -- | The experiment for the Monte-Carlo simulation. monteCarloExperiment :: Experiment diff --git a/examples/Furnace.hs b/examples/Furnace.hs --- a/examples/Furnace.hs +++ b/examples/Furnace.hs @@ -37,72 +37,51 @@ import Control.Monad import Control.Monad.Trans -import Simulation.Aivika.Specs -import Simulation.Aivika.Simulation -import Simulation.Aivika.Dynamics -import Simulation.Aivika.Event -import Simulation.Aivika.Ref -import Simulation.Aivika.Process -import Simulation.Aivika.Random +import Simulation.Aivika +import Simulation.Aivika.Queue.Infinite import qualified Simulation.Aivika.DoubleLinkedList as DLL import Simulation.Aivika.Experiment -import Simulation.Aivika.Experiment.ExperimentSpecsView -import Simulation.Aivika.Experiment.FinalStatsView -import Simulation.Aivika.Experiment.DeviationChartView -import Simulation.Aivika.Experiment.FinalHistogramView +import Simulation.Aivika.Experiment.Chart -- | The simulation specs. specs = Specs { spcStartTime = 0.0, spcStopTime = 1000.0, -- spcStopTime = 300.0, spcDT = 0.1, - spcMethod = RungeKutta4 } + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } --- | Return an exponentially distributed random value with mean --- 1 / @lambda@, where @lambda@ is a parameter of the function. -exprnd :: Double -> IO Double -exprnd lambda = - do x <- getStdRandom random - return (- log x / lambda) - -- | Return a random initial temperature of the item. -temprnd :: IO Double -temprnd = - do x <- getStdRandom random - return (400.0 + (600.0 - 400.0) * x) +randomTemp :: Parameter Double +randomTemp = randomUniform 400 600 -- | Represents the furnace. data Furnace = - Furnace { furnaceNormalGen :: IO Double, - -- ^ The normal random number generator. - furnacePits :: [Pit], + Furnace { furnacePits :: [Pit], -- ^ The pits for ingots. furnacePitCount :: Ref Int, -- ^ The count of active pits with ingots. - furnaceAwaitingIngots :: DLL.DoubleLinkedList Ingot, - -- ^ The awaiting ingots in the queue. - furnaceQueueCount :: Ref Int, - -- ^ The queue count. - furnaceWaitCount :: Ref Int, - -- ^ The count of awaiting ingots. - furnaceWaitTime :: Ref Double, - -- ^ The wait time for all loaded ingots. - furnaceHeatingTime :: Ref Double, - -- ^ The heating time for all unloaded ingots. + furnaceQueue :: FCFSQueue Ingot, + -- ^ The furnace queue. + furnaceUnloadedSource :: SignalSource (), + -- ^ Notifies when the ingots have been + -- unloaded from the furnace. + furnaceHeatingTime :: Ref (SamplingStats Double), + -- ^ The heating time for the ready ingots. furnaceTemp :: Ref Double, -- ^ The furnace temperature. - furnaceTotalCount :: Ref Int, - -- ^ The total count of ingots. - furnaceLoadCount :: Ref Int, - -- ^ The count of loaded ingots. - furnaceUnloadCount :: Ref Int, - -- ^ The count of unloaded ingots. - furnaceUnloadTemps :: Ref [Double] - -- ^ The temperatures of all unloaded ingots. + furnaceReadyCount :: Ref Int, + -- ^ The count of ready ingots. + furnaceReadyTemps :: Ref [Double] + -- ^ The temperatures of all ready ingots. } +-- | Notifies when the ingots have been unloaded from the furnace. +furnaceUnloaded :: Furnace -> Signal () +furnaceUnloaded = publishSignal . furnaceUnloadedSource + -- | A pit in the furnace to place the ingots. data Pit = Pit { pitIngot :: Ref (Maybe Ingot), @@ -129,32 +108,22 @@ -- | Create a furnace. newFurnace :: Simulation Furnace newFurnace = - do normalGen <- liftIO newNormalGen - pits <- sequence [newPit | i <- [1..10]] + do pits <- sequence [newPit | i <- [1..10]] pitCount <- newRef 0 - awaitingIngots <- liftIO DLL.newList - queueCount <- newRef 0 - waitCount <- newRef 0 - waitTime <- newRef 0.0 - heatingTime <- newRef 0.0 + queue <- newFCFSQueue + heatingTime <- newRef emptySamplingStats h <- newRef 1650.0 - totalCount <- newRef 0 - loadCount <- newRef 0 - unloadCount <- newRef 0 - unloadTemps <- newRef [] - return Furnace { furnaceNormalGen = normalGen, - furnacePits = pits, + readyCount <- newRef 0 + readyTemps <- newRef [] + s <- newSignalSource + return Furnace { furnacePits = pits, furnacePitCount = pitCount, - furnaceAwaitingIngots = awaitingIngots, - furnaceQueueCount = queueCount, - furnaceWaitCount = waitCount, - furnaceWaitTime = waitTime, + furnaceQueue = queue, + furnaceUnloadedSource = s, furnaceHeatingTime = heatingTime, furnaceTemp = h, - furnaceTotalCount = totalCount, - furnaceLoadCount = loadCount, - furnaceUnloadCount = unloadCount, - furnaceUnloadTemps = unloadTemps } + furnaceReadyCount = readyCount, + furnaceReadyTemps = readyTemps } -- | Create a new pit. newPit :: Simulation Pit @@ -168,9 +137,9 @@ newIngot :: Furnace -> Event Ingot newIngot furnace = do t <- liftDynamics time - xi <- liftIO $ furnaceNormalGen furnace - h' <- liftIO temprnd - let c = 0.1 + (0.05 + xi * 0.01) + xi <- liftParameter $ randomNormal 0.05 0.01 + h' <- liftParameter randomTemp + let c = 0.1 + xi return Ingot { ingotFurnace = furnace, ingotReceiveTime = t, ingotReceiveTemp = h', @@ -189,7 +158,7 @@ -- update the temperature of the ingot. let furnace = ingotFurnace ingot - dt' <- liftDynamics dt + dt' <- liftParameter dt h' <- readRef (pitTemp pit) h <- readRef (furnaceTemp furnace) writeRef (pitTemp pit) $ @@ -208,84 +177,73 @@ do h' <- readRef (pitTemp pit) when (h' >= 2000.0) $ do Just ingot <- readRef (pitIngot pit) - unloadIngot ingot pit + unloadIngot furnace ingot pit -- | Try to load an awaiting ingot in the specified empty pit. tryLoadPit :: Furnace -> Pit -> Event () tryLoadPit furnace pit = - do let ingots = furnaceAwaitingIngots furnace - flag <- liftIO $ DLL.listNull ingots - unless flag $ - do ingot <- liftIO $ DLL.listFirst ingots - liftIO $ DLL.listRemoveFirst ingots - t' <- liftDynamics time - modifyRef (furnaceQueueCount furnace) (+ (-1)) - loadIngot (ingot { ingotLoadTime = t', - ingotLoadTemp = 400.0 }) pit + do ingot <- tryDequeue (furnaceQueue furnace) + case ingot of + Nothing -> + return () + Just ingot -> + do t' <- liftDynamics time + loadIngot furnace (ingot { ingotLoadTime = t', + ingotLoadTemp = 400.0 }) pit -- | Unload the ingot from the specified pit. -unloadIngot :: Ingot -> Pit -> Event () -unloadIngot ingot pit = +unloadIngot :: Furnace -> Ingot -> Pit -> Event () +unloadIngot furnace ingot pit = do h' <- readRef (pitTemp pit) writeRef (pitIngot pit) Nothing writeRef (pitTemp pit) 0.0 - + -- count the active pits - let furnace = ingotFurnace ingot - count <- readRef (furnacePitCount furnace) - writeRef (furnacePitCount furnace) (count - 1) + modifyRef (furnacePitCount furnace) (+ (- 1)) -- how long did we heat the ingot up? t' <- liftDynamics time - modifyRef (furnaceHeatingTime furnace) - (+ (t' - ingotLoadTime ingot)) + modifyRef (furnaceHeatingTime furnace) $ + addSamplingStats (t' - ingotLoadTime ingot) -- what is the temperature of the unloaded ingot? - modifyRef (furnaceUnloadTemps furnace) (h' :) + modifyRef (furnaceReadyTemps furnace) (h' :) - -- count the unloaded ingots - modifyRef (furnaceUnloadCount furnace) (+ 1) + -- count the ready ingots + modifyRef (furnaceReadyCount furnace) (+ 1) -- | Load the ingot in the specified pit -loadIngot :: Ingot -> Pit -> Event () -loadIngot ingot pit = +loadIngot :: Furnace -> Ingot -> Pit -> Event () +loadIngot furnace ingot pit = do writeRef (pitIngot pit) $ Just ingot writeRef (pitTemp pit) $ ingotLoadTemp ingot - + -- count the active pits - let furnace = ingotFurnace ingot + modifyRef (furnacePitCount furnace) (+ 1) count <- readRef (furnacePitCount furnace) - writeRef (furnacePitCount furnace) (count + 1) -- decrease the furnace temperature h <- readRef (furnaceTemp furnace) let h' = ingotLoadTemp ingot - dh = - (h - h') / fromInteger (toInteger (count + 1)) + dh = - (h - h') / fromIntegral count writeRef (furnaceTemp furnace) $ h + dh - - -- how long did we keep the ingot in the queue? - t' <- liftDynamics time - modifyRef (furnaceWaitCount furnace) (+ 1) - modifyRef (furnaceWaitTime furnace) - (+ (t' - ingotReceiveTime ingot)) - - -- count the loaded ingots - modifyRef (furnaceLoadCount furnace) (+ 1) - + -- | Start iterating the furnace processing through the event queue. startIteratingFurnace :: Furnace -> Event () startIteratingFurnace furnace = let pits = furnacePits furnace in enqueueEventWithIntegTimes $ - do ready <- ingotsReady furnace + do -- try to unload ready ingots + ready <- ingotsReady furnace when ready $ do mapM_ (tryUnloadPit furnace) pits - pits' <- emptyPits furnace - mapM_ (tryLoadPit furnace) pits' + triggerSignal (furnaceUnloadedSource furnace) () + + -- heat up mapM_ heatPitUp pits -- update the temperature of the furnace - dt' <- liftDynamics dt + dt' <- liftParameter dt h <- readRef (furnaceTemp furnace) writeRef (furnaceTemp furnace) $ h + dt' * (2600.0 - h) * 0.2 @@ -296,32 +254,37 @@ filterM (fmap isNothing . readRef . pitIngot) $ furnacePits furnace --- | Accept a new ingot. -acceptIngot :: Furnace -> Event () -acceptIngot furnace = - do ingot <- newIngot furnace - - -- counting - modifyRef (furnaceTotalCount furnace) (+ 1) - - -- check what to do with the new ingot - count <- readRef (furnacePitCount furnace) - if count >= 10 - then do let ingots = furnaceAwaitingIngots furnace - liftIO $ DLL.listAddLast ingots ingot - modifyRef (furnaceQueueCount furnace) (+ 1) - else do pit:_ <- emptyPits furnace - loadIngot ingot pit - --- | Process the furnace. -processFurnace :: Furnace -> Process () -processFurnace furnace = - do delay <- liftIO $ exprnd (1.0 / 2.5) +-- | This process takes ingots from the queue and then +-- loads them in the furnace. +loadingProcess :: Furnace -> Process () +loadingProcess furnace = + do ingot <- dequeue (furnaceQueue furnace) + let wait :: Process () + wait = + do count <- liftEvent $ readRef (furnacePitCount furnace) + when (count >= 10) $ + do processAwait (furnaceUnloaded furnace) + wait + wait + -- take any empty pit and load it + liftEvent $ + do pit: _ <- emptyPits furnace + loadIngot furnace ingot pit + -- repeat it again + loadingProcess furnace + +-- | The input process that adds new ingots to the queue. +inputProcess :: Furnace -> Process () +inputProcess furnace = + do delay <- liftParameter $ + randomExponential 2.5 holdProcess delay -- we have got a new ingot - liftEvent $ acceptIngot furnace + liftEvent $ + do ingot <- newIngot furnace + enqueue (furnaceQueue furnace) ingot -- repeat it again - processFurnace furnace + inputProcess furnace -- | Initialize the furnace. initializeFurnace :: Furnace -> Event () @@ -334,64 +297,48 @@ x6 <- newIngot furnace let p1 : p2 : p3 : p4 : p5 : p6 : ps = furnacePits furnace - loadIngot (x1 { ingotLoadTemp = 550.0 }) p1 - loadIngot (x2 { ingotLoadTemp = 600.0 }) p2 - loadIngot (x3 { ingotLoadTemp = 650.0 }) p3 - loadIngot (x4 { ingotLoadTemp = 700.0 }) p4 - loadIngot (x5 { ingotLoadTemp = 750.0 }) p5 - loadIngot (x6 { ingotLoadTemp = 800.0 }) p6 - writeRef (furnaceTotalCount furnace) 6 + loadIngot furnace (x1 { ingotLoadTemp = 550.0 }) p1 + loadIngot furnace (x2 { ingotLoadTemp = 600.0 }) p2 + loadIngot furnace (x3 { ingotLoadTemp = 650.0 }) p3 + loadIngot furnace (x4 { ingotLoadTemp = 700.0 }) p4 + loadIngot furnace (x5 { ingotLoadTemp = 750.0 }) p5 + loadIngot furnace (x6 { ingotLoadTemp = 800.0 }) p6 writeRef (furnaceTemp furnace) 1650.0 -- | The simulation model that returns experimental data. model :: Simulation ExperimentData model = do furnace <- newFurnace - pid <- newProcessId - + -- initialize the furnace and start its iterating in start time runEventInStartTime IncludingCurrentEvents $ do initializeFurnace furnace startIteratingFurnace furnace - -- accept input ingots - runProcessInStartTime IncludingCurrentEvents - pid (processFurnace furnace) + -- generate randomly new input ingots + runProcessInStartTime IncludingCurrentEvents $ + inputProcess furnace - -- the mean wait time in the queue - let meanWaitTime :: Event Double - meanWaitTime = - do waitTime <- readRef (furnaceWaitTime furnace) - waitCount <- readRef (furnaceWaitCount furnace) - return $ waitTime / fromIntegral waitCount - - -- the mean heating time - let meanHeatingTime :: Event Double - meanHeatingTime = - do heatingTime <- readRef (furnaceHeatingTime furnace) - unloadCount <- readRef (furnaceUnloadCount furnace) - return $ heatingTime / fromIntegral unloadCount + -- load permanently the input ingots in the furnace + runProcessInStartTime IncludingCurrentEvents $ + loadingProcess furnace experimentDataInStartTime [(totalIngotCountName, seriesEntity "total ingot count" $ - furnaceTotalCount furnace), + queueStoreCount (furnaceQueue furnace)), (loadedIngotCountName, - seriesEntity "loaded ingot count" $ - furnaceLoadCount furnace), + seriesEntity "loaded ingot count" $ -- actually, +/- 1 + queueOutputCount (furnaceQueue furnace)), (readyIngotCountName, seriesEntity "ready ingot count" $ - furnaceUnloadCount furnace), - - (awaitedIngotCountName, - seriesEntity "awaited in the queue ingot count" $ - furnaceWaitCount furnace), + furnaceReadyCount furnace), (readyIngotTempsName, seriesEntity "the temperature of ready ingot" $ - furnaceUnloadTemps furnace), + furnaceReadyTemps furnace), (pitCountName, seriesEntity "the used pit count" $ @@ -399,15 +346,15 @@ (queueCountName, seriesEntity "the queue size" $ - furnaceQueueCount furnace), + queueCount (furnaceQueue furnace)), (meanWaitTimeName, - seriesEntity "the mean wait time" - meanWaitTime), + seriesEntity "the mean wait time" $ + queueWaitTime (furnaceQueue furnace)), (meanHeatingTimeName, - seriesEntity "the mean heating time" - meanHeatingTime) ] + seriesEntity "the mean heating time" $ + furnaceHeatingTime furnace) ] totalIngotCountName = "totalIngotCount" loadedIngotCountName = "loadedIngotCount" @@ -431,39 +378,27 @@ [outputView defaultExperimentSpecsView, outputView $ defaultDeviationChartView { - deviationChartTitle = "Deviation Chart - 1.1", + deviationChartTitle = "Deviation Chart - 1", deviationChartPlotTitle = "The total, loaded and ready ingot counts", deviationChartSeries = [Right totalIngotCountName, Right loadedIngotCountName, Right readyIngotCountName] }, - outputView $ defaultDeviationChartView { - deviationChartTitle = "Deviation Chart - 1.2", - deviationChartPlotTitle = "The awaited in the queue ingot count", - deviationChartSeries = [Right awaitedIngotCountName] }, - outputView $ defaultFinalHistogramView { - finalHistogramTitle = "Final Histogram - 1.1", + finalHistogramTitle = "Final Histogram - 1", finalHistogramPlotTitle = "The distribution of total, loaded and ready " ++ "ingot counts in the final time point.", finalHistogramSeries = [totalIngotCountName, loadedIngotCountName, readyIngotCountName] }, - outputView $ defaultFinalHistogramView { - finalHistogramTitle = "Final Histogram - 1.2", - finalHistogramPlotTitle = "The distribution of the awaited in the queue " ++ - "ingot count in the final time point.", - finalHistogramSeries = [awaitedIngotCountName] }, - outputView $ defaultFinalStatsView { finalStatsTitle = "Final Statistics - 1", - finalStatsDescription = "The summary of total, loaded, ready and awaited in " ++ - "the queue ingot counts in the final time point.", + finalStatsDescription = "The summary of total, loaded and ready " ++ + "ingot counts in the final time point.", finalStatsSeries = [totalIngotCountName, loadedIngotCountName, - readyIngotCountName, - awaitedIngotCountName] }, + readyIngotCountName] }, outputView $ defaultDeviationChartView { deviationChartTitle = "Deviation Chart - 2", @@ -472,8 +407,7 @@ outputView $ defaultFinalHistogramView { finalHistogramTitle = "Final Histogram - 2", - finalHistogramPlotTitle = "The distribution of the used pit count " ++ - "in the final simulation time point.", + finalHistogramPlotTitle = "The used pit count in the final time point.", finalHistogramSeries = [pitCountName] }, outputView $ defaultFinalStatsView { @@ -488,8 +422,7 @@ outputView $ defaultFinalHistogramView { finalHistogramTitle = "Final Histogram - 3", - finalHistogramPlotTitle = "The distribution of the queue size " ++ - "in the final simulation time point.", + finalHistogramPlotTitle = "The queue size in the final time point.", finalHistogramSeries = [queueCountName] }, outputView $ defaultFinalStatsView { @@ -502,16 +435,10 @@ deviationChartPlotTitle = "The mean wait time", deviationChartSeries = [Right meanWaitTimeName] }, - outputView $ defaultFinalHistogramView { - finalHistogramTitle = "Final Histogram - 4", - finalHistogramPlotTitle = "The distribution of the mean wait time " ++ - "in the final simulation time point.", - finalHistogramSeries = [meanWaitTimeName] }, - outputView $ defaultFinalStatsView { finalStatsTitle = "Final Statistics - 4", finalStatsDescription = "The summary of the mean wait time in " ++ - "the final simulation time point.", + "the final time point.", finalStatsSeries = [meanWaitTimeName] }, outputView $ defaultDeviationChartView { @@ -519,16 +446,10 @@ deviationChartPlotTitle = "The mean heating time", deviationChartSeries = [Right meanHeatingTimeName] }, - outputView $ defaultFinalHistogramView { - finalHistogramTitle = "Final Histogram - 5", - finalHistogramPlotTitle = "The distribution of the mean heating time " ++ - "in the final simulation time point.", - finalHistogramSeries = [meanHeatingTimeName] }, - outputView $ defaultFinalStatsView { finalStatsTitle = "Final Statistics - 5", finalStatsDescription = "The summary of the mean heating time in " ++ - "the final simulation time point.", + "the final time point.", finalStatsSeries = [meanHeatingTimeName] }, outputView $ defaultDeviationChartView { @@ -538,14 +459,14 @@ outputView $ defaultFinalHistogramView { finalHistogramTitle = "Final Histogram - 6", - finalHistogramPlotTitle = "The distribution of the ready ingot temperature " ++ - "in the final simulation time point.", + finalHistogramPlotTitle = "The ready ingot temperature in " ++ + "the final time point.", finalHistogramSeries = [readyIngotTempsName] }, outputView $ defaultFinalStatsView { finalStatsTitle = "Final Statistics - 6", finalStatsDescription = "The summary of the ready ingot temperature in " ++ - "the final simulation time point.", + "the final time point.", finalStatsSeries = [readyIngotTempsName] } ] } diff --git a/examples/LinearArray.hs b/examples/LinearArray.hs --- a/examples/LinearArray.hs +++ b/examples/LinearArray.hs @@ -14,26 +14,16 @@ import qualified Data.Vector as V -import Simulation.Aivika.Specs -import Simulation.Aivika.Simulation -import Simulation.Aivika.Dynamics +import Simulation.Aivika import Simulation.Aivika.SystemDynamics - import Simulation.Aivika.Experiment -import Simulation.Aivika.Experiment.TableView -import Simulation.Aivika.Experiment.ExperimentSpecsView - -import Simulation.Aivika.Experiment.TimeSeriesView -import Simulation.Aivika.Experiment.DeviationChartView -import Simulation.Aivika.Experiment.FinalHistogramView -import Simulation.Aivika.Experiment.FinalXYChartView -import Simulation.Aivika.Experiment.HistogramView -import Simulation.Aivika.Experiment.XYChartView +import Simulation.Aivika.Experiment.Chart specs = Specs { spcStartTime = 0, spcStopTime = 500, spcDT = 0.1, - spcMethod = RungeKutta4 } + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } -- | This is an analog of 'V.generateM' included in the Haskell platform. generateArray :: (Ix i, Monad m) => (i, i) -> (i -> m a) -> m (Array i a) diff --git a/examples/MachRep3.hs b/examples/MachRep3.hs --- a/examples/MachRep3.hs +++ b/examples/MachRep3.hs @@ -17,30 +17,18 @@ import Control.Monad import Control.Monad.Trans -import Simulation.Aivika.Specs -import Simulation.Aivika.Simulation -import Simulation.Aivika.Dynamics -import Simulation.Aivika.Event -import Simulation.Aivika.Ref -import Simulation.Aivika.QueueStrategy -import Simulation.Aivika.Resource -import Simulation.Aivika.Process - +import Simulation.Aivika import Simulation.Aivika.Experiment -import Simulation.Aivika.Experiment.Histogram -import Simulation.Aivika.Experiment.LastValueView -import Simulation.Aivika.Experiment.TableView -import Simulation.Aivika.Experiment.TimeSeriesView -import Simulation.Aivika.Experiment.DeviationChartView -import Simulation.Aivika.Experiment.FinalHistogramView -import Simulation.Aivika.Experiment.FinalXYChartView -import Simulation.Aivika.Experiment.ExperimentSpecsView -import Simulation.Aivika.Experiment.FinalStatsView +import Simulation.Aivika.Experiment.Chart +meanUpTime = 1.0 +meanRepairTime = 0.5 + specs = Specs { spcStartTime = 0.0, spcStopTime = 1000.0, spcDT = 1.0, - spcMethod = RungeKutta4 } + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } experiment :: Experiment experiment = @@ -57,7 +45,7 @@ finalXYChartXSeries = Just "n", finalXYChartYSeries = [Right "x"], finalXYChartPredicate = - do i <- liftSimulation simulationIndex + do i <- liftParameter simulationIndex return $ (i < 50) || (i > 100) }, outputView $ defaultFinalHistogramView { finalHistogramPlotTitle = "Final Histogram (Default)", @@ -95,14 +83,6 @@ finalHistogramBuild = histogram binScott, finalHistogramSeries = ["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 -- number of machines currently up @@ -118,14 +98,15 @@ let machine :: ProcessId -> Process () machine pid = - do startUpTime <- liftDynamics time - upTime <- liftIO $ exprnd upRate + do upTime <- + liftParameter $ + randomExponential meanUpTime holdProcess upTime - finishUpTime <- liftDynamics time - liftEvent $ modifyRef totalUpTime - (+ (finishUpTime - startUpTime)) - - liftEvent $ modifyRef nUp $ \a -> a - 1 + liftEvent $ + modifyRef totalUpTime (+ upTime) + + liftEvent $ + modifyRef nUp (+ (-1)) nUp' <- liftEvent $ readRef nUp if nUp' == 1 then passivateProcess @@ -135,17 +116,20 @@ reactivateProcess pid requestResource repairPerson - repairTime <- liftIO $ exprnd repairRate + repairTime <- + liftParameter $ + randomExponential meanRepairTime holdProcess repairTime - liftEvent $ modifyRef nUp $ \a -> a + 1 + liftEvent $ + modifyRef nUp (+ 1) releaseResource repairPerson machine pid - runProcessInStartTime IncludingCurrentEvents + runProcessInStartTimeUsingId IncludingCurrentEvents pid1 (machine pid2) - runProcessInStartTime IncludingCurrentEvents + runProcessInStartTimeUsingId IncludingCurrentEvents pid2 (machine pid1) let result =