83 lines
2.6 KiB
Haskell
83 lines
2.6 KiB
Haskell
{-# LANGUAGE Arrows #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
module HomeAssistant.Controller.Children where
|
|
import HomeAssistant.Controller (HASS, callService, Target (AreaId), light, Light(..))
|
|
import AFRP (Event)
|
|
import qualified AFRP
|
|
import Control.Arrow (Arrow(..), (>>>))
|
|
import Data.Time (Day, TimeOfDay (..), localDay, LocalTime (..))
|
|
import Data.Time.Calendar.OrdinalDate (WeekOfYear, mondayStartWeek)
|
|
import Data.Functor.Contravariant (Predicate (..), (>$<))
|
|
|
|
-- 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)
|
|
, at (18,57) -- debug
|
|
]
|
|
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)
|
|
, at (18,55) -- debug
|
|
]
|
|
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{brightnessPercentage = Just 100}))
|
|
|
|
lightsOff :: HASS a ()
|
|
lightsOff = foldMap atTime timersOff
|
|
>>> AFRP.onEvent (callService (light [AreaId "lasten_makuuhuone"] Off))
|