home-assistant-controller/src/HomeAssistant/Controller/Children.hs

{-# LANGUAGE Arrows #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DerivingVia #-}
module HomeAssistant.Controller.Children where
import HomeAssistant.Controller (HASS, callService, light, LightCommand(..), ikeaQuickButton, IkeaGesture (..), IkeaButton (..), traceEvent, activateScene, LightAttributes (..), Brightness (..), entityRead, entityChangeEvent)
import AFRP (Event (..))
import qualified AFRP
import Control.Arrow (Arrow(..), (>>>), returnA)
import Data.Time (Day, TimeOfDay (..), localDay, LocalTime (..))
import Data.Time.Calendar.OrdinalDate (WeekOfYear, mondayStartWeek)
import Data.Functor.Contravariant (Predicate (..), (>$<))
import Data.Aeson (Value, object, (.=))
import Data.Default (Default(..))
import Data.Serialize (Serialize)
import Data.Serialize.Text ()
import GHC.Generics (Generic)
import HomeAssistant.Controller.Service (Service(..), Target(..))
import Data.Aeson.Types (ToJSON (..))
import Data.Aeson.Lens (key, _String)
import Control.Lens ((^?), to)
import Data.Text (Text)
import Control.Monad (join)

-- Let's see building some reasonable interface for utctime
dow :: Day -> (WeekOfYear, Int)
dow = mondayStartWeek


weekday :: Predicate Day
weekday = Predicate (betweenInclusive 1 5 . snd . dow)
  where
    betweenInclusive a b c = c >= a && c <= b

time :: (Int, Int) -> Predicate TimeOfDay
time (h,m) = mconcat
  [ Predicate (equals h . todHour)
  , Predicate (equals m . todMin)
  ]
  where
    equals a b = a == b


atTime :: Predicate LocalTime -> HASS a (Event ())
atTime p = AFRP.currentTime
  >>> arr (getPredicate p)
  >>> AFRP.edge

-- I don't have any proper presence sensors in their bedroom
-- and they are notoriously bad at changing clothes in complete darkness
-- So I have set up an automation that attempts to turn on the lights sometime
-- before they leave for school and turns them off a bit later

-- Don't mconcat these predicates they have && behavior
-- if you mconcat the actual arrows, they combine the behaviors of the separate branches
-- essentially becoming || behavior
timersOff :: [Predicate LocalTime]
timersOff =
  [ day 1 <> at (08,15)
  , day 2 <> at (09,15)
  , day 3 <> at (08,15)
  , day 4 <> at (08,15)
  , day 5 <> at (08,15)
  ]
  where
    dayOfWeek = snd . mondayStartWeek . localDay
    at (h,m) = localTimeOfDay >$< Predicate (\TimeOfDay{todHour, todMin} -> todHour == h && todMin == m)
    day n = dayOfWeek >$< Predicate (== n)

timersOn :: [Predicate LocalTime]
timersOn =
  [ day 1 <> at (07,30)
  , day 2 <> at (08,30)
  , day 3 <> at (07,30)
  , day 4 <> at (07,30)
  , day 5 <> at (07,30)
  ]
  where
    dayOfWeek = snd . mondayStartWeek . localDay
    at (h,m) = localTimeOfDay >$< Predicate (\TimeOfDay{todHour, todMin} -> todHour == h && todMin == m)
    day n = dayOfWeek >$< Predicate (== n)

schoolLightController :: HASS a ()
schoolLightController = lightsOn <> lightsOff


lightsOn :: HASS a ()
lightsOn = foldMap atTime timersOn
  >>> AFRP.onEvent (callService (light [AreaId "lasten_makuuhuone"] (On def{lightBrightness=Just $ BrightnessPercent 100} )))

lightsOff :: HASS a ()
lightsOff = foldMap atTime timersOff
  >>> AFRP.onEvent (callService (light [AreaId "lasten_makuuhuone"] Off))


childrenBedroomButton :: HASS   (Event Value) (Event (IkeaButton IkeaGesture))
childrenBedroomButton = ikeaQuickButton "event.children_quick_remote_action"

childrenBedroomButtonController :: HASS (Event Value) ()
childrenBedroomButtonController = proc x -> do
  ev <- childrenBedroomButton >>> traceEvent -< x
  case ev of
       Event (OnButton ShortRelease) -> callService (activateScene "scene.lasten_nukkuvalmistelu") -< ()
       Event (OnButton DoubleClick) -> callService (activateScene "scene.lasten_luku") -< ()
       Event (OnButton LongClick) -> callService (activateScene "scene.lasten_kirkas") -< ()
       Event (OffButton _) -> callService (light [AreaId "lasten_makuuhuone"] Off) -< ()
       _ -> returnA -< ()

newtype PM25 = PM25 Float
  deriving (Serialize, Eq, Ord) via Float
  deriving Show

data PM25Level = PM25High | PM25Low
  deriving (Eq, Generic, Show)

instance Serialize PM25Level

pm25 :: HASS (Event Value) PM25
pm25 = fmap PM25 (entityRead "sensor.children_temp_pm25" >>> AFRP.hold 0)

pm25Level :: HASS PM25 PM25Level
pm25Level = (tagHigh &&& tagLow) >>> arr (uncurry AFRP.lMerge) >>> AFRP.hold PM25Low
  where
    -- Band between 8 and 12 to avoid oscillation near the ~10 mark
    tagHigh = arr (> PM25 12) >>> AFRP.edge >>> arr (AFRP.tag PM25High)
    tagLow = arr (< PM25 8) >>> AFRP.edge >>> arr (AFRP.tag PM25Low)

data HumidifierAction
  = Idle
  | Humidifying
  | Other Text
  deriving (Show, Eq, Generic)
instance Serialize HumidifierAction

-- what is the humidifer doing right now?
humidifierOperatingState :: HASS (Event Value) (Event (Maybe HumidifierAction))
humidifierOperatingState = entityChangeEvent "humidifier.lapset_ilmankostutin"
  >>> arr (fmap entityAction)
  where
    entityAction v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "attributes" . key "action" . _String . to humidifierAction
    humidifierAction = \case
      "idle" -> Idle
      "humidifying" -> Humidifying
      other -> Other other

-- TODO: There's some other percentages elsewhere that could be replaced with this
newtype Percentage = Percentage Int
instance ToJSON Percentage where
  toJSON (Percentage p) = object ["percentage" .= p]

childrenAirFilterController :: HASS (Event Value) ()
childrenAirFilterController = proc ev -> do
  level <- pm25 >>> pm25Level >>> AFRP.changes >>> traceEvent -< ev
  humidifier <- humidifierOperatingState >>> AFRP.holdKnown >>> arr join -< ev
  case level of
       Event PM25High ->
         AFRP.whenA (== Just Idle) (callService (fanOnTo (Percentage 80))) -< humidifier
       Event PM25Low -> callService (fanOnTo (Percentage 20)) -< ()
       _ -> returnA -< ()
  where
    fanOnTo percentage = Service
      { serviceDomain = "fan"
      , serviceName = "set_percentage"
      , serviceTarget = [EntityId "fan.children_fan"]
      , serviceData = Just $ toJSON percentage
      }