rollup, sliding and fixed windows

src/AFRP.hs

@@ -25,6 +25,9 @@ module AFRP
   , isEvent
   , delayEvent
   , sample
+  , rollup
+  , sliding
+  , fixed
   ) where
 
 import Control.Category (Category(..), (>>>))
@@ -34,6 +37,7 @@ import Data.Time (UTCTime, NominalDiffTime, diffUTCTime, addUTCTime)
 import Control.Monad.Fix (MonadFix (mfix))
 import Data.Either (fromLeft)
 import Data.Bool (bool)
+import Data.Monoid (Endo(..))
 import Data.UUID (UUID)
 
 data Request = Request
@@ -221,5 +225,44 @@ duration :: forall eff a. Mealy eff a NominalDiffTime
 duration = mapAccumRequest go (Nothing @(UTCTime, NominalDiffTime)) (maybe 0 snd)
   where
     go :: Request -> Maybe (UTCTime, NominalDiffTime) -> a -> Maybe (UTCTime, NominalDiffTime)
-    go req Nothing _ = Just $ (requestTime req, requestTime req `diffUTCTime` requestTime req)
+    go req Nothing _ = Just (requestTime req, requestTime req `diffUTCTime` requestTime req)
     go req (Just (startTime, _)) _ = Just (startTime, requestTime req `diffUTCTime` startTime)
+
+
+
+rollup :: Int -> Int -> Mealy eff (Event a) (Event [a])
+rollup limit seconds = mapAccumRequest go (Left Tick) (either id (\(_, _, _, ev) -> ev))
+  where
+    e a = Endo ([a] ++)
+    go :: Request -> Either (Event [a]) (UTCTime, Int, Endo [a], Event [a]) -> Event a -> Either (Event [a]) (UTCTime, Int, Endo [a], Event [a])
+    go _ (Left _) Tick = Left Tick
+    go req (Left _) (Event a) = Right (addUTCTime (fromIntegral seconds) (requestTime req), 1, mempty, Event [a])
+    go req (Right (end, n, acc, _)) Tick
+      | requestTime req >= end = Left (Event $ appEndo acc [])
+      | otherwise = Right (end, n, acc, Tick)
+    go req (Right (end, n, acc, _)) (Event a)
+      | requestTime req >= end = Left (Event $ appEndo acc [a])
+      | n < limit = Right (end, n+1, acc, Event [a])
+      | otherwise = Right (end, n+1, acc <> e a, Tick)
+
+-- Sliding window into the events
+sliding :: Int -> Mealy eff (Event a) [a]
+sliding size = mapAccum go [] id
+  where
+    go :: [a] -> Event a -> [a]
+    go acc Tick = acc
+    go acc (Event a) = take size (acc ++ [a])
+
+fixed :: Int -> Mealy eff (Event a) [a]
+fixed seconds = mapAccumRequest go Nothing (maybe [] ((`appEndo` []) . snd))
+  where
+    e a = Endo ([a] ++)
+    go :: Request -> Maybe (UTCTime, Endo [a]) -> Event a -> Maybe (UTCTime, Endo [a])
+    go req Nothing Tick = Just (addUTCTime (fromIntegral seconds) (requestTime req), mempty)
+    go req Nothing (Event a) = Just (addUTCTime (fromIntegral seconds) (requestTime req), e a)
+    go req (Just (end, acc)) ev =
+      case ev of
+           Tick | requestTime req >= end -> Just (addUTCTime (fromIntegral seconds) end, mempty)
+                | otherwise -> Just (end, acc)
+           Event a | requestTime req >= end -> Just (addUTCTime (fromIntegral seconds) end, e a)
+                   | otherwise -> Just (end, acc <> e a)