diff --git a/Simulation/Aivika/Experiment.hs b/Simulation/Aivika/Experiment.hs --- a/Simulation/Aivika/Experiment.hs +++ b/Simulation/Aivika/Experiment.hs @@ -3,16 +3,16 @@ -- | -- Module : Simulation.Aivika.Experiment --- Copyright : Copyright (c) 2012, David Sorokin +-- Copyright : Copyright (c) 2012-2013, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental --- Tested with: GHC 7.4.1 +-- Tested with: GHC 7.6.3 -- -- The module defines the simulation experiments. They automate -- the process of generating and analyzing the results. Moreover, -- this module is open to extensions, allowing you to define --- your own output views for the simulations results, for example, +-- your own output views for the simulation results, for example, -- such views that would allow saving the results in PDF or as -- charts. To decrease the number of dependencies, such possible -- extenstions are not included in this package, although simple @@ -29,12 +29,15 @@ experimentSeriesProviders, experimentMixedSignal, Series(..), + SeriesContainer(..), SeriesEntity(..), SeriesProvider(..), SeriesListWithSubscript, SeriesArrayWithSubscript, + SeriesVectorWithSubscript, seriesListWithSubscript, seriesArrayWithSubscript, + seriesVectorWithSubscript, View(..), Generator(..), Reporter(..), @@ -48,7 +51,16 @@ import Control.Concurrent.ParallelIO.Local import qualified Data.Map as M -import Data.Array +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as UV +import qualified Data.Array as A +import qualified Data.Array.Unboxed as UA + +import Data.Array (Array) +import Data.Array.Unboxed (UArray) +import Data.Array.IO + +import Data.Ix import Data.Maybe import Data.Monoid @@ -318,10 +330,7 @@ forM reporters $ \reporter -> reporterSimulate reporter d runDynamicsInStopTime $ - do updateSignal $ - experimentMixedSignal d $ - join $ map seriesProviders $ - M.elems $ experimentSeries d + do runQueueSync $ experimentQueue d sequence_ fs executor $ runSimulations simulate specs runCount forM_ reporters reporterFinalise @@ -419,205 +428,118 @@ Nothing -> name Just dir -> combine dir name -instance Series (Simulation Double) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Just $ liftSimulation s, - providerToDoubleStats = - Just $ liftSimulation $ fmap returnSamplingStats s, - providerToDoubleList = - Just $ liftSimulation $ fmap return s, - providerToInt = Nothing, - providerToIntStats = Nothing, - providerToIntList = Nothing, - providerToString = Just $ liftSimulation $ fmap show s, - providerSignal = Nothing }] } +-- | Represent a container for simulation data. +class SeriesContainer c where -instance Series (Simulation Int) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Just $ liftSimulation $ fmap fromIntegral s, - providerToDoubleStats = - Just $ liftSimulation $ - fmap returnSamplingStats $ - fmap fromIntegral s, - providerToDoubleList = - Just $ liftSimulation $ - fmap return $ - fmap fromIntegral s, - providerToInt = Just $ liftSimulation s, - providerToIntStats = - Just $ liftSimulation $ fmap returnSamplingStats s, - providerToIntList = - Just $ liftSimulation $ fmap return s, - providerToString = Just $ liftSimulation $ fmap show s, - providerSignal = Nothing }] } + -- | Extract data from the container. + containerData :: c a -> Dynamics a -instance Series (Simulation String) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = Nothing, - providerToDoubleList = Nothing, - providerToInt = Nothing, - providerToIntStats = Nothing, - providerToIntList = Nothing, - providerToString = Just $ liftSimulation s, - providerSignal = Nothing }] } + -- | Get the signal for the container. + containerSignal :: c a => Maybe (Signal ()) -instance Series (Dynamics Double) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Just s, - providerToDoubleStats = Just $ fmap returnSamplingStats s, - providerToDoubleList = Just $ fmap return s, - providerToInt = Nothing, - providerToIntStats = Nothing, - providerToIntList = Nothing, - providerToString = Just $ fmap show s, - providerSignal = Nothing }] } +instance SeriesContainer Simulation where -instance Series (Dynamics Int) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Just $ fmap fromIntegral s, - providerToDoubleStats = - Just $ fmap returnSamplingStats $ fmap fromIntegral s, - providerToDoubleList = - Just $ fmap return $ fmap fromIntegral s, - providerToInt = Just s, - providerToIntStats = Just $ fmap returnSamplingStats s, - providerToIntList = Just $ fmap return s, - providerToString = Just $ fmap show s, - providerSignal = Nothing }] } + containerData = liftSimulation -instance Series (Dynamics String) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = Nothing, - providerToDoubleList = Nothing, - providerToInt = Nothing, - providerToIntStats = Nothing, - providerToIntList = Nothing, - providerToString = Just s, - providerSignal = Nothing }] } + containerSignal = const Nothing -instance Series (Ref Double) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Just $ readRef s, - providerToDoubleStats = - Just $ fmap returnSamplingStats $ readRef s, - providerToDoubleList = - Just $ fmap return $ readRef s, - providerToInt = Nothing, - providerToIntStats = Nothing, - providerToIntList = Nothing, - providerToString = Just $ fmap show (readRef s), - providerSignal = Just $ refChanged_ s }] } +instance SeriesContainer Dynamics where -instance Series (Ref Int) where + containerData = id + + containerSignal = const Nothing + +instance SeriesContainer Ref where + + containerData = readRef + + containerSignal = Just . refChanged_ + +instance SeriesContainer Var where + + containerData = readVar + + containerSignal = Just . varChanged_ + +instance SeriesContainer c => Series (c Double) where seriesEntity name s = SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Just $ fmap fromIntegral (readRef s), + [SeriesProvider { providerName = name, + providerToDouble = + Just $ + containerData s, providerToDoubleStats = Just $ fmap returnSamplingStats $ - fmap fromIntegral (readRef s), + containerData s, providerToDoubleList = Just $ fmap return $ - fmap fromIntegral (readRef s), - providerToInt = Just $ readRef s, - providerToIntStats = - Just $ fmap returnSamplingStats (readRef s), - providerToIntList = - Just $ fmap return (readRef s), - providerToString = Just $ fmap show (readRef s), - providerSignal = Just $ refChanged_ s }] } - -instance Series (Ref String) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = Nothing, - providerToDoubleList = Nothing, - providerToInt = Nothing, - providerToIntStats = Nothing, - providerToIntList = Nothing, - providerToString = Just $ readRef s, - providerSignal = Just $ refChanged_ s }] } - -instance Series (Var Double) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Just $ readVar s, - providerToDoubleStats = - Just $ fmap returnSamplingStats $ readVar s, - providerToDoubleList = - Just $ fmap return $ readVar s, - providerToInt = Nothing, + containerData s, + providerToInt = Nothing, providerToIntStats = Nothing, providerToIntList = Nothing, - providerToString = Just $ fmap show (readVar s), - providerSignal = Just $ varChanged_ s }] } + providerToString = + Just $ + fmap show $ + containerData s, + providerSignal = + containerSignal s }] } -instance Series (Var Int) where +instance SeriesContainer c => Series (c Int) where seriesEntity name s = SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Just $ fmap fromIntegral (readVar s), + [SeriesProvider { providerName = name, + providerToDouble = + Just $ + fmap fromIntegral $ + containerData s, providerToDoubleStats = Just $ fmap returnSamplingStats $ - fmap fromIntegral (readVar s), + fmap fromIntegral $ + containerData s, providerToDoubleList = Just $ fmap return $ - fmap fromIntegral (readVar s), - providerToInt = Just $ readVar s, + fmap fromIntegral $ + containerData s, + providerToInt = + Just $ + containerData s, providerToIntStats = - Just $ fmap returnSamplingStats (readVar s), + Just $ + fmap returnSamplingStats $ + containerData s, providerToIntList = - Just $ fmap return (readVar s), - providerToString = Just $ fmap show (readVar s), - providerSignal = Just $ varChanged_ s }] } + Just $ + fmap return $ + containerData s, + providerToString = + Just $ + fmap show $ + containerData s, + providerSignal = + containerSignal s }] } -instance Series (Var String) where +instance SeriesContainer c => Series (c String) where seriesEntity name s = SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, + [SeriesProvider { providerName = name, providerToDouble = Nothing, providerToDoubleStats = Nothing, providerToDoubleList = Nothing, - providerToInt = Nothing, + providerToInt = Nothing, providerToIntStats = Nothing, providerToIntList = Nothing, - providerToString = Just $ readVar s, - providerSignal = Just $ varChanged_ s }] } + providerToString = + Just $ + containerData s, + providerSignal = + containerSignal s }] } instance Series (UVar Double) where @@ -661,7 +583,7 @@ seriesEntity name s = SeriesEntity { seriesProviders = - join $ forM (zip [1..] s) $ \(i, s) -> + join $ forM (zip [0..] s) $ \(i, s) -> let name' = name ++ "[" ++ show i ++ "]" in seriesProviders $ seriesEntity name' s } @@ -669,10 +591,18 @@ seriesEntity name s = SeriesEntity { seriesProviders = - join $ forM (assocs s) $ \(i, s) -> + join $ forM (A.assocs s) $ \(i, s) -> let name' = name ++ "[" ++ show i ++ "]" in seriesProviders $ seriesEntity name' s } +instance Series s => Series (V.Vector s) where + + seriesEntity name s = + SeriesEntity { seriesProviders = + join $ forM (zip [0..] (V.toList s)) $ \(i, s) -> + let name' = name ++ "[" ++ show i ++ "]" + in seriesProviders $ seriesEntity name' s } + -- | Represents a list with the specified subscript. data SeriesListWithSubscript s = SeriesListWithSubscript { seriesList :: [s], @@ -683,6 +613,11 @@ SeriesArrayWithSubscript { seriesArray :: Array i s, seriesArraySubscript :: Array i String } +-- | Represents a vector with the specified subscript. +data SeriesVectorWithSubscript s = + SeriesVectorWithSubscript { seriesVector :: V.Vector s, + seriesVectorSubscript :: V.Vector String } + -- | Add the specified subscript to the list. seriesListWithSubscript :: Series s => [s] -> [String] -> SeriesListWithSubscript s seriesListWithSubscript = SeriesListWithSubscript @@ -692,6 +627,11 @@ -> SeriesArrayWithSubscript i s seriesArrayWithSubscript = SeriesArrayWithSubscript +-- | Add the specified subscript to the vector. +seriesVectorWithSubscript :: Series s => V.Vector s -> V.Vector String + -> SeriesVectorWithSubscript s +seriesVectorWithSubscript = SeriesVectorWithSubscript + instance Series s => Series (SeriesListWithSubscript s) where seriesEntity name s = @@ -708,179 +648,38 @@ SeriesEntity { seriesProviders = do let xs = seriesArray s ns = seriesArraySubscript s - join $ forM (zip (assocs xs) (elems ns)) $ \((i, s), n) -> + join $ forM (zip (A.assocs xs) (A.elems ns)) $ \((i, s), n) -> let name' = name ++ n in seriesProviders $ seriesEntity name' s } -instance Series (Simulation (SamplingStats Double)) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = Just $ liftSimulation s, - providerToDoubleList = Nothing, - providerToInt = Nothing, - providerToIntStats = Nothing, - providerToIntList = Nothing, - providerToString = Nothing, - providerSignal = Nothing }] } - -instance Series (Simulation (SamplingStats Int)) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = - Just $ liftSimulation $ fmap fromIntSamplingStats s, - providerToDoubleList = Nothing, - providerToInt = Nothing, - providerToIntStats = Just $ liftSimulation s, - providerToIntList = Nothing, - providerToString = Nothing, - providerSignal = Nothing }] } - -instance Series (Dynamics (SamplingStats Double)) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = Just s, - providerToDoubleList = Nothing, - providerToInt = Nothing, - providerToIntStats = Nothing, - providerToIntList = Nothing, - providerToString = Nothing, - providerSignal = Nothing }] } - -instance Series (Dynamics (SamplingStats Int)) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = Just $ fmap fromIntSamplingStats s, - providerToDoubleList = Nothing, - providerToInt = Nothing, - providerToIntStats = Just $ s, - providerToIntList = Nothing, - providerToString = Nothing, - providerSignal = Nothing }] } - -instance Series (Ref (SamplingStats Double)) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = Just $ readRef s, - providerToDoubleList = Nothing, - providerToInt = Nothing, - providerToIntStats = Nothing, - providerToIntList = Nothing, - providerToString = Nothing, - providerSignal = Nothing }] } - -instance Series (Ref (SamplingStats Int)) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = - Just $ fmap fromIntSamplingStats $ readRef s, - providerToDoubleList = Nothing, - providerToInt = Nothing, - providerToIntStats = Just $ readRef s, - providerToIntList = Nothing, - providerToString = Nothing, - providerSignal = Nothing }] } - -instance Series (Var (SamplingStats Double)) where +instance Series s => Series (SeriesVectorWithSubscript s) where seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = Just $ readVar s, - providerToDoubleList = Nothing, - providerToInt = Nothing, - providerToIntStats = Nothing, - providerToIntList = Nothing, - providerToString = Nothing, - providerSignal = Nothing }] } + SeriesEntity { seriesProviders = do + let xs = seriesVector s + ns = seriesVectorSubscript s + join $ forM (zip (V.toList xs) (V.toList ns)) $ \(x, n) -> + let name' = name ++ n + in seriesProviders $ seriesEntity name' x } -instance Series (Var (SamplingStats Int)) where +instance SeriesContainer c => Series (c (SamplingStats Double)) where seriesEntity name s = SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, + [SeriesProvider { providerName = name, providerToDouble = Nothing, providerToDoubleStats = - Just $ fmap fromIntSamplingStats $ readVar s, + Just $ + containerData s, providerToDoubleList = Nothing, - providerToInt = Nothing, - providerToIntStats = Just $ readVar s, - providerToIntList = Nothing, - providerToString = Nothing, - providerSignal = Nothing }] } - -instance Series (Simulation [Double]) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = - Just $ liftSimulation $ fmap listSamplingStats s, - providerToDoubleList = - Just $ liftSimulation s, - providerToInt = Nothing, - providerToIntStats = Nothing, - providerToIntList = Nothing, - providerToString = Nothing, - providerSignal = Nothing }] } - -instance Series (Simulation [Int]) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = - Just $ liftSimulation $ - fmap fromIntSamplingStats $ - fmap listSamplingStats s, - providerToDoubleList = - Just $ liftSimulation $ - fmap (map fromIntegral) s, - providerToInt = Nothing, - providerToIntStats = - Just $ liftSimulation $ fmap listSamplingStats s, - providerToIntList = - Just $ liftSimulation s, - providerToString = Nothing, - providerSignal = Nothing }] } - -instance Series (Dynamics [Double]) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = - Just $ fmap listSamplingStats s, - providerToDoubleList = - Just s, - providerToInt = Nothing, + providerToInt = Nothing, providerToIntStats = Nothing, providerToIntList = Nothing, providerToString = Nothing, - providerSignal = Nothing }] } + providerSignal = + containerSignal s } ] } -instance Series (Dynamics [Int]) where +instance SeriesContainer c => Series (c (SamplingStats Int)) where seriesEntity name s = SeriesEntity { seriesProviders = @@ -889,179 +688,177 @@ providerToDoubleStats = Just $ fmap fromIntSamplingStats $ - fmap listSamplingStats s, - providerToDoubleList = - Just $ fmap (map fromIntegral) s, + containerData s, + providerToDoubleList = Nothing, providerToInt = Nothing, providerToIntStats = - Just $ fmap listSamplingStats s, - providerToIntList = - Just s, - providerToString = Nothing, - providerSignal = Nothing }] } - -instance Series (Ref [Double]) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = - Just $ fmap listSamplingStats $ readRef s, - providerToDoubleList = - Just $ readRef s, - providerToInt = Nothing, - providerToIntStats = Nothing, + Just $ + containerData s, providerToIntList = Nothing, providerToString = Nothing, - providerSignal = Nothing }] } + providerSignal = + containerSignal s } ] } -instance Series (Ref [Int]) where +instance SeriesContainer c => Series (c [Double]) where seriesEntity name s = SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, + [SeriesProvider { providerName = name, providerToDouble = Nothing, providerToDoubleStats = Just $ - fmap fromIntSamplingStats $ - fmap listSamplingStats $ readRef s, - providerToDoubleList = - Just $ fmap (map fromIntegral) $ readRef s, - providerToInt = Nothing, - providerToIntStats = - Just $ fmap listSamplingStats $ readRef s, - providerToIntList = - Just $ readRef s, - providerToString = Nothing, - providerSignal = Nothing }] } - -instance Series (Var [Double]) where - - seriesEntity name s = - SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, - providerToDouble = Nothing, - providerToDoubleStats = - Just $ fmap listSamplingStats $ readVar s, + fmap listSamplingStats $ + containerData s, providerToDoubleList = - Just $ readVar s, - providerToInt = Nothing, + Just $ + containerData s, + providerToInt = Nothing, providerToIntStats = Nothing, providerToIntList = Nothing, - providerToString = Nothing, - providerSignal = Nothing }] } + providerToString = + Just $ + fmap show $ + containerData s, + providerSignal = + containerSignal s } ] } -instance Series (Var [Int]) where +instance SeriesContainer c => Series (c [Int]) where seriesEntity name s = SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, + [SeriesProvider { providerName = name, providerToDouble = Nothing, providerToDoubleStats = Just $ fmap fromIntSamplingStats $ - fmap listSamplingStats $ readVar s, + fmap listSamplingStats $ + containerData s, providerToDoubleList = - Just $ fmap (map fromIntegral) $ readVar s, - providerToInt = Nothing, + Just $ + fmap (map fromIntegral) $ + containerData s, + providerToInt = Nothing, providerToIntStats = - Just $ fmap listSamplingStats $ readVar s, + Just $ + fmap listSamplingStats $ + containerData s, providerToIntList = - Just $ readVar s, - providerToString = Nothing, - providerSignal = Nothing }] } + Just $ + containerData s, + providerToString = + Just $ + fmap show $ + containerData s, + providerSignal = + containerSignal s } ] } -instance Ix i => Series (Simulation (Array i Double)) where +instance (Ix i, SeriesContainer c) => Series (c (Array i Double)) where seriesEntity name s = SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, + [SeriesProvider { providerName = name, providerToDouble = Nothing, providerToDoubleStats = - Just $ liftSimulation $ + Just $ fmap listSamplingStats $ - fmap elems s, + fmap A.elems $ + containerData s, providerToDoubleList = - Just $ liftSimulation $ - fmap elems s, - providerToInt = Nothing, + Just $ + fmap A.elems $ + containerData s, + providerToInt = Nothing, providerToIntStats = Nothing, providerToIntList = Nothing, providerToString = Nothing, - providerSignal = Nothing }] } + providerSignal = + containerSignal s } ] } -instance Ix i => Series (Simulation (Array i Int)) where +instance (Ix i, SeriesContainer c) => Series (c (Array i Int)) where seriesEntity name s = SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, + [SeriesProvider { providerName = name, providerToDouble = Nothing, providerToDoubleStats = - Just $ liftSimulation $ + Just $ fmap fromIntSamplingStats $ fmap listSamplingStats $ - fmap elems s, + fmap A.elems $ + containerData s, providerToDoubleList = - Just $ liftSimulation $ + Just $ fmap (map fromIntegral) $ - fmap elems s, - providerToInt = Nothing, + fmap A.elems $ + containerData s, + providerToInt = Nothing, providerToIntStats = - Just $ liftSimulation $ + Just $ fmap listSamplingStats $ - fmap elems s, + fmap A.elems $ + containerData s, providerToIntList = - Just $ liftSimulation $ - fmap elems s, + Just $ + fmap A.elems $ + containerData s, providerToString = Nothing, - providerSignal = Nothing }] } + providerSignal = + containerSignal s } ] } -instance Ix i => Series (Dynamics (Array i Double)) where +instance (Ix i, SeriesContainer c) => Series (c (UArray i Double)) where seriesEntity name s = SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, + [SeriesProvider { providerName = name, providerToDouble = Nothing, providerToDoubleStats = Just $ fmap listSamplingStats $ - fmap elems s, + fmap UA.elems $ + containerData s, providerToDoubleList = - Just $ fmap elems s, - providerToInt = Nothing, + Just $ + fmap UA.elems $ + containerData s, + providerToInt = Nothing, providerToIntStats = Nothing, providerToIntList = Nothing, providerToString = Nothing, - providerSignal = Nothing }] } + providerSignal = + containerSignal s } ] } -instance Ix i => Series (Dynamics (Array i Int)) where +instance (Ix i, SeriesContainer c) => Series (c (UArray i Int)) where seriesEntity name s = SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, + [SeriesProvider { providerName = name, providerToDouble = Nothing, providerToDoubleStats = Just $ fmap fromIntSamplingStats $ fmap listSamplingStats $ - fmap elems s, + fmap UA.elems $ + containerData s, providerToDoubleList = Just $ fmap (map fromIntegral) $ - fmap elems s, - providerToInt = Nothing, + fmap UA.elems $ + containerData s, + providerToInt = Nothing, providerToIntStats = Just $ fmap listSamplingStats $ - fmap elems s, + fmap UA.elems $ + containerData s, providerToIntList = - Just $ fmap elems s, + Just $ + fmap UA.elems $ + containerData s, providerToString = Nothing, - providerSignal = Nothing }] } - + providerSignal = + containerSignal s } ] } -instance Ix i => Series (Ref (Array i Double)) where +instance SeriesContainer c => Series (c (V.Vector Double)) where seriesEntity name s = SeriesEntity { seriesProviders = @@ -1070,16 +867,23 @@ providerToDoubleStats = Just $ fmap listSamplingStats $ - fmap elems $ readRef s, + fmap V.toList $ + containerData s, providerToDoubleList = - Just $ fmap elems $ readRef s, - providerToInt = Nothing, + Just $ + fmap V.toList $ + containerData s, + providerToInt = Nothing, providerToIntStats = Nothing, providerToIntList = Nothing, - providerToString = Nothing, - providerSignal = Nothing }] } + providerToString = + Just $ + fmap show $ + containerData s, + providerSignal = + containerSignal s } ] } -instance Ix i => Series (Ref (Array i Int)) where +instance SeriesContainer c => Series (c (V.Vector Int)) where seriesEntity name s = SeriesEntity { seriesProviders = @@ -1089,64 +893,85 @@ Just $ fmap fromIntSamplingStats $ fmap listSamplingStats $ - fmap elems $ readRef s, + fmap V.toList $ + containerData s, providerToDoubleList = Just $ fmap (map fromIntegral) $ - fmap elems $ readRef s, - providerToInt = Nothing, + fmap V.toList $ + containerData s, + providerToInt = Nothing, providerToIntStats = Just $ fmap listSamplingStats $ - fmap elems $ readRef s, + fmap V.toList $ + containerData s, providerToIntList = Just $ - fmap elems $ readRef s, - providerToString = Nothing, - providerSignal = Nothing }] } - + fmap V.toList $ + containerData s, + providerToString = + Just $ + fmap show $ + containerData s, + providerSignal = + containerSignal s }] } -instance Ix i => Series (Var (Array i Double)) where +instance SeriesContainer c => Series (c (UV.Vector Double)) where seriesEntity name s = SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, + [SeriesProvider { providerName = name, providerToDouble = Nothing, providerToDoubleStats = Just $ fmap listSamplingStats $ - fmap elems $ readVar s, + fmap UV.toList $ + containerData s, providerToDoubleList = Just $ - fmap elems $ readVar s, - providerToInt = Nothing, + fmap UV.toList $ + containerData s, + providerToInt = Nothing, providerToIntStats = Nothing, providerToIntList = Nothing, - providerToString = Nothing, - providerSignal = Nothing }] } + providerToString = + Just $ + fmap show $ + containerData s, + providerSignal = + containerSignal s } ] } -instance Ix i => Series (Var (Array i Int)) where +instance SeriesContainer c => Series (c (UV.Vector Int)) where seriesEntity name s = SeriesEntity { seriesProviders = - [SeriesProvider { providerName = name, + [SeriesProvider { providerName = name, providerToDouble = Nothing, providerToDoubleStats = Just $ fmap fromIntSamplingStats $ fmap listSamplingStats $ - fmap elems $ readVar s, + fmap UV.toList $ + containerData s, providerToDoubleList = Just $ fmap (map fromIntegral) $ - fmap elems $ readVar s, - providerToInt = Nothing, + fmap UV.toList $ + containerData s, + providerToInt = Nothing, providerToIntStats = Just $ fmap listSamplingStats $ - fmap elems $ readVar s, + fmap UV.toList $ + containerData s, providerToIntList = Just $ - fmap elems $ readVar s, - providerToString = Nothing, - providerSignal = Nothing }] } + fmap UV.toList $ + containerData s, + providerToString = + Just $ + fmap show $ + containerData s, + providerSignal = + containerSignal s } ] } diff --git a/Simulation/Aivika/Experiment/FinalStatsView.hs b/Simulation/Aivika/Experiment/FinalStatsView.hs --- a/Simulation/Aivika/Experiment/FinalStatsView.hs +++ b/Simulation/Aivika/Experiment/FinalStatsView.hs @@ -131,20 +131,15 @@ error "Series with different names are returned for different runs: simulateFinalStats" results <- liftIO $ fmap fromJust $ readIORef (finalStatsResults st) let values = finalStatsValues results - t0 <- starttime - enqueue (experimentQueue expdata) t0 $ - do let h = filterSignalM (const predicate) $ - experimentSignalInStopTime expdata - -- we must subscribe through the event queue; - -- otherwise, we will loose a signal in the start time, - -- because the handleSignal_ function checks the event queue - handleSignal_ h $ \_ -> - do xs <- sequence input - liftIO $ withMVar lock $ \() -> - forM_ (zip xs values) $ \(x, values) -> - do y <- readIORef values - let y' = addDataToSamplingStats x y - y' `seq` writeIORef values y' + h = filterSignalM (const predicate) $ + experimentSignalInStopTime expdata + handleSignal_ h $ \_ -> + do xs <- sequence input + liftIO $ withMVar lock $ \() -> + forM_ (zip xs values) $ \(x, values) -> + do y <- readIORef values + let y' = addDataToSamplingStats x y + y' `seq` writeIORef values y' return $ return () -- | Get the HTML code. diff --git a/Simulation/Aivika/Experiment/FinalTableView.hs b/Simulation/Aivika/Experiment/FinalTableView.hs --- a/Simulation/Aivika/Experiment/FinalTableView.hs +++ b/Simulation/Aivika/Experiment/FinalTableView.hs @@ -64,7 +64,7 @@ -- An example is -- -- @ - -- finalTableFileName = UniqueFileName \"$TITLE\", \".csv\" + -- finalTableFileName = UniqueFileName \"$TITLE\" \".csv\" -- @ finalTableSeparator :: String, -- ^ It defines the separator for the view. @@ -168,18 +168,13 @@ error "Series with different names are returned for different runs: simulateFinalTable" results <- liftIO $ fmap fromJust $ readIORef (finalTableResults st) let values = finalTableValues results - t <- time - enqueue (experimentQueue expdata) t $ - do let h = filterSignalM (const predicate) $ - experimentSignalInStopTime expdata - -- we must subscribe through the event queue; - -- otherwise, we will loose a signal in the start time, - -- because the handleSignal_ function checks the event queue - handleSignal_ h $ \_ -> - do xs <- sequence input - i <- liftSimulation simulationIndex - liftIO $ withMVar lock $ \() -> - modifyIORef values $ M.insert i xs + h = filterSignalM (const predicate) $ + experimentSignalInStopTime expdata + handleSignal_ h $ \_ -> + do xs <- sequence input + i <- liftSimulation simulationIndex + liftIO $ withMVar lock $ \() -> + modifyIORef values $ M.insert i xs return $ return () -- | Save the results in the CSV file after the simulation is complete. @@ -203,10 +198,10 @@ -- create a new file h <- liftIO $ openFile file WriteMode -- write a header - hPutStr h run + hPutStr h $ show run forM_ names $ \name -> do hPutStr h separator - hPutStr h name + hPutStr h $ show name hPutStrLn h "" -- write data forM_ (M.assocs m) $ \(i, xs) -> diff --git a/Simulation/Aivika/Experiment/LastValueView.hs b/Simulation/Aivika/Experiment/LastValueView.hs --- a/Simulation/Aivika/Experiment/LastValueView.hs +++ b/Simulation/Aivika/Experiment/LastValueView.hs @@ -105,12 +105,7 @@ " as a string: simulateLastValues" Just input -> (providerName provider, input) i <- liftSimulation simulationIndex - t <- time - enqueue (experimentQueue expdata) t $ - -- we must subscribe through the event queue; - -- otherwise, we will loose a signal in the start time, - -- because the handleSignal_ function checks the event queue - handleSignal_ (experimentSignalInStopTime expdata) $ \t -> + handleSignal_ (experimentSignalInStopTime expdata) $ \t -> do let r = fromJust $ M.lookup (i - 1) (lastValueMap st) output <- forM input $ \(name, input) -> do x <- input diff --git a/Simulation/Aivika/Experiment/TableView.hs b/Simulation/Aivika/Experiment/TableView.hs --- a/Simulation/Aivika/Experiment/TableView.hs +++ b/Simulation/Aivika/Experiment/TableView.hs @@ -82,7 +82,7 @@ -- An example is -- -- @ - -- tableFileName = UniqueFileName \"$TITLE - $RUN_INDEX\", \".csv\" + -- tableFileName = UniqueFileName \"$TITLE - $RUN_INDEX\" \".csv\" -- @ tableSeparator :: String, -- ^ It defines the separator for the view. @@ -172,14 +172,9 @@ do forM_ (zip [0..] providers) $ \(column, provider) -> do when (column > 0) $ hPutStr h separator - hPutStr h $ providerName provider + hPutStr h $ show $ providerName provider hPutStrLn h "" - t <- time - enqueue (experimentQueue expdata) t $ - -- we must subscribe through the event queue; - -- otherwise, we will loose a signal in the start time, - -- because the handleSignal_ function checks the event queue - handleSignal_ (experimentMixedSignal expdata providers) $ \t -> + handleSignal_ (experimentMixedSignal expdata providers) $ \t -> do p <- predicate when p $ do forM_ (zip [0..] input) $ \(column, input) -> -- write the row diff --git a/Simulation/Aivika/Experiment/TimingStatsView.hs b/Simulation/Aivika/Experiment/TimingStatsView.hs --- a/Simulation/Aivika/Experiment/TimingStatsView.hs +++ b/Simulation/Aivika/Experiment/TimingStatsView.hs @@ -122,11 +122,7 @@ liftIO $ modifyIORef r ((:) (name, stats)) let h = filterSignalM (const predicate) $ experimentMixedSignal expdata [provider] - enqueue (experimentQueue expdata) t $ - -- we must subscribe through the event queue; - -- otherwise, we will loose a signal in the start time, - -- because the handleSignal_ function checks the event queue - handleSignal_ h $ \_ -> + handleSignal_ h $ \_ -> do t <- time x <- input liftIO $ diff --git a/aivika-experiment.cabal b/aivika-experiment.cabal --- a/aivika-experiment.cabal +++ b/aivika-experiment.cabal @@ -1,5 +1,5 @@ name: aivika-experiment -version: 0.3 +version: 0.3.1 synopsis: Simulation experiments for the Aivika library description: This package allows defining simulation experiments for the Aivika @@ -21,6 +21,8 @@ tested-with: GHC == 7.6.3 extra-source-files: examples/MachRep3.hs + examples/LinearArray.hs + examples/README library @@ -43,6 +45,7 @@ build-depends: base >= 3 && < 6, mtl >= 1.1.0.2, array >= 0.3.0.0, + vector >= 0.9, containers >= 0.4.0.0, directory >= 1.1.0.2, filepath >= 1.3.0.0, @@ -50,7 +53,7 @@ split >= 0.2.2, network >= 2.3.0.13, parallel-io >= 0.3.2.1, - aivika >= 0.6 + aivika >= 0.6.1 extensions: FlexibleInstances diff --git a/examples/LinearArray.hs b/examples/LinearArray.hs new file mode 100644 --- /dev/null +++ b/examples/LinearArray.hs @@ -0,0 +1,83 @@ + +-- The model demonstrates using the arrays +-- as described in model Linear Array from Berkeley Madonna. +-- +-- It defines only one helper function generateArray. +-- If the model used vectors (Data.Vector) then there would be +-- no need in this helper function. + +{-# LANGUAGE RecursiveDo #-} + +import Data.Array +import Control.Monad +import Control.Monad.Trans + +import qualified Data.Vector as V + +import Simulation.Aivika.Dynamics +import Simulation.Aivika.Dynamics.Simulation +import Simulation.Aivika.Dynamics.SystemDynamics +import Simulation.Aivika.Dynamics.EventQueue +import Simulation.Aivika.Dynamics.Base +import Simulation.Aivika.Dynamics.Signal + +import Simulation.Aivika.Experiment +import Simulation.Aivika.Experiment.LastValueView +import Simulation.Aivika.Experiment.TableView +import Simulation.Aivika.Experiment.ExperimentSpecsView +import Simulation.Aivika.Experiment.FinalStatsView +import Simulation.Aivika.Experiment.TimingStatsView +import Simulation.Aivika.Experiment.FinalTableView + +specs = Specs { spcStartTime = 0, + spcStopTime = 500, + spcDT = 0.1, + spcMethod = RungeKutta4 } + +-- | 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) +generateArray bnds generator = + do ps <- forM (range bnds) $ \i -> + do x <- generator i + return (i, x) + return $ array bnds ps + +model :: Int -> Simulation ExperimentData +model n = + mdo queue <- newQueue + m <- generateArray (1, n) $ \i -> + integ (q + k * (c!(i - 1) - c!i) + k * (c!(i + 1) - c!i)) 0 + let c = + array (0, n + 1) [(i, if (i == 0) || (i == n + 1) + then 0 + else (m!i / v)) | i <- [0 .. n + 1]] + q = 1 + k = 2 + v = 0.75 + experimentDataInStartTime queue + [("t", seriesEntity "time" time), + ("m", seriesEntity "M" m), + ("c", seriesEntity "C" c)] + +experiment :: Experiment +experiment = + defaultExperiment { + experimentSpecs = specs, + experimentRunCount = 1, + experimentTitle = "Linear Array", + experimentDescription = "Model Linear Array as described in " ++ + "the examples included in Berkeley-Madonna.", + experimentGenerators = + [outputView defaultExperimentSpecsView, + outputView $ defaultTableView { + tableSeries = ["t", "m", "c"] }, + outputView $ defaultFinalTableView { + finalTableSeries = ["m", "c"] }, + outputView $ defaultLastValueView { + lastValueSeries = ["t", "m", "c"] }, + outputView $ defaultTimingStatsView { + timingStatsSeries = ["t", "m", "c"] }, + outputView $ defaultFinalStatsView { + finalStatsSeries = ["m", "c"] } ] } + +main = runExperiment experiment (model 51) diff --git a/examples/README b/examples/README new file mode 100644 --- /dev/null +++ b/examples/README @@ -0,0 +1,5 @@ +You may find more examples on GitHub by the following link: + +https://github.com/dsorokin/aivika-models + +July 18, 2013