@@ -1,3 +1,6 @@
1+{-# LANGUAGE ScopedTypeVariables #-}
2+{-# LANGUAGE TypeFamilies #-}
3+
14module Reflex.Dom.Time where
25
36import Reflex
@@ -8,6 +11,7 @@ import Control.Monad
811import Control.Monad.IO.Class
912import Data.Fixed
1013import Data.Time.Clock
14+import System.Random
1115import Data.Typeable
1216
1317data TickInfo
@@ -18,7 +22,7 @@ data TickInfo
1822 , _tickInfo_alreadyElapsed :: NominalDiffTime
1923 -- ^ Amount of time already elapsed in the current tick period.
2024 }
21− deriving (Eq, Ord, Typeable)
25+ deriving (Eq, Ord, Show, Typeable)
2226
2327-- | Special case of tickLossyFrom that uses the post-build event to start the
2428-- tick thread.
@@ -49,3 +53,105 @@ delay :: MonadWidget t m => NominalDiffTime -> Event t a -> m (Event t a)
4953delay dt e = performEventAsync $ ffor e $ \a cb -> liftIO $ void $ forkIO $ do
5054 threadDelay $ ceiling $ dt * 1000000
5155 cb a
56+
57+-- | Send events with Poisson timing with the given basis and rate
58+-- Each occurence of the resulting event will contain the index of
59+-- the current interval, with 0 representing the basis time
60+poissonLossyFrom
61+ :: (RandomGen g, MonadWidget t m)
62+ => g
63+ -> Double
64+ -- ^ Poisson event rate (Hz)
65+ -> UTCTime
66+ -- ^ Baseline time for events
67+ -> Event t a
68+ -- ^ Event that starts a tick generation thread. Usually you want this to
69+ -- be something like the result of getPostBuild that only fires once. But
70+ -- there could be uses for starting multiple timer threads.
71+ -- Start sending events in response to the event parameter.
72+ -> m (Event t TickInfo)
73+poissonLossyFrom rnd rate t0 t =
74+ inhomogeneousPoissonFrom rnd (current $ constDyn rate) rate t0 t
75+
76+
77+-- | Send events with Poisson timing with the given basis and rate
78+-- Each occurence of the resulting event will contain the index of
79+-- the current interval, with 0 representing the basis time.
80+-- Automatically begin sending events when the DOM is built
81+poissonLossy
82+ :: (RandomGen g, MonadWidget t m)
83+ => g
84+ -> Double
85+ -- ^ Poisson event rate (Hz)
86+ -> UTCTime
87+ -- ^ Baseline time for events
88+ -> m (Event t TickInfo)
89+poissonLossy rnd rate t0 = poissonLossyFrom rnd rate t0 =<< getPostBuild
90+
91+-- | Send events with inhomogeneous Poisson timing with the given basis
92+-- and variable rate. Provide a maxRate that you expect to support.
93+inhomogeneousPoissonFrom
94+ :: (RandomGen g, MonadWidget t m)
95+ => g
96+ -> Behavior t Double
97+ -> Double
98+ -> UTCTime
99+ -> Event t a
100+ -> m (Event t TickInfo)
101+inhomogeneousPoissonFrom rnd rate maxRate t0 e = do
102+
103+ -- Create a thread for producing homogeneous poisson events
104+ -- along with random Doubles (usage of Double's explained below)
105+ ticksWithRateRand <- performEventAsync $
106+ fmap callAtNextInterval e
107+
108+ -- Filter homogeneous events according to associated
109+ -- random values and the current rate parameter
110+ return $ attachWithMaybe filterFun rate ticksWithRateRand
111+
112+ where
113+
114+ -- Inhomogeneous poisson processes are built from faster
115+ -- homogeneous ones by randomly dropping events from the
116+ -- fast process. For each fast homogeneous event, choose
117+ -- a uniform random sample from (0, rMax). If the
118+ -- inhomogeneous rate at this moment is greater than the
119+ -- random sample, then keep this event, otherwise drop it
120+ filterFun :: Double -> (TickInfo, Double) -> Maybe TickInfo
121+ filterFun r (tInfo, p)
122+ | r >= p = Just tInfo
123+ | otherwise = Nothing
124+
125+ callAtNextInterval _ cb = void $ liftIO $ forkIO $ go t0 rnd cb 0
126+
127+ go tTargetLast lastGen cb lastN = do
128+ t <- getCurrentTime
129+
130+ -- Generate random numbers for this poisson interval (u)
131+ -- and sample-retention likelihood (p)
132+ let (u, nextGen) = randomR (0,1) lastGen
133+ (p :: Double, nextGen') = randomR (0,maxRate) nextGen
134+
135+ -- Inter-event interval is drawn from exponential
136+ -- distribution accourding to u
137+ let dt = realToFrac $ -1 * log(u)/maxRate :: NominalDiffTime
138+ offset = t `diffUTCTime` t0
139+ nEvents = lastN + 1
140+ alreadyElapsed = diffUTCTime t tTargetLast
141+ tTarget = addUTCTime dt tTargetLast
142+ thisDelay = realToFrac $ diffUTCTime tTarget t :: Double
143+ threadDelay $ ceiling $ thisDelay * 1000000
144+ void $ cb $ (TickInfo t nEvents alreadyElapsed, p)
145+ go tTarget nextGen' cb nEvents
146+
147+-- | Send events with inhomogeneous Poisson timing with the given basis
148+-- and variable rate. Provide a maxRate that you expect to support
149+inhomogeneousPoisson
150+ :: (RandomGen g, MonadWidget t m)
151+ => g
152+ -> Behavior t Double
153+ -> Double
154+ -> UTCTime
155+ -> m (Event t TickInfo)
156+inhomogeneousPoisson rnd rate maxRate t0 =
157+ inhomogeneousPoissonFrom rnd rate maxRate t0 =<< getPostBuild