From d341270ed14705dff2e621d0c63d8050dc28dffe Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Tue, 25 Aug 2026 10:11:44 +0300 Subject: [PATCH] rollup, sliding and fixed windows --- default.nix | 2 +- home-assistant-controller.cabal | 1 + src/AFRP.hs | 45 ++++++++++++++++++++++++++- src/HomeAssistant/Controller.hs | 18 +---------- src/HomeAssistant/Controller/Ruuvi.hs | 31 ++++++++++++++++++ src/HomeAssistant/Runtime.hs | 2 ++ 6 files changed, 80 insertions(+), 19 deletions(-) create mode 100644 src/HomeAssistant/Controller/Ruuvi.hs diff --git a/default.nix b/default.nix index 6618ebe..f2c7cc6 100644 --- a/default.nix +++ b/default.nix @@ -15,7 +15,7 @@ mkDerivation { executableHaskellDepends = [ base ]; testHaskellDepends = [ aeson annotated-exception async base hedgehog hspec hspec-hedgehog - stm text time + katip stm text time uuid ]; license = lib.meta.getLicenseFromSpdxId "BSD-3-Clause"; mainProgram = "home-assistant-controller"; diff --git a/home-assistant-controller.cabal b/home-assistant-controller.cabal index 92b0a71..866a768 100644 --- a/home-assistant-controller.cabal +++ b/home-assistant-controller.cabal @@ -62,6 +62,7 @@ library exposed-modules: AFRP , HomeAssistant.Controller , HomeAssistant.Controller.Bedroom + , HomeAssistant.Controller.Ruuvi , HomeAssistant.Runtime , HomeAssistant.Runtime.Bus , HomeAssistant.Runtime.Connection diff --git a/src/AFRP.hs b/src/AFRP.hs index e0634aa..0a0402a 100644 --- a/src/AFRP.hs +++ b/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) diff --git a/src/HomeAssistant/Controller.hs b/src/HomeAssistant/Controller.hs index ad63c81..10bdf52 100644 --- a/src/HomeAssistant/Controller.hs +++ b/src/HomeAssistant/Controller.hs @@ -14,10 +14,6 @@ module HomeAssistant.Controller , entityRead' , entityBool , entityBool' - , Ruuvi(..) - , ruuvi - , ruuviTemperatures - , ruuviPressures , DoorState(..) , light , Presence(..) @@ -29,7 +25,7 @@ module HomeAssistant.Controller , Target(..) ) where -import AFRP (Mealy (..), eff, Event(..), hold, events, changes, filterA, (>>|), toEvent, Request) +import AFRP (Mealy (..), eff, Event(..), events, filterA, (>>|), toEvent, Request) import Control.Arrow (Arrow(..), returnA) import Control.Category ((>>>)) import Data.Aeson (Value) @@ -75,18 +71,6 @@ traceValue = proc x -> do eff Trace -< x returnA -< x -ruuviTemperatures :: Mealy eff (Event Value) Double -ruuviTemperatures = entityRead @Double "sensor.ruuvitag_b168_temperature" >>> hold 0 - -ruuviPressures :: Mealy eff (Event Value) Double -ruuviPressures = entityRead "sensor.ruuvitag_b168_pressure" >>> hold 0 - -data Ruuvi = Ruuvi { ruuviTemperature :: Double, ruuviPressure :: Double } - deriving (Show, Eq) - -ruuvi :: Mealy eff (Event Value) (Event Ruuvi) -ruuvi = (Ruuvi <$> ruuviTemperatures <*> ruuviPressures) >>> changes - data DoorState = Open | Closed deriving (Show, Eq) diff --git a/src/HomeAssistant/Controller/Ruuvi.hs b/src/HomeAssistant/Controller/Ruuvi.hs new file mode 100644 index 0000000..30e5bbc --- /dev/null +++ b/src/HomeAssistant/Controller/Ruuvi.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE Arrows #-} +{-# LANGUAGE OverloadedStrings #-} +module HomeAssistant.Controller.Ruuvi + ( Ruuvi(..) + , ruuvi + , ruuviTemperatures + , ruuviPressures + , ruuviController + ) where + +import AFRP (Mealy, Event, hold, changes, rollup) +import Control.Category ((>>>)) +import Data.Aeson (Value) +import HomeAssistant.Controller (entityRead, traceEvent, HASS) +import Control.Arrow (Arrow(..)) + +ruuviTemperatures :: Mealy eff (Event Value) Double +ruuviTemperatures = entityRead @Double "sensor.ruuvitag_b168_temperature" >>> hold 0 + +ruuviPressures :: Mealy eff (Event Value) Double +ruuviPressures = entityRead "sensor.ruuvitag_b168_pressure" >>> hold 0 + +data Ruuvi = Ruuvi { ruuviTemperature :: Double, ruuviPressure :: Double } + deriving (Show, Eq) + +ruuvi :: Mealy eff (Event Value) (Event Ruuvi) +ruuvi = (Ruuvi <$> ruuviTemperatures <*> ruuviPressures) >>> changes + + +ruuviController :: HASS (Event Value) () +ruuviController = ruuvi >>> rollup 1 30 >>> traceEvent >>> arr (const ()) diff --git a/src/HomeAssistant/Runtime.hs b/src/HomeAssistant/Runtime.hs index 69cb631..e762515 100644 --- a/src/HomeAssistant/Runtime.hs +++ b/src/HomeAssistant/Runtime.hs @@ -32,6 +32,7 @@ import qualified Data.UUID.V4 as UUID.V4 import Katip (runKatipT, logF, sl, Severity (..), ls, Namespace (Namespace), runKatipContextT) import Control.Monad.IO.Class (liftIO, MonadIO) import Control.Monad.Fix (MonadFix) +import HomeAssistant.Controller.Ruuvi (ruuviController) step :: (MonadFix m, MonadIO m) => (forall x. eff x -> m x) -> UUID -> Mealy eff a b -> a -> m (b, Mealy eff a b) step nt trace (Mealy f) a = do @@ -46,6 +47,7 @@ controllers = , Controller "bedroom-button" bedroomButtonController False -- This works but leaving for vacation , Controller "bedroom-drawer" bedroomDrawerController True , Controller "bedroom-humidifier" humidifierController True + , Controller "ruuvi-controller" ruuviController True ] -- | Steps the machine for every inbound message; service calls go to the