From 7c2cfde81473c4ef3396695d3c83f741e426289e Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Wed, 16 Sep 2026 09:47:49 +0300 Subject: [PATCH] Livingroom lights --- home-assistant-controller.cabal | 1 + src/HomeAssistant/Controller.hs | 32 +++++++++++++- src/HomeAssistant/Controller/Kitchen.hs | 26 ++--------- src/HomeAssistant/Controller/Livingroom.hs | 51 ++++++++++++++++++++++ src/HomeAssistant/Runtime.hs | 2 + 5 files changed, 87 insertions(+), 25 deletions(-) create mode 100644 src/HomeAssistant/Controller/Livingroom.hs diff --git a/home-assistant-controller.cabal b/home-assistant-controller.cabal index 72d2d2b..9cc6521 100644 --- a/home-assistant-controller.cabal +++ b/home-assistant-controller.cabal @@ -64,6 +64,7 @@ library , HomeAssistant.Controller.Bedroom , HomeAssistant.Controller.Kitchen , HomeAssistant.Controller.Children + , HomeAssistant.Controller.Livingroom , HomeAssistant.Controller.Ruuvi , HomeAssistant.Runtime , HomeAssistant.Runtime.Bus diff --git a/src/HomeAssistant/Controller.hs b/src/HomeAssistant/Controller.hs index abadd10..bccdb02 100644 --- a/src/HomeAssistant/Controller.hs +++ b/src/HomeAssistant/Controller.hs @@ -19,6 +19,8 @@ module HomeAssistant.Controller , light , Presence(..) , presence + , motion + , motionToPresence , debug , traceEvent , traceValue @@ -28,7 +30,7 @@ module HomeAssistant.Controller , Light(..) ) where -import AFRP (Mealy (..), eff, Event(..), events, filterA, (>>|), toEvent, Request) +import AFRP (Mealy (..), eff, Event(..), events, filterA, (>>|), toEvent, Request, hold, lMerge, waitFor, tag, edge) import Control.Arrow (Arrow(..), returnA) import Control.Category ((>>>)) import Data.Aeson (Value, object, (.=)) @@ -40,6 +42,7 @@ import qualified Data.Text.Lens as TL import Data.Bool (bool) import Data.Serialize (Serialize) import GHC.Generics (Generic) +import Data.Time (NominalDiffTime) data Target = EntityId !T.Text | AreaId !T.Text deriving (Show,Eq,Ord) @@ -93,10 +96,35 @@ data Presence = Occupied | Unoccupied instance Serialize Presence presence :: T.Text -> HASS (Event Value) (Event Presence) -presence entityId =entityBool entityId +presence entityId = entityBool entityId >>> arr (fmap (bool Unoccupied Occupied)) +data Motion = MotionDetected | MotionNotDetected | MotionUnknown + deriving (Show, Eq, Generic) + + +motion :: T.Text -> HASS (Event Value) Motion +motion entityId = entityBool entityId + >>> arr (fmap (bool MotionNotDetected MotionDetected)) + >>> hold MotionUnknown + + +-- Convert a motion status into a simulated presence +-- +-- A motion tracker detects _motion_, but if you are still, it can't detect you. +-- A simple and cheap heuristic is to assume the person is a bit longer there +motionToPresence :: NominalDiffTime -> HASS Motion Presence +motionToPresence delay = (eventOccupied &&& eventUnoccupied) + >>> arr (uncurry lMerge) + >>> AFRP.hold Unoccupied + where + eventOccupied :: HASS Motion (Event Presence) + eventOccupied = arr (== MotionDetected) >>> edge >>> arr (fmap (const Occupied)) + eventUnoccupied :: HASS Motion (Event Presence) + eventUnoccupied = arr (== MotionNotDetected) >>> waitFor delay >>> arr (tag Unoccupied) + +instance Serialize Motion data Light = Off diff --git a/src/HomeAssistant/Controller/Kitchen.hs b/src/HomeAssistant/Controller/Kitchen.hs index 8b78189..948f832 100644 --- a/src/HomeAssistant/Controller/Kitchen.hs +++ b/src/HomeAssistant/Controller/Kitchen.hs @@ -7,37 +7,17 @@ import qualified AFRP import Data.Aeson (Value) import Control.Arrow ((>>>), Arrow (..), returnA) import Data.Bool (bool) -import GHC.Generics (Generic) -import Data.Serialize (Serialize) import Prelude hiding (id) import Data.Time (LocalTime(..), TimeOfDay (..)) -- Kitchen has two "presence" sensors. One IKEA motion sensor and one SwitchBot presence sensor -data Motion = MotionDetected | MotionNotDetected | MotionUnknown - deriving (Show, Eq, Generic) - -instance Serialize Motion data Lights = LightsOn | LightsOff deriving (Show) -kitchenMotion :: HASS (Event Value) Motion -kitchenMotion = entityBool "binary_sensor.kitchen_movement_occupancy" - >>> arr (fmap (bool MotionNotDetected MotionDetected)) - >>> traceEvent - >>> AFRP.hold MotionUnknown - - -kitchenPresence :: HASS Motion Presence -kitchenPresence = (eventOccupied &&& eventUnoccupied) - >>> arr (uncurry AFRP.lMerge) >>> traceEvent - >>> AFRP.hold Unoccupied - where - eventOccupied :: HASS Motion (Event Presence) - eventOccupied = arr (== MotionDetected) >>> AFRP.edge >>> arr (fmap (const Occupied)) - eventUnoccupied :: HASS Motion (Event Presence) - eventUnoccupied = arr (== MotionNotDetected) >>> AFRP.waitFor 300 >>> arr (AFRP.tag Unoccupied) +kitchenPresence :: HASS (Event Value) Presence +kitchenPresence = motion "binary_sensor.kitchen_movement_occupancy" >>> motionToPresence 500 eventLights :: HASS Presence (Event Lights) eventLights = AFRP.changes >>> arr (fmap presenceLights) @@ -48,7 +28,7 @@ eventLights = AFRP.changes >>> arr (fmap presenceLights) kitchenCeilingController :: HASS (Event Value) () kitchenCeilingController = proc x -> do now <- AFRP.currentTime -< () - p <- kitchenMotion >>> kitchenPresence -< x + p <- kitchenPresence -< x ev <- eventLights -< p traceEvent -< ev case ev of diff --git a/src/HomeAssistant/Controller/Livingroom.hs b/src/HomeAssistant/Controller/Livingroom.hs new file mode 100644 index 0000000..9bef251 --- /dev/null +++ b/src/HomeAssistant/Controller/Livingroom.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Arrows #-} +module HomeAssistant.Controller.Livingroom where + +import HomeAssistant.Controller (HASS, Presence (..), Target (..), presence, callServiceDyn, light, Light (..), traceEvent) +import qualified AFRP +import Control.Arrow ((>>>), Arrow (..), returnA) +import Data.Aeson (Value) +import Prelude hiding ((.)) +import Control.Category ((.)) + +data Lights = LightsOn | LightsOff + deriving (Show) + +livingroomPresence :: HASS (AFRP.Event Value) Presence +livingroomPresence = presence "binary_sensor.occupancy_olohuone_derived" >>> AFRP.hold Unoccupied + +eventLights :: HASS Presence (AFRP.Event Lights) +eventLights = AFRP.changes >>> arr (fmap presenceLights) + where + presenceLights Occupied = LightsOn + presenceLights Unoccupied = LightsOff + + +-- There's a small race condition / corner case bug in the og implementation +-- I have a couple of lights in the Livingroom +-- +-- - Ceiling ilght +-- - "Sofa light", a small reading nook light +-- - A few strong lights at a plant corner +-- +-- The plant corner lights are not started by the automation. They are started by a separate schedule +-- But, they are turned off by the automation +-- So their status gets messed if their schedule turns on while there is nobody in the room +-- +-- +-- With that in mind, I'll be explicitly controlling the two lights, without any scene shenanigans + + +lights :: [Target] +lights = [EntityId "light.livingroom_ceiling", EntityId "light.livingroom_sofa"] + +livingroomPresenceController :: HASS (AFRP.Event Value) () +livingroomPresenceController = proc x -> do + ev <- eventLights . livingroomPresence -< x + traceEvent -< ev + case ev of + AFRP.Event LightsOn -> callServiceDyn (light lights) -< On Nothing + AFRP.Event LightsOff -> callServiceDyn (light lights) -< Off + _ -> returnA -< () + returnA -< () diff --git a/src/HomeAssistant/Runtime.hs b/src/HomeAssistant/Runtime.hs index 446724a..33ae701 100644 --- a/src/HomeAssistant/Runtime.hs +++ b/src/HomeAssistant/Runtime.hs @@ -40,6 +40,7 @@ import qualified HomeAssistant.Runtime.Graphing import System.FilePath (()) import Text.Read (readMaybe) import HomeAssistant.Controller.Kitchen (kitchenMotionController) +import HomeAssistant.Controller.Livingroom (livingroomPresenceController) step :: (MonadIO m) => FilePath -> UUID -> Auto m a b -> a -> m (b, Auto m a b) step path trace st a = do @@ -59,6 +60,7 @@ controllers = , Controller "ruuvi-controller" ruuviController False , Controller "school-light-controller" schoolLightController True , Controller "kitchen-motion-controller" kitchenMotionController True + , Controller "livingroom-presence" livingroomPresenceController True ] -- | Steps the machine for every inbound message; service calls go to the