From fd103125e39b885b1e58267b6618fe6bbe927cf2 Mon Sep 17 00:00:00 2001 From: Sven van Heugten Date: Tue, 6 Jan 2026 09:14:14 +0100 Subject: [PATCH] Automatically turn on lights at dawn --- NightLight.Core.Tests/GenHelpers.fs | 9 ++++ .../InteractionListGenerators.fs | 43 +++++++--------- .../NightLight.Core.Tests.fsproj | 3 +- NightLight.Core.Tests/NightLightTests.fs | 50 ++++++++++++++----- .../TimeChangedGenerators.fs | 24 +++++---- NightLight.Core/NightLightStateMachine.fs | 26 +++++++--- 6 files changed, 97 insertions(+), 58 deletions(-) create mode 100644 NightLight.Core.Tests/GenHelpers.fs diff --git a/NightLight.Core.Tests/GenHelpers.fs b/NightLight.Core.Tests/GenHelpers.fs new file mode 100644 index 0000000..9d8bbf2 --- /dev/null +++ b/NightLight.Core.Tests/GenHelpers.fs @@ -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 diff --git a/NightLight.Core.Tests/InteractionListGenerators.fs b/NightLight.Core.Tests/InteractionListGenerators.fs index 269c94e..b41e517 100644 --- a/NightLight.Core.Tests/InteractionListGenerators.fs +++ b/NightLight.Core.Tests/InteractionListGenerators.fs @@ -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 |> 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 genNonTrivialList = - gen { - let! before = genInteractionsListThatStartsWithTimeChanged - let! after = Gen.listOf (genInteraction |> Gen.filter (not << disqualifiedAfter)) - return before @ containingInteraction :: after - } +let genInteractionListThatStartsWithTimeChangedAndEndsWith (endsWith: Interaction) = + let genNonTrivialList = + genInteractionsListThatStartsWithTimeChanged + |> Gen.map (fun lst -> lst @ [ endsWith ]) - return! - match containingInteraction with - | Interaction.TimeChanged _ -> - let genTrivialList = Gen.constant <| List.singleton containingInteraction - Gen.frequency [ 1, genTrivialList; 9, genNonTrivialList ] - | _ -> genNonTrivialList - } + match endsWith with + | Interaction.TimeChanged _ -> + let genTrivialList = Gen.constant <| List.singleton endsWith + Gen.frequency [ 1, genTrivialList; 9, genNonTrivialList ] + | _ -> genNonTrivialList + +let genInteractionListExcept disqualifier = + genInteraction |> Gen.filter (not << disqualifier) |> Gen.listOf diff --git a/NightLight.Core.Tests/NightLight.Core.Tests.fsproj b/NightLight.Core.Tests/NightLight.Core.Tests.fsproj index 8dbe2c5..3af4cd3 100644 --- a/NightLight.Core.Tests/NightLight.Core.Tests.fsproj +++ b/NightLight.Core.Tests/NightLight.Core.Tests.fsproj @@ -8,8 +8,9 @@ - + + diff --git a/NightLight.Core.Tests/NightLightTests.fs b/NightLight.Core.Tests/NightLightTests.fs index 62a4297..86ecd22 100644 --- a/NightLight.Core.Tests/NightLightTests.fs +++ b/NightLight.Core.Tests/NightLightTests.fs @@ -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() = [] 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() = [] 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) [] - 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) [] - 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) + + [] + 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) diff --git a/NightLight.Core.Tests/TimeChangedGenerators.fs b/NightLight.Core.Tests/TimeChangedGenerators.fs index 6f1300d..ebe3d60 100644 --- a/NightLight.Core.Tests/TimeChangedGenerators.fs +++ b/NightLight.Core.Tests/TimeChangedGenerators.fs @@ -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 - |> 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 - |> Gen.filter (not << isDay) - |> Gen.map Interaction.TimeChanged +let isTimeChangedToDay = isTimeChangedMeetingCondition isDay + +let isTimeChangedToNight = isTimeChangedMeetingCondition (not << isDay) + +let genTimeChanged = + ArbMap.defaults |> ArbMap.generate |> Gen.map Interaction.TimeChanged + +let genTimeChangedToDay = genTimeChanged |> Gen.filter isTimeChangedToDay + +let genTimeChangedToNight = genTimeChanged |> Gen.filter isTimeChangedToNight diff --git a/NightLight.Core/NightLightStateMachine.fs b/NightLight.Core/NightLightStateMachine.fs index 6068de5..94eef76 100644 --- a/NightLight.Core/NightLightStateMachine.fs +++ b/NightLight.Core/NightLightStateMachine.fs @@ -28,6 +28,11 @@ type NightLightStateMachine private (maybeTime: DateTime option, lightToState: M member this.OnEventReceived(event: Event) : Result = 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