HUmidifier logic with some extra new primitives

src/AFRP.hs

@@ -19,12 +19,18 @@ module AFRP
   , toEvent
   , lMerge
   , Request(..)
+  , edge
+  , duration
+  , tag
+  , isEvent
+  , delayEvent
+  , sample
   ) where
 
 import Control.Category (Category(..), (>>>))
 import Prelude hiding ((.), id)
 import Control.Arrow (Arrow(..), ArrowChoice(..), ArrowLoop(..))
-import Data.Time (UTCTime)
+import Data.Time (UTCTime, NominalDiffTime, diffUTCTime, addUTCTime)
 import Control.Monad.Fix (MonadFix (mfix))
 import Data.Either (fromLeft)
 import Data.Bool (bool)
@@ -95,6 +101,13 @@ events = arr $ \case
   Tick -> Left ()
   Event a -> Right a
 
+isEvent :: Event a -> Bool
+isEvent Tick = False
+isEvent _ = True
+
+tag :: b -> Event a -> Event b
+tag b ev = b <$ ev
+
 switch :: Mealy eff a (b, Event c) -> (c -> Mealy eff a b) -> Mealy eff a b
 switch (Mealy f) s = Mealy $ \nt t a -> do
   ((b, ev), f') <- f nt t a
@@ -102,6 +115,9 @@ switch (Mealy f) s = Mealy $ \nt t a -> do
           Tick -> pure (b, switch f' s)
           Event x -> runMealy (s x) nt t a
 
+sample :: Mealy eff (a, Event b) (Event a)
+sample = arr (uncurry tag)
+
 preMapAccum :: (x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
 preMapAccum f x extract = go x
   where
@@ -130,6 +146,34 @@ mapAccumRequest f x extract = go x
       let next = f t b a
       in pure (extract next, go next)
 
+data DelayState a = DelayState
+  { pending :: [(UTCTime, a)]
+  , output  :: Event a
+  }
+
+
+delayEvent :: NominalDiffTime -> Mealy eff (Event a) (Event a)
+delayEvent delay =
+  mapAccumRequest step initial output
+  where
+    initial = DelayState [] Tick
+
+    step req st input =
+      let now = requestTime req
+
+          queued =
+            case input of
+              Tick    -> pending st
+              Event x -> pending st ++ [(delay `addUTCTime` now, x)]
+
+      in case queued of
+           (due, x) : rest
+             | due <= now ->
+                 DelayState rest (Event x)
+
+           _ ->
+                 DelayState queued Tick
+
 changes :: Eq a => Mealy eff a (Event a)
 changes = mapAccum go Nothing (maybe Tick snd)
   where
@@ -161,3 +205,21 @@ lMerge :: Event a -> Event a -> Event a
 lMerge Tick Tick = Tick
 lMerge (Event a) _ = Event a
 lMerge Tick (Event a) = Event a
+
+edge :: Mealy eff Bool (Event ())
+edge = go False
+  where
+    go True = Mealy $ \_ _ -> \case
+      True -> pure (Tick, go True)
+      False -> pure (Tick, go False)
+    go False = Mealy $ \_ _ -> \case
+      True -> pure (Event (), go True)
+      False -> pure (Tick, go False)
+
+
+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 (Just (startTime, _)) _ = Just (startTime, requestTime req `diffUTCTime` startTime)