Livingroom lights

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

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

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

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 -< ()

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