diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,11 @@ +Version 0.5 +----- + +* Added the latticeTimes and enqueueWithLatticeTimes functions. + +* Added the latticeParentMemberIndex function. + Version 0.4 ----- diff --git a/Simulation/Aivika/Lattice/Internal/LIO.hs b/Simulation/Aivika/Lattice/Internal/LIO.hs --- a/Simulation/Aivika/Lattice/Internal/LIO.hs +++ b/Simulation/Aivika/Lattice/Internal/LIO.hs @@ -28,7 +28,9 @@ lioParamsAt, latticeTimeIndex, latticeMemberIndex, + latticeParentMemberIndex, latticeTime, + latticeTimes, latticeTimeStep, latticePoint, latticeSize, @@ -45,6 +47,7 @@ import Simulation.Aivika.Trans.Exception import Simulation.Aivika.Trans.Internal.Types +import Simulation.Aivika.Trans.Internal.Specs import Simulation.Aivika.Trans.Parameter import Simulation.Aivika.Lattice.Internal.Lattice @@ -190,34 +193,37 @@ latticeMemberIndex :: LIO Int latticeMemberIndex = LIO $ return . lioMemberIndex +-- | Return the parent member index starting from 0 for non-root lattice nodes. +latticeParentMemberIndex :: LIO (Maybe Int) +latticeParentMemberIndex = LIO $ return . fmap lioMemberIndex . parentLIOParams + -- | Return the time for the current lattice node. latticeTime :: Parameter LIO Double latticeTime = Parameter $ \r -> LIO $ \ps -> - let sc = runSpecs r - t0 = spcStartTime sc - t2 = spcStopTime sc - m = lioSize $ lioLattice ps - dt = (t2 - t0) / (fromIntegral m) - i = lioTimeIndex ps - t = t0 + (fromInteger $ toInteger i) * dt - in return t + let i = lioTimeIndex ps + in invokeLIO ps $ + invokeParameter r $ + getLatticeTimeByIndex i +-- | Return the time values in the lattice nodes. +latticeTimes :: Parameter LIO [Double] +latticeTimes = + Parameter $ \r -> + LIO $ \ps -> + let m = lioSize $ lioLattice ps + in forM [0 .. m] $ \i -> + invokeLIO ps $ + invokeParameter r $ + getLatticeTimeByIndex i + -- | Return the point in the corresponding lattice node. latticePoint :: Parameter LIO (Point LIO) latticePoint = Parameter $ \r -> do t <- invokeParameter r latticeTime - let sc = runSpecs r - t0 = spcStartTime sc - dt = spcDT sc - n = fromIntegral $ floor ((t - t0) / dt) - return Point { pointSpecs = sc, - pointRun = r, - pointTime = t, - pointIteration = n, - pointPhase = -1 } + return $ pointAt r t -- | Return the lattice time step. latticeTimeStep :: Parameter LIO Double @@ -236,7 +242,7 @@ latticeSize = LIO $ return . lioSize . lioLattice -- | Find the lattice time index by the specified modeling time. -findLatticeTimeIndex :: Double -> Parameter LIO Double +findLatticeTimeIndex :: Double -> Parameter LIO Int findLatticeTimeIndex t = Parameter $ \r -> LIO $ \ps -> @@ -244,5 +250,22 @@ t0 = spcStartTime sc t2 = spcStopTime sc m = lioSize $ lioLattice ps - i = fromIntegral $ floor (fromIntegral m * ((t - t0) / (t2 - t0))) + i | t == t0 = 0 + | t == t2 = m + | otherwise = floor (fromIntegral m * ((t - t0) / (t2 - t0))) return i + +-- | Get the modeling time in the lattice node by the specified time index. +getLatticeTimeByIndex :: Int -> Parameter LIO Double +getLatticeTimeByIndex i = + Parameter $ \r -> + LIO $ \ps -> + let sc = runSpecs r + t0 = spcStartTime sc + t2 = spcStopTime sc + m = lioSize $ lioLattice ps + dt = (t2 - t0) / (fromIntegral m) + t | i == 0 = t0 + | i == m = t2 + | otherwise = t0 + (fromInteger $ toInteger i) * dt + in return t diff --git a/Simulation/Aivika/Lattice/LIO.hs b/Simulation/Aivika/Lattice/LIO.hs --- a/Simulation/Aivika/Lattice/LIO.hs +++ b/Simulation/Aivika/Lattice/LIO.hs @@ -17,11 +17,15 @@ runLIO, latticeTimeIndex, latticeMemberIndex, + latticeParentMemberIndex, latticeSize, latticeTime, + latticeTimes, latticeTimeStep, - findLatticeTimeIndex) where + findLatticeTimeIndex, + enqueueEventWithLatticeTimes) where +import Simulation.Aivika.Trans import Simulation.Aivika.Trans.Comp import Simulation.Aivika.Trans.DES import Simulation.Aivika.Trans.Exception @@ -45,4 +49,10 @@ instance EventIOQueueing LIO where enqueueEventIO = enqueueEvent + +-- | Actuate the event handler in the lattice node time points. +enqueueEventWithLatticeTimes :: Event LIO () -> Event LIO () +enqueueEventWithLatticeTimes m = + do ts <- liftParameter latticeTimes + enqueueEventWithTimes ts m diff --git a/aivika-lattice.cabal b/aivika-lattice.cabal --- a/aivika-lattice.cabal +++ b/aivika-lattice.cabal @@ -1,5 +1,5 @@ name: aivika-lattice -version: 0.4 +version: 0.5 synopsis: Nested discrete event simulation module for the Aivika library using lattice description: This experimental package extends the aivika-transformers [1] library and allows @@ -20,6 +20,7 @@ tested-with: GHC == 7.10.3 extra-source-files: CHANGELOG.md + tests/Distribution.hs tests/MachRep1.hs tests/TraversingLattice1.hs tests/TraversingLattice2.hs diff --git a/tests/Distribution.hs b/tests/Distribution.hs new file mode 100644 --- /dev/null +++ b/tests/Distribution.hs @@ -0,0 +1,44 @@ + +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Trans +import Simulation.Aivika.Lattice +import Simulation.Aivika.Experiment.Histogram + +meanUpTime = 1.0 +meanRepairTime = 0.5 + +specs = Specs { spcStartTime = 0.0, + spcStopTime = 1000.0, + spcDT = 0.1, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +model :: Simulation LIO Histogram +model = + do let latticeDistribution :: Estimate LIO [Int] + latticeDistribution = + do k <- liftComp latticeMemberIndex + return [k] + + let reduce :: [Int] -> [Int] -> Estimate LIO [Int] + reduce ks1 ks2 = return $ ks1 ++ ks2 + + let leaf = latticeDistribution + + ks <- foldEstimate reduce leaf + + runEstimateInStartTime $ + do xs <- ks + let ys = fmap (fromIntegral) xs + hs = histogram binScott [ys] + return hs + +main :: IO () +main = + do lat <- newRandomLattice 10 + hs <- runLIO lat $ + runSimulation model specs + putStrLn "Histogram:" + putStrLn (show hs) diff --git a/tests/EstimatingMachRep1.hs b/tests/EstimatingMachRep1.hs --- a/tests/EstimatingMachRep1.hs +++ b/tests/EstimatingMachRep1.hs @@ -71,7 +71,7 @@ main :: IO () main = - do lattice <- newRandomLattice 10 - a <- runLIO lattice $ + do lat <- newRandomLattice 10 + a <- runLIO lat $ runSimulation model specs print a diff --git a/tests/MachRep1.hs b/tests/MachRep1.hs --- a/tests/MachRep1.hs +++ b/tests/MachRep1.hs @@ -67,8 +67,8 @@ main :: IO () main = - do lattice <- newRandomLattice 10 - runLIO lattice $ + do lat <- newRandomLattice 10 + runLIO lat $ printSimulationResultsInStopTime printResultSourceInEnglish model specs diff --git a/tests/TraversingLattice1.hs b/tests/TraversingLattice1.hs --- a/tests/TraversingLattice1.hs +++ b/tests/TraversingLattice1.hs @@ -10,7 +10,7 @@ specs = Specs { spcStartTime = 0.0, spcStopTime = 1000.0, - spcDT = 100.0, + spcDT = 0.1, spcMethod = RungeKutta4, spcGeneratorType = SimpleGenerator } @@ -28,7 +28,7 @@ putStrLn "" runEventInStartTime $ - enqueueEventWithIntegTimes + enqueueEventWithLatticeTimes showLatticeNode runEventInStopTime $ @@ -36,6 +36,6 @@ main :: IO () main = - do lattice <- newRandomLattice 5 - runLIO lattice $ + do lat <- newRandomLattice 4 + runLIO lat $ runSimulation model specs diff --git a/tests/TraversingLattice2.hs b/tests/TraversingLattice2.hs --- a/tests/TraversingLattice2.hs +++ b/tests/TraversingLattice2.hs @@ -10,7 +10,7 @@ specs = Specs { spcStartTime = 0.0, spcStopTime = 1000.0, - spcDT = 400.0, + spcDT = 0.1, spcMethod = RungeKutta4, spcGeneratorType = SimpleGenerator } @@ -29,7 +29,7 @@ putStrLn "" runEventInStartTime $ - enqueueEventWithIntegTimes $ + enqueueEventWithLatticeTimes $ showLatticeNode "enqueue" let reduce a b = @@ -48,6 +48,6 @@ main :: IO () main = - do lattice <- newRandomLattice 5 - runLIO lattice $ + do lat <- newRandomLattice 4 + runLIO lat $ runSimulation model specs diff --git a/tests/TraversingLattice3.hs b/tests/TraversingLattice3.hs --- a/tests/TraversingLattice3.hs +++ b/tests/TraversingLattice3.hs @@ -10,7 +10,7 @@ specs = Specs { spcStartTime = 0.0, spcStopTime = 1000.0, - spcDT = 400.0, + spcDT = 0.1, spcMethod = RungeKutta4, spcGeneratorType = SimpleGenerator } @@ -29,7 +29,7 @@ putStrLn "" runEventInStartTime $ - enqueueEventWithIntegTimes $ + enqueueEventWithLatticeTimes $ showLatticeNode "enqueue" let reduce a b = @@ -48,6 +48,6 @@ main :: IO () main = - do lattice <- newRandomLattice 5 - runLIO lattice $ + do lat <- newRandomLattice 4 + runLIO lat $ runSimulation model specs diff --git a/tests/TraversingLattice4.hs b/tests/TraversingLattice4.hs --- a/tests/TraversingLattice4.hs +++ b/tests/TraversingLattice4.hs @@ -10,7 +10,7 @@ specs = Specs { spcStartTime = 0.0, spcStopTime = 1000.0, - spcDT = 400.0, + spcDT = 0.1, spcMethod = RungeKutta4, spcGeneratorType = SimpleGenerator } @@ -31,7 +31,7 @@ r <- newRef 0 runEventInStartTime $ - enqueueEventWithIntegTimes $ + enqueueEventWithLatticeTimes $ do x <- liftParameter $ randomUniform 0 1 writeRef r x showLatticeNode ("enqueue (x = " ++ show x ++ ")") @@ -59,6 +59,6 @@ main :: IO () main = - do lattice <- newRandomLattice 5 - runLIO lattice $ + do lat <- newRandomLattice 4 + runLIO lat $ runSimulation model specs diff --git a/tests/TraversingMachRep1.hs b/tests/TraversingMachRep1.hs --- a/tests/TraversingMachRep1.hs +++ b/tests/TraversingMachRep1.hs @@ -26,7 +26,7 @@ specs = Specs { spcStartTime = 0.0, spcStopTime = 1000.0, - spcDT = 100.0, + spcDT = 0.1, spcMethod = RungeKutta4, spcGeneratorType = SimpleGenerator } @@ -74,7 +74,7 @@ main :: IO () main = - do lattice <- newRandomLattice 5 - a <- runLIO lattice $ + do lat <- newRandomLattice 4 + a <- runLIO lat $ runSimulation model specs print a