From 96d4fb4c8d86805bcfa400c62dbca8417a65dd70 Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Fri, 21 Aug 2026 15:46:31 +0300 Subject: [PATCH] HUmidifier logic with some extra new primitives --- src/AFRP.hs | 64 ++++++++++++++++++++++++- src/HomeAssistant/Controller.hs | 21 +++----- src/HomeAssistant/Controller/Bedroom.hs | 34 ++++++++++++- src/HomeAssistant/Runtime.hs | 3 +- 4 files changed, 104 insertions(+), 18 deletions(-) diff --git a/src/AFRP.hs b/src/AFRP.hs index 18a5834..e0634aa 100644 --- a/src/AFRP.hs +++ b/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) diff --git a/src/HomeAssistant/Controller.hs b/src/HomeAssistant/Controller.hs index bed1ed9..ad63c81 100644 --- a/src/HomeAssistant/Controller.hs +++ b/src/HomeAssistant/Controller.hs @@ -19,13 +19,12 @@ module HomeAssistant.Controller , ruuviTemperatures , ruuviPressures , DoorState(..) - , door , light - , lightController , Presence(..) , presence , debug , traceEvent + , traceValue , switch , Target(..) ) where @@ -71,6 +70,11 @@ traceEvent = Mealy $ \nt req -> \case Event a -> nt (Trace req a) >>= \() -> pure (Event a, traceEvent) Tick -> pure (Tick, traceEvent) +traceValue :: Show a => HASS a a +traceValue = proc x -> do + eff Trace -< x + returnA -< x + ruuviTemperatures :: Mealy eff (Event Value) Double ruuviTemperatures = entityRead @Double "sensor.ruuvitag_b168_temperature" >>> hold 0 @@ -95,11 +99,6 @@ presence entityId =entityBool entityId -door :: HASS (Event Value) (Event DoorState) -door = entityBool "binary_sensor.makuuhuone_ovi_contact" - >>> arr (fmap (bool Closed Open)) - >>> hold Open - >>> changes -- Turn off lights when door is closed light :: [Target] -> Bool -> Service @@ -119,14 +118,6 @@ switch targets b = Service , serviceTarget=targets } -lightController :: HASS (Event Value) (Event DoorState) -lightController = proc ev -> do - doorState <- door -< ev - case doorState of - Event Open -> callService (light [EntityId "light.bedroom_masse"] False) -< () - Event Closed -> callService (light [EntityId "light.bedroom_masse"] True) -< () - _ -> returnA -< () - returnA -< doorState entityChangeEvent :: T.Text -> Mealy eff (Event Value) (Event Value) entityChangeEvent entityId = entityChangeEvent' entityId >>> toEvent diff --git a/src/HomeAssistant/Controller/Bedroom.hs b/src/HomeAssistant/Controller/Bedroom.hs index 15a45e3..f892064 100644 --- a/src/HomeAssistant/Controller/Bedroom.hs +++ b/src/HomeAssistant/Controller/Bedroom.hs @@ -4,12 +4,14 @@ module HomeAssistant.Controller.Bedroom where import HomeAssistant.Controller import qualified Data.Text as T -import AFRP (Event (..), (>>|), toEvent, lMerge) +import AFRP (Event (..), (>>|), toEvent, lMerge, duration, edge) import Data.Aeson (Value, object, (.=)) import Control.Arrow ((>>>), returnA, arr, Arrow (..)) import Control.Lens ((^?), to, traversed) import Data.Aeson.Lens (key, _String) import Data.Bool (bool) +import Data.Time (NominalDiffTime) +import qualified AFRP @@ -121,3 +123,33 @@ bedroomDrawerController = proc x -> do _ -> returnA -< () where entity = EntityId "switch.bedroom_drawer_light_masse" + +door :: HASS (Event Value) (Event DoorState) +door = entityBool "binary_sensor.makuuhuone_ovi_contact" + >>> arr (fmap (bool Closed Open)) + +waitFor :: NominalDiffTime -> HASS a (Event ()) +waitFor n = duration >>> arr (> n) >>> edge + +delayedDoor :: HASS (Event Value) (Event DoorState) +delayedDoor = door + >>> (AFRP.hold Open &&& AFRP.delayEvent 15) + >>> AFRP.sample + >>> traceEvent + +humidifierController :: HASS (Event Value) () +humidifierController = proc x -> do + st <- delayedDoor -< x + case st of + -- Turn the humidifier on when the door is closed + -- the humidifier is low-powered, no point in losing all the humidity + Event Open -> callService (humidifier False) -< () + Event Closed -> callService (humidifier True) -< () + _ -> returnA -< () + where + humidifier state = Service + { serviceDomain="humidifier" + , serviceName= bool "turn_off" "turn_on" state + , serviceData= Nothing + , serviceTarget= [EntityId "humidifier.makuuhuone_ilmankostutin"] + } diff --git a/src/HomeAssistant/Runtime.hs b/src/HomeAssistant/Runtime.hs index 743633b..69cb631 100644 --- a/src/HomeAssistant/Runtime.hs +++ b/src/HomeAssistant/Runtime.hs @@ -26,7 +26,7 @@ import HomeAssistant.Runtime.Connection (readerAction, writerAction) import HomeAssistant.Runtime.Supervisor (defaultBackoff, supervised) import Network.Socket (withSocketsDo) import System.Environment (getEnv, lookupEnv) -import HomeAssistant.Controller.Bedroom (bedroomPresenceController, bedroomButtonController, bedroomDrawerController) +import HomeAssistant.Controller.Bedroom (bedroomPresenceController, bedroomButtonController, bedroomDrawerController, humidifierController) import Data.UUID (UUID, toText) import qualified Data.UUID.V4 as UUID.V4 import Katip (runKatipT, logF, sl, Severity (..), ls, Namespace (Namespace), runKatipContextT) @@ -45,6 +45,7 @@ controllers = [ Controller "bedroom-presence" bedroomPresenceController False , Controller "bedroom-button" bedroomButtonController False -- This works but leaving for vacation , Controller "bedroom-drawer" bedroomDrawerController True + , Controller "bedroom-humidifier" humidifierController True ] -- | Steps the machine for every inbound message; service calls go to the