svenvanheugten/night-light
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Automatically turn on lights at dawn

Browse source
This commit is contained in:
Sven van Heugten 2026-01-06 09:14:14 +01:00
parent f42a8747dd
commit fd103125e3
6 changed files with 97 additions and 58 deletions
Download patch file Download diff file Expand all files Collapse all files

9
NightLight.Core.Tests/GenHelpers.fs Normal file
View file

@ -0,0 +1,9 @@
module NightLight.Core.Tests.GenHelpers
open FsCheck
open FsCheck.FSharp
let concatGens (gens: Gen<'a list> list) : Gen<'a list> =
match gens with
| [] -> Gen.constant []
| first :: rest -> rest |> List.fold (fun accGen g -> Gen.map2 (@) accGen g) first

35
NightLight.Core.Tests/InteractionListGenerators.fs
View file

@ -1,11 +1,9 @@
module NightLight.Core.Tests.InteractionListGenerators
open System
open FsCheck.FSharp
open NightLight.Core.Models
let private genTimeChangedInteraction =
ArbMap.defaults |> ArbMap.generate<DateTime> |> Gen.map Interaction.TimeChanged
open NightLight.Core.Tests.GenHelpers
open NightLight.Core.Tests.TimeChangedGenerators
let private genHumanInteraction =
let genLightInteraction =
@ -18,29 +16,22 @@ let private genHumanInteraction =
Gen.oneof [ genLightInteraction; genRemoteInteraction ]
|> Gen.map Interaction.HumanInteraction
let private genInteraction =
Gen.oneof [ genTimeChangedInteraction; genHumanInteraction ]
let private genInteraction = Gen.oneof [ genTimeChanged; genHumanInteraction ]
let private genInteractionsListThatStartsWithTimeChanged =
gen {
let! firstInteraction = genTimeChangedInteraction
let! remainingInteractions = Gen.listOf genInteraction
return firstInteraction :: remainingInteractions
}
[ genTimeChanged |> Gen.map List.singleton; Gen.listOf genInteraction ]
|> concatGens
let genInteractionListContaining containingInteraction disqualifiedAfter =
gen {
let genInteractionListThatStartsWithTimeChangedAndEndsWith (endsWith: Interaction) =
let genNonTrivialList =
gen {
let! before = genInteractionsListThatStartsWithTimeChanged
let! after = Gen.listOf (genInteraction |> Gen.filter (not << disqualifiedAfter))
return before @ containingInteraction :: after
}
genInteractionsListThatStartsWithTimeChanged
|> Gen.map (fun lst -> lst @ [ endsWith ])
return!
match containingInteraction with
match endsWith with
| Interaction.TimeChanged _ ->
let genTrivialList = Gen.constant <| List.singleton containingInteraction
let genTrivialList = Gen.constant <| List.singleton endsWith
Gen.frequency [ 1, genTrivialList; 9, genNonTrivialList ]
| _ -> genNonTrivialList
}
let genInteractionListExcept disqualifier =
genInteraction |> Gen.filter (not << disqualifier) |> Gen.listOf

3
NightLight.Core.Tests/NightLight.Core.Tests.fsproj
View file

@ -8,8 +8,9 @@
<ItemGroup>
<Compile Include="FakeHome.fs" />
<Compile Include="InteractionListGenerators.fs" />
<Compile Include="GenHelpers.fs" />
<Compile Include="TimeChangedGenerators.fs" />
<Compile Include="InteractionListGenerators.fs" />
<Compile Include="NightLightTests.fs" />
</ItemGroup>

50
NightLight.Core.Tests/NightLightTests.fs
View file

@ -1,6 +1,7 @@
namespace NightLight.Core.Tests
open NightLight.Core.Core
open NightLight.Core.Tests.GenHelpers
open NightLight.Core.Tests.TimeChangedGenerators
open NightLight.Core.Tests.InteractionListGenerators
open FsCheck.Xunit
@ -38,8 +39,9 @@ type NightLightTests() =
[<Property>]
let ``All lights that are on should be white or yellow during the day`` () =
genTimeChangedToDay
|> Gen.bind (fun timeChangedToDay -> genInteractionListContaining timeChangedToDay _.IsTimeChanged)
concatGens
[ Gen.bind genInteractionListThatStartsWithTimeChangedAndEndsWith genTimeChangedToDay
genInteractionListExcept isTimeChangedToNight ]
|> Arb.fromGen
|> Prop.forAll
<| fun interactions ->
@ -50,8 +52,9 @@ type NightLightTests() =
[<Property>]
let ``All lights that are on should be red during the night`` () =
genTimeChangedToNight
|> Gen.bind (fun timeChangedToNight -> genInteractionListContaining timeChangedToNight _.IsTimeChanged)
concatGens
[ Gen.bind genInteractionListThatStartsWithTimeChangedAndEndsWith genTimeChangedToNight
genInteractionListExcept isTimeChangedToDay ]
|> Arb.fromGen
|> Prop.forAll
<| fun interactions ->
@ -61,13 +64,12 @@ type NightLightTests() =
|> Prop.trivial (fakeHome.LightStates |> Seq.filter (snd >> _.IsOn) |> Seq.isEmpty)
[<Property>]
let ``After pressing 'On' on the remote, the remotely controlled lights that have power should be on until they are powered off or 'Off' is pressed``
let ``After pressing 'On' on the remote, all lights that have power should be on as long as the 'Off' button isn't pressed``
()
=
genInteractionListContaining (HumanInteraction RemotePressedOnButton) (function
| HumanInteraction RemotePressedOffButton -> true
| HumanInteraction(LightPoweredOff l) when l.ControlledWithRemote -> true
| _ -> false)
concatGens
[ genInteractionListThatStartsWithTimeChangedAndEndsWith (HumanInteraction RemotePressedOnButton)
genInteractionListExcept ((=) (HumanInteraction RemotePressedOffButton)) ]
|> Arb.fromGen
|> Prop.forAll
<| fun interactions ->
@ -80,12 +82,14 @@ type NightLightTests() =
|> Prop.trivial (Seq.isEmpty lightsWithPower)
[<Property>]
let ``After pressing 'Off' on the remote, the remotely controlled lights should stay off until 'On' is pressed``
let ``After pressing 'Off' on the remote, all lights that have power should be on as long as the 'On' button isn't pressed and a new day doesn't start``
()
=
genInteractionListContaining
(HumanInteraction RemotePressedOffButton)
((=) (HumanInteraction RemotePressedOnButton))
concatGens
[ genInteractionListThatStartsWithTimeChangedAndEndsWith (HumanInteraction RemotePressedOffButton)
genInteractionListExcept (fun interaction ->
interaction = HumanInteraction RemotePressedOnButton
|| interaction |> isTimeChangedToDay) ]
|> Arb.fromGen
|> Prop.forAll
<| fun interactions ->
@ -94,3 +98,23 @@ type NightLightTests() =
fakeHome.ForAllRemotelyControlledLights(fun (_, state) -> state = Off)
|> Prop.trivial (Seq.isEmpty lightsWithPower)
[<Property>]
let ``After a new day starts, all lights that have power should be on as long as the 'Off' button isn't pressed``
()
=
concatGens
[ Gen.bind genInteractionListThatStartsWithTimeChangedAndEndsWith genTimeChangedToNight
genInteractionListExcept isTimeChangedToDay
Gen.map List.singleton genTimeChangedToDay
genInteractionListExcept ((=) (HumanInteraction RemotePressedOffButton)) ]
|> Arb.fromGen
|> Prop.forAll
<| fun interactions ->
let fakeHome = createFakeHomeWithNightLightAndInteract interactions
let lightsWithPower = fakeHome.LightStates |> filterToLightsWithPower interactions
lightsWithPower
|> Seq.map snd
|> Seq.forall _.IsOn
|> Prop.trivial (Seq.isEmpty lightsWithPower)

24
NightLight.Core.Tests/TimeChangedGenerators.fs
View file

@ -7,14 +7,18 @@ let private isDay (time: DateTime) =
time.TimeOfDay >= TimeSpan.FromHours 5.5
&& time.TimeOfDay < TimeSpan.FromHours 20.5
let genTimeChangedToDay =
ArbMap.defaults
|> ArbMap.generate<DateTime>
|> Gen.filter isDay
|> Gen.map Interaction.TimeChanged
let private isTimeChangedMeetingCondition condition interaction =
match interaction with
| TimeChanged time when condition time -> true
| _ -> false
let genTimeChangedToNight =
ArbMap.defaults
|> ArbMap.generate<DateTime>
|> Gen.filter (not << isDay)
|> Gen.map Interaction.TimeChanged
let isTimeChangedToDay = isTimeChangedMeetingCondition isDay
let isTimeChangedToNight = isTimeChangedMeetingCondition (not << isDay)
let genTimeChanged =
ArbMap.defaults |> ArbMap.generate<DateTime> |> Gen.map Interaction.TimeChanged
let genTimeChangedToDay = genTimeChanged |> Gen.filter isTimeChangedToDay
let genTimeChangedToNight = genTimeChanged |> Gen.filter isTimeChangedToNight

26
NightLight.Core/NightLightStateMachine.fs
View file

@ -28,6 +28,11 @@ type NightLightStateMachine private (maybeTime: DateTime option, lightToState: M
member this.OnEventReceived(event: Event) : Result<NightLightStateMachine * Message seq, OnEventReceivedError> =
result {
let maybePartOfDay = maybeTime |> Option.map getPartOfDay
let remoteControlledLights = lights |> Seq.filter _.ControlledWithRemote
let updateLightStateForRemoteControlledLights desiredLightState =
remoteControlledLights
|> Seq.fold (fun acc key -> Map.add key desiredLightState acc) lightToState
match event, maybePartOfDay with
| ReceivedZigbeeEvent payload, Some partOfDay ->
@ -48,25 +53,30 @@ type NightLightStateMachine private (maybeTime: DateTime option, lightToState: M
| PressedOn -> On
| PressedOff -> Off
let remoteControlledLights = lights |> Seq.filter _.ControlledWithRemote
let newLightToState =
remoteControlledLights
|> Seq.fold (fun acc key -> Map.add key desiredLightState acc) lightToState
let newLightToState = updateLightStateForRemoteControlledLights desiredLightState
NightLightStateMachine(maybeTime, newLightToState),
remoteControlledLights
|> Seq.collect (fun light -> generateZigbeeCommandsToFixLight desiredLightState partOfDay light)
| TimeChanged newTime, maybePartOfDay ->
let newState = NightLightStateMachine(Some newTime, lightToState)
let newPartOfDay = getPartOfDay newTime
let partOfDayChanged = maybePartOfDay <> Some newPartOfDay
let newLightToState =
if partOfDayChanged && newPartOfDay = Day then
updateLightStateForRemoteControlledLights On
else
lightToState
let newState = NightLightStateMachine(Some newTime, newLightToState)
return
newState,
if maybePartOfDay <> Some newPartOfDay then
if partOfDayChanged then
lights
|> Seq.collect (fun light ->
generateZigbeeCommandsToFixLight lightToState[light] newPartOfDay light)
generateZigbeeCommandsToFixLight newLightToState[light] newPartOfDay light)
else
Seq.empty
| _, None -> return! Error TimeIsUnknown