From 14cfaaeed5b2feda1abd04a95418f148c86684de Mon Sep 17 00:00:00 2001 From: Sven van Heugten Date: Mon, 5 Jan 2026 21:32:14 +0100 Subject: [PATCH 01/13] Generalize the genInteractionListThatEndsAtTime concept --- .../ArbitraryInteractionLists.fs | 8 ++--- .../InteractionListGenerators.fs | 32 +++++++++++-------- NightLight.Core.Tests/NightLightTests.fs | 4 +-- 3 files changed, 24 insertions(+), 20 deletions(-) diff --git a/NightLight.Core.Tests/ArbitraryInteractionLists.fs b/NightLight.Core.Tests/ArbitraryInteractionLists.fs index 9098db1..1a80df4 100644 --- a/NightLight.Core.Tests/ArbitraryInteractionLists.fs +++ b/NightLight.Core.Tests/ArbitraryInteractionLists.fs @@ -8,18 +8,18 @@ let private isDay (time: DateTime) = time.TimeOfDay >= TimeSpan.FromHours 5.5 && time.TimeOfDay < TimeSpan.FromHours 20.5 -type ArbitraryInteractionsListThatEndsDuringTheDay = +type ArbitraryInteractionListThatEndsDuringTheDay = static member InteractionsList() = ArbMap.defaults |> ArbMap.generate |> Gen.filter isDay - |> Gen.bind genInteractionsListThatEndsAtTime + |> Gen.bind genInteractionListThatEndsAtTime |> Arb.fromGen -type ArbitraryInteractionsListThatEndsDuringTheNight = +type ArbitraryInteractionListThatEndsDuringTheNight = static member InteractionsList() = ArbMap.defaults |> ArbMap.generate |> Gen.filter (not << isDay) - |> Gen.bind genInteractionsListThatEndsAtTime + |> Gen.bind genInteractionListThatEndsAtTime |> Arb.fromGen diff --git a/NightLight.Core.Tests/InteractionListGenerators.fs b/NightLight.Core.Tests/InteractionListGenerators.fs index d1e1925..5d620f3 100644 --- a/NightLight.Core.Tests/InteractionListGenerators.fs +++ b/NightLight.Core.Tests/InteractionListGenerators.fs @@ -17,25 +17,29 @@ let private genHumanInteraction = let private genInteraction = Gen.oneof [ genTimeChangedInteraction; genHumanInteraction ] -let private genInteractionsListThatStartsWithTimeChange = +let private genInteractionsListThatStartsWithTimeChanged = gen { let! firstInteraction = genTimeChangedInteraction let! remainingInteractions = Gen.listOf genInteraction return firstInteraction :: remainingInteractions } -let private genInteractionsListWhere condition = - Gen.listOf (genInteraction |> Gen.filter condition) +let private genInteractionListContaining containingInteraction afterFilter = + gen { + let genNonTrivialList = + gen { + let! before = genInteractionsListThatStartsWithTimeChanged + let! after = Gen.listOf (genInteraction |> Gen.filter afterFilter) + return before @ containingInteraction :: after + } -let genInteractionsListThatEndsAtTime time = - let genTrivialList = Gen.constant <| List.singleton (Interaction.TimeChanged time) + return! + match containingInteraction with + | Interaction.TimeChanged _ -> + let genTrivialList = Gen.constant <| List.singleton containingInteraction + Gen.frequency [ 1, genTrivialList; 9, genNonTrivialList ] + | _ -> genNonTrivialList + } - let genNonTrivialList = - gen { - let! before = genInteractionsListThatStartsWithTimeChange - let interactionThatSetsEndTime = Interaction.TimeChanged time - let! after = genInteractionsListWhere (not << _.IsTimeChanged) - return before @ interactionThatSetsEndTime :: after - } - - Gen.frequency [ 1, genTrivialList; 9, genNonTrivialList ] +let genInteractionListThatEndsAtTime time = + genInteractionListContaining (Interaction.TimeChanged time) (not << _.IsTimeChanged) diff --git a/NightLight.Core.Tests/NightLightTests.fs b/NightLight.Core.Tests/NightLightTests.fs index 6423a68..a10c86d 100644 --- a/NightLight.Core.Tests/NightLightTests.fs +++ b/NightLight.Core.Tests/NightLightTests.fs @@ -21,12 +21,12 @@ type NightLightTests() = fakeHome - [ |])>] + [ |])>] let ``Lights should be white or yellow during the day`` (interactions: Interaction list) = let fakeHome = createFakeHomeWithNightLightAndInteract interactions fakeHome.ForAllLightsThatAreOn(fun (_, _, color) -> color = White || color = Yellow) - [ |])>] + [ |])>] let ``Lights should be red during the night`` (interactions: Interaction list) = let fakeHome = createFakeHomeWithNightLightAndInteract interactions fakeHome.ForAllLightsThatAreOn(fun (_, _, color) -> color = Red) From d2864fcc2276fa0fb3e5d0ab5edd14e53f8657df Mon Sep 17 00:00:00 2001 From: Sven van Heugten Date: Mon, 5 Jan 2026 21:37:35 +0100 Subject: [PATCH 02/13] Give tests better names --- NightLight.Core.Tests/NightLightTests.fs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/NightLight.Core.Tests/NightLightTests.fs b/NightLight.Core.Tests/NightLightTests.fs index a10c86d..9eaad9e 100644 --- a/NightLight.Core.Tests/NightLightTests.fs +++ b/NightLight.Core.Tests/NightLightTests.fs @@ -22,11 +22,11 @@ type NightLightTests() = fakeHome [ |])>] - let ``Lights should be white or yellow during the day`` (interactions: Interaction list) = + let ``All lights that are on should be white or yellow during the day`` (interactions: Interaction list) = let fakeHome = createFakeHomeWithNightLightAndInteract interactions fakeHome.ForAllLightsThatAreOn(fun (_, _, color) -> color = White || color = Yellow) [ |])>] - let ``Lights should be red during the night`` (interactions: Interaction list) = + let ``All lights that are on should be red during the night`` (interactions: Interaction list) = let fakeHome = createFakeHomeWithNightLightAndInteract interactions fakeHome.ForAllLightsThatAreOn(fun (_, _, color) -> color = Red) From 838bbb79a33d484e872fccf9e50cafd3725798ce Mon Sep 17 00:00:00 2001 From: Sven van Heugten Date: Mon, 5 Jan 2026 21:53:48 +0100 Subject: [PATCH 03/13] Add naive remote control implementation --- NightLight.Core/Models.fs | 23 +++++++++---- NightLight.Core/NightLightStateMachine.fs | 8 ++++- NightLight.Core/ZigbeeCommands.fs | 28 +++++++++++++--- NightLight.Core/ZigbeeEvents.fs | 40 ++++++++++++++++------- NightLight/Program.fs | 5 +-- 5 files changed, 78 insertions(+), 26 deletions(-) diff --git a/NightLight.Core/Models.fs b/NightLight.Core/Models.fs index b9fa8db..363f085 100644 --- a/NightLight.Core/Models.fs +++ b/NightLight.Core/Models.fs @@ -9,6 +9,7 @@ type Event = | TimeChanged of DateTime type ParseZigbeeEventError = + | UnknownTopic | InvalidJson | MissingTypeField | MissingDataField @@ -16,6 +17,8 @@ type ParseZigbeeEventError = | InvalidTypeField | InvalidFriendlyNameField | UnknownType + | MissingActionField + | InvalidActionField type OnEventReceivedError = | ParseZigbeeEventError of ParseZigbeeEventError @@ -40,21 +43,29 @@ type DeviceFriendlyName = type Light = { FriendlyName: DeviceFriendlyName Room: Room - Bulb: Bulb } + Bulb: Bulb + ControlledWithRemote: bool } let lights = [ { FriendlyName = DeviceFriendlyName "Vardagsrum - Fönsterlampa" Room = LivingRoom - Bulb = IkeaBulb } + Bulb = IkeaBulb + ControlledWithRemote = true } { FriendlyName = DeviceFriendlyName "Vardagsrum - Vägglampa" Room = LivingRoom - Bulb = PaulmannBulb } + Bulb = PaulmannBulb + ControlledWithRemote = false } { FriendlyName = DeviceFriendlyName "Vardagsrum - Golvlampa" Room = LivingRoom - Bulb = PaulmannBulb } + Bulb = PaulmannBulb + ControlledWithRemote = false } { FriendlyName = DeviceFriendlyName "Badrum - Taklampa" Room = Bathroom - Bulb = IkeaBulb } + Bulb = IkeaBulb + ControlledWithRemote = false } { FriendlyName = DeviceFriendlyName "Sovrum - Nattduksbordlampa" Room = Bedroom - Bulb = IkeaBulb } ] + Bulb = IkeaBulb + ControlledWithRemote = true } ] + +let remoteControlFriendlyName = DeviceFriendlyName "Fjärrkontroll" diff --git a/NightLight.Core/NightLightStateMachine.fs b/NightLight.Core/NightLightStateMachine.fs index f1d5d54..5a66ec4 100644 --- a/NightLight.Core/NightLightStateMachine.fs +++ b/NightLight.Core/NightLightStateMachine.fs @@ -15,7 +15,7 @@ let internal generateZigbeeCommandToFixLight partOfDay light = let color, brightness = getDesiredMood light.Room partOfDay |> getDesiredColorAndBrightness light.Bulb - generateZigbeeCommand light.FriendlyName color brightness + generateZigbeeCommand color brightness light type NightLightStateMachine private (maybeTime: DateTime option) = new() = NightLightStateMachine None @@ -37,6 +37,12 @@ type NightLightStateMachine private (maybeTime: DateTime option) = match maybeLight with | Some light -> generateZigbeeCommandToFixLight partOfDay light |> Seq.singleton | None -> Seq.empty + | ButtonPress action -> + let remoteControlledLights = lights |> Seq.filter _.ControlledWithRemote + + match action with + | PressedOn -> remoteControlledLights |> Seq.map (generateStateCommand On) + | PressedOff -> remoteControlledLights |> Seq.map (generateStateCommand Off) | TimeChanged newTime, maybePartOfDay -> let newState = NightLightStateMachine(Some newTime) let newPartOfDay = getPartOfDay newTime diff --git a/NightLight.Core/ZigbeeCommands.fs b/NightLight.Core/ZigbeeCommands.fs index 2d25c04..955c041 100644 --- a/NightLight.Core/ZigbeeCommands.fs +++ b/NightLight.Core/ZigbeeCommands.fs @@ -4,7 +4,28 @@ open System.Text.Json.Nodes open NightLight.Core.Models open NightLight.Core.Moods -let generateZigbeeCommand (friendlyName: DeviceFriendlyName) targetColor targetBrightness = +type State = + | On + | Off + +let toZigbeeCommand light payload = + let topic = $"zigbee2mqtt/{light.FriendlyName.Get}/set" + { Topic = topic; Payload = payload } + +let generateStateCommand state light = + let commandObj = JsonObject() + + commandObj["state"] <- + match state with + | On -> "ON" + | Off -> "OFF" + + if light.Bulb = IkeaBulb then + commandObj["transition"] <- 0 + + commandObj.ToJsonString() |> toZigbeeCommand light + +let generateZigbeeCommand targetColor targetBrightness light = let commandObj = JsonObject() match targetColor with @@ -19,7 +40,4 @@ let generateZigbeeCommand (friendlyName: DeviceFriendlyName) targetColor targetB match targetBrightness with | Brightness b -> b - let topic = $"zigbee2mqtt/{friendlyName.Get}/set" - let payload = commandObj.ToJsonString() - - { Topic = topic; Payload = payload } + commandObj.ToJsonString() |> toZigbeeCommand light diff --git a/NightLight.Core/ZigbeeEvents.fs b/NightLight.Core/ZigbeeEvents.fs index e6a9769..0c31a63 100644 --- a/NightLight.Core/ZigbeeEvents.fs +++ b/NightLight.Core/ZigbeeEvents.fs @@ -4,22 +4,38 @@ open NightLight.Core.Models open FsToolkit.ErrorHandling open FSharp.Data -type ZigbeeEvent = DeviceAnnounce of DeviceFriendlyName +type Action = + | PressedOn + | PressedOff + +type ZigbeeEvent = + | DeviceAnnounce of DeviceFriendlyName + | ButtonPress of Action let parseZigbeeEvent (message: Message) = result { let! jsonValue = JsonValue.TryParse message.Payload |> Result.requireSome InvalidJson - let! messageType = jsonValue.TryGetProperty "type" |> Result.requireSome MissingTypeField - let! messageData = jsonValue.TryGetProperty "data" |> Result.requireSome MissingDataField + match message.Topic with + | "zigbee2mqtt/bridge/event" -> + let! messageType = jsonValue.TryGetProperty "type" |> Result.requireSome MissingTypeField + let! messageData = jsonValue.TryGetProperty "data" |> Result.requireSome MissingDataField - return! - match messageType with - | JsonValue.String "device_announce" -> - match messageData.TryGetProperty "friendly_name" with - | Some(JsonValue.String friendlyName) -> Ok <| DeviceAnnounce(DeviceFriendlyName friendlyName) - | Some _ -> Error InvalidFriendlyNameField - | None -> Error MissingFriendlyNameField - | JsonValue.String _ -> Error UnknownType - | _ -> Error InvalidTypeField + return! + match messageType with + | JsonValue.String "device_announce" -> + match messageData.TryGetProperty "friendly_name" with + | Some(JsonValue.String friendlyName) -> Ok <| DeviceAnnounce(DeviceFriendlyName friendlyName) + | Some _ -> Error InvalidFriendlyNameField + | None -> Error MissingFriendlyNameField + | JsonValue.String _ -> Error UnknownType + | _ -> Error InvalidTypeField + | "zigbee2mqtt/Fjärrkontroll" -> + return! + match jsonValue.TryGetProperty "action" with + | Some(JsonValue.String "on") -> Ok(ButtonPress PressedOn) + | Some(JsonValue.String "off") -> Ok(ButtonPress PressedOff) + | Some _ -> Error InvalidActionField + | None -> Error MissingActionField + | _ -> return! Error UnknownTopic } diff --git a/NightLight/Program.fs b/NightLight/Program.fs index 04b900f..08739ca 100644 --- a/NightLight/Program.fs +++ b/NightLight/Program.fs @@ -104,8 +104,9 @@ let mainAsync _ = do! mqttClient.ConnectAsync mqttClientOptions |> Async.AwaitTask |> Async.Ignore do! - mqttClient.SubscribeAsync "zigbee2mqtt/bridge/event" - |> Async.AwaitTask + [ "zigbee2mqtt/bridge/event"; $"zigbee2mqtt/{remoteControlFriendlyName.Get}" ] + |> Seq.map (fun topic -> async { return! mqttClient.SubscribeAsync topic |> Async.AwaitTask }) + |> Async.Sequential |> Async.Ignore while true do From cef2a20f7a03576c1245428963246b7be71c7991 Mon Sep 17 00:00:00 2001 From: Sven van Heugten Date: Mon, 5 Jan 2026 21:54:34 +0100 Subject: [PATCH 04/13] Remove some ambiguity --- NightLight.Core.Tests/FakeHome.fs | 14 +++++++------- NightLight.Core.Tests/InteractionListGenerators.fs | 2 +- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/NightLight.Core.Tests/FakeHome.fs b/NightLight.Core.Tests/FakeHome.fs index 3facd72..d01c935 100644 --- a/NightLight.Core.Tests/FakeHome.fs +++ b/NightLight.Core.Tests/FakeHome.fs @@ -7,8 +7,8 @@ open FsToolkit.ErrorHandling open FSharp.Data type HumanInteraction = - | LightTurnedOn of Light - | LightTurnedOff of Light + | LightPoweredOn of Light + | LightPoweredOff of Light type Interaction = | HumanInteraction of HumanInteraction @@ -30,9 +30,9 @@ type FakeLight(light: Light) = member _.LightWithState = light, if hasPower then On(brightness, color) else Off - member _.TurnOn() = hasPower <- true + member _.PowerOn() = hasPower <- true - member _.TurnOff() = hasPower <- false + member _.PowerOff() = hasPower <- false member _.SetBrightness(newBrightness: byte) = if hasPower then @@ -91,8 +91,8 @@ type FakeHome() = member _.Interact(interaction: Interaction) = match interaction with - | HumanInteraction(LightTurnedOn light) -> - friendlyNameToFakeLight[light.FriendlyName].TurnOn() + | HumanInteraction(LightPoweredOn light) -> + friendlyNameToFakeLight[light.FriendlyName].PowerOn() { Topic = "zigbee2mqtt/bridge/event" Payload = @@ -102,7 +102,7 @@ type FakeHome() = }}" } |> ReceivedZigbeeEvent |> onEventPublished.Trigger - | HumanInteraction(LightTurnedOff light) -> friendlyNameToFakeLight[light.FriendlyName].TurnOff() + | HumanInteraction(LightPoweredOff light) -> friendlyNameToFakeLight[light.FriendlyName].PowerOff() | TimeChanged newTime -> newTime |> Event.TimeChanged |> onEventPublished.Trigger type FakeHome with diff --git a/NightLight.Core.Tests/InteractionListGenerators.fs b/NightLight.Core.Tests/InteractionListGenerators.fs index 5d620f3..17fd21e 100644 --- a/NightLight.Core.Tests/InteractionListGenerators.fs +++ b/NightLight.Core.Tests/InteractionListGenerators.fs @@ -10,7 +10,7 @@ let private genTimeChangedInteraction = let private genHumanInteraction = Gen.elements lights |> Gen.bind (fun light -> - [ LightTurnedOn light; LightTurnedOff light ] + [ LightPoweredOn light; LightPoweredOff light ] |> Gen.elements |> Gen.map Interaction.HumanInteraction) From 52e0ec85e92880461bc77fc41b09e7465a3844db Mon Sep 17 00:00:00 2001 From: Sven van Heugten Date: Mon, 5 Jan 2026 22:00:14 +0100 Subject: [PATCH 05/13] Introduce the remote into FakeHome --- NightLight.Core.Tests/FakeHome.fs | 26 ++++++++++++++++++- .../InteractionListGenerators.fs | 14 ++++++---- 2 files changed, 34 insertions(+), 6 deletions(-) diff --git a/NightLight.Core.Tests/FakeHome.fs b/NightLight.Core.Tests/FakeHome.fs index d01c935..c3a7c4c 100644 --- a/NightLight.Core.Tests/FakeHome.fs +++ b/NightLight.Core.Tests/FakeHome.fs @@ -9,6 +9,8 @@ open FSharp.Data type HumanInteraction = | LightPoweredOn of Light | LightPoweredOff of Light + | RemotePressedOnButton + | RemotePressedOffButton type Interaction = | HumanInteraction of HumanInteraction @@ -25,15 +27,21 @@ type LightState = type FakeLight(light: Light) = let mutable hasPower = false + let mutable state = true let mutable brightness: byte = 255uy let mutable color: Color = White - member _.LightWithState = light, if hasPower then On(brightness, color) else Off + member _.LightWithState = + light, if hasPower && state then On(brightness, color) else Off member _.PowerOn() = hasPower <- true member _.PowerOff() = hasPower <- false + member _.SetState(newState: bool) = + if hasPower then + state <- newState + member _.SetBrightness(newBrightness: byte) = if hasPower then brightness <- newBrightness @@ -69,6 +77,12 @@ type FakeHome() = let parsedPayload = JsonValue.Parse command.Payload + match parsedPayload.TryGetProperty "state" with + | Some(JsonValue.String "ON") -> fakeLight.SetState true + | Some(JsonValue.String "OFF") -> fakeLight.SetState false + | None -> () + | value -> failwith $"Unexpected state value {value}" + match parsedPayload.TryGetProperty "brightness" with | Some(JsonValue.Number newBrightness) -> fakeLight.SetBrightness(byte newBrightness) | None -> () @@ -103,6 +117,16 @@ type FakeHome() = |> ReceivedZigbeeEvent |> onEventPublished.Trigger | HumanInteraction(LightPoweredOff light) -> friendlyNameToFakeLight[light.FriendlyName].PowerOff() + | HumanInteraction RemotePressedOnButton -> + { Topic = $"zigbee2mqtt/{remoteControlFriendlyName.Get}" + Payload = @"{ ""action"": ""on"" }" } + |> ReceivedZigbeeEvent + |> onEventPublished.Trigger + | HumanInteraction RemotePressedOffButton -> + { Topic = $"zigbee2mqtt/{remoteControlFriendlyName.Get}" + Payload = @"{ ""action"": ""off"" }" } + |> ReceivedZigbeeEvent + |> onEventPublished.Trigger | TimeChanged newTime -> newTime |> Event.TimeChanged |> onEventPublished.Trigger type FakeHome with diff --git a/NightLight.Core.Tests/InteractionListGenerators.fs b/NightLight.Core.Tests/InteractionListGenerators.fs index 17fd21e..7289a32 100644 --- a/NightLight.Core.Tests/InteractionListGenerators.fs +++ b/NightLight.Core.Tests/InteractionListGenerators.fs @@ -8,11 +8,15 @@ let private genTimeChangedInteraction = ArbMap.defaults |> ArbMap.generate |> Gen.map Interaction.TimeChanged let private genHumanInteraction = - Gen.elements lights - |> Gen.bind (fun light -> - [ LightPoweredOn light; LightPoweredOff light ] - |> Gen.elements - |> Gen.map Interaction.HumanInteraction) + let genLightInteraction = + Gen.elements lights + |> Gen.bind (fun light -> Gen.elements [ LightPoweredOn light; LightPoweredOff light ]) + + let genRemoteInteraction = + Gen.elements [ RemotePressedOnButton; RemotePressedOffButton ] + + Gen.oneof [ genLightInteraction; genRemoteInteraction ] + |> Gen.map Interaction.HumanInteraction let private genInteraction = Gen.oneof [ genTimeChangedInteraction; genHumanInteraction ] From e792a57cb4fc67b6356e38575e7d4030a7288b17 Mon Sep 17 00:00:00 2001 From: Sven van Heugten Date: Mon, 5 Jan 2026 22:06:18 +0100 Subject: [PATCH 06/13] Improve error for unknown topics --- NightLight.Core/Models.fs | 2 +- NightLight.Core/ZigbeeEvents.fs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/NightLight.Core/Models.fs b/NightLight.Core/Models.fs index 363f085..5243bcb 100644 --- a/NightLight.Core/Models.fs +++ b/NightLight.Core/Models.fs @@ -9,7 +9,7 @@ type Event = | TimeChanged of DateTime type ParseZigbeeEventError = - | UnknownTopic + | UnknownTopic of string | InvalidJson | MissingTypeField | MissingDataField diff --git a/NightLight.Core/ZigbeeEvents.fs b/NightLight.Core/ZigbeeEvents.fs index 0c31a63..632c6b1 100644 --- a/NightLight.Core/ZigbeeEvents.fs +++ b/NightLight.Core/ZigbeeEvents.fs @@ -37,5 +37,5 @@ let parseZigbeeEvent (message: Message) = | Some(JsonValue.String "off") -> Ok(ButtonPress PressedOff) | Some _ -> Error InvalidActionField | None -> Error MissingActionField - | _ -> return! Error UnknownTopic + | _ -> return! Error <| UnknownTopic message.Topic } From 747282514063a73507978b06be664c23063a5fe8 Mon Sep 17 00:00:00 2001 From: Sven van Heugten Date: Mon, 5 Jan 2026 22:22:14 +0100 Subject: [PATCH 07/13] Demonstrate a bug --- .../ArbitraryInteractionLists.fs | 1 + NightLight.Core.Tests/FakeHome.fs | 5 +++++ .../InteractionListGenerators.fs | 2 +- NightLight.Core.Tests/NightLightTests.fs | 16 ++++++++++++++++ 4 files changed, 23 insertions(+), 1 deletion(-) diff --git a/NightLight.Core.Tests/ArbitraryInteractionLists.fs b/NightLight.Core.Tests/ArbitraryInteractionLists.fs index 1a80df4..906ae6d 100644 --- a/NightLight.Core.Tests/ArbitraryInteractionLists.fs +++ b/NightLight.Core.Tests/ArbitraryInteractionLists.fs @@ -3,6 +3,7 @@ module NightLight.Core.Tests.ArbitraryInteractionLists open System open FsCheck.FSharp open NightLight.Core.Tests.InteractionListGenerators +open NightLight.Core.Models let private isDay (time: DateTime) = time.TimeOfDay >= TimeSpan.FromHours 5.5 diff --git a/NightLight.Core.Tests/FakeHome.fs b/NightLight.Core.Tests/FakeHome.fs index c3a7c4c..11e0bb0 100644 --- a/NightLight.Core.Tests/FakeHome.fs +++ b/NightLight.Core.Tests/FakeHome.fs @@ -139,3 +139,8 @@ type FakeHome with | On(brightness, color) -> Some(light, brightness, color) | Off -> None) |> Seq.forall condition + + member this.ForAllRemotelyControlledLights condition = + this.LightStates + |> Seq.filter (fst >> _.ControlledWithRemote) + |> Seq.forall condition diff --git a/NightLight.Core.Tests/InteractionListGenerators.fs b/NightLight.Core.Tests/InteractionListGenerators.fs index 7289a32..144579f 100644 --- a/NightLight.Core.Tests/InteractionListGenerators.fs +++ b/NightLight.Core.Tests/InteractionListGenerators.fs @@ -28,7 +28,7 @@ let private genInteractionsListThatStartsWithTimeChanged = return firstInteraction :: remainingInteractions } -let private genInteractionListContaining containingInteraction afterFilter = +let genInteractionListContaining containingInteraction afterFilter = gen { let genNonTrivialList = gen { diff --git a/NightLight.Core.Tests/NightLightTests.fs b/NightLight.Core.Tests/NightLightTests.fs index 9eaad9e..4ca2fb7 100644 --- a/NightLight.Core.Tests/NightLightTests.fs +++ b/NightLight.Core.Tests/NightLightTests.fs @@ -2,7 +2,10 @@ namespace NightLight.Core.Tests open NightLight.Core.Core open NightLight.Core.Tests.ArbitraryInteractionLists +open NightLight.Core.Tests.InteractionListGenerators +open FsCheck open FsCheck.Xunit +open FsCheck.FSharp type NightLightTests() = let createFakeHomeWithNightLightAndInteract (interactions: Interaction list) = @@ -30,3 +33,16 @@ type NightLightTests() = let ``All lights that are on should be red during the night`` (interactions: Interaction list) = let fakeHome = createFakeHomeWithNightLightAndInteract interactions fakeHome.ForAllLightsThatAreOn(fun (_, _, color) -> color = Red) + + [] + let ``After pressing 'Off' on the remote, the remotely controlled lights should stay off until 'On' is pressed again`` + () + = + genInteractionListContaining + (HumanInteraction RemotePressedOffButton) + ((<>) (HumanInteraction RemotePressedOnButton)) + |> Arb.fromGen + |> Prop.forAll + <| fun interactions -> + let fakeHome = createFakeHomeWithNightLightAndInteract interactions + fakeHome.ForAllRemotelyControlledLights(fun (_, state) -> state = Off) From bb528e99422d213f53fb54083dbe9e9564027012 Mon Sep 17 00:00:00 2001 From: Sven van Heugten Date: Mon, 5 Jan 2026 22:34:21 +0100 Subject: [PATCH 08/13] Get rid of arbitraries that are only used once --- .../ArbitraryInteractionLists.fs | 26 ----------------- .../InteractionListGenerators.fs | 3 -- .../NightLight.Core.Tests.fsproj | 2 +- NightLight.Core.Tests/NightLightTests.fs | 29 ++++++++++++------- .../TimeChangedGenerators.fs | 20 +++++++++++++ 5 files changed, 40 insertions(+), 40 deletions(-) delete mode 100644 NightLight.Core.Tests/ArbitraryInteractionLists.fs create mode 100644 NightLight.Core.Tests/TimeChangedGenerators.fs diff --git a/NightLight.Core.Tests/ArbitraryInteractionLists.fs b/NightLight.Core.Tests/ArbitraryInteractionLists.fs deleted file mode 100644 index 906ae6d..0000000 --- a/NightLight.Core.Tests/ArbitraryInteractionLists.fs +++ /dev/null @@ -1,26 +0,0 @@ -module NightLight.Core.Tests.ArbitraryInteractionLists - -open System -open FsCheck.FSharp -open NightLight.Core.Tests.InteractionListGenerators -open NightLight.Core.Models - -let private isDay (time: DateTime) = - time.TimeOfDay >= TimeSpan.FromHours 5.5 - && time.TimeOfDay < TimeSpan.FromHours 20.5 - -type ArbitraryInteractionListThatEndsDuringTheDay = - static member InteractionsList() = - ArbMap.defaults - |> ArbMap.generate - |> Gen.filter isDay - |> Gen.bind genInteractionListThatEndsAtTime - |> Arb.fromGen - -type ArbitraryInteractionListThatEndsDuringTheNight = - static member InteractionsList() = - ArbMap.defaults - |> ArbMap.generate - |> Gen.filter (not << isDay) - |> Gen.bind genInteractionListThatEndsAtTime - |> Arb.fromGen diff --git a/NightLight.Core.Tests/InteractionListGenerators.fs b/NightLight.Core.Tests/InteractionListGenerators.fs index 144579f..d901847 100644 --- a/NightLight.Core.Tests/InteractionListGenerators.fs +++ b/NightLight.Core.Tests/InteractionListGenerators.fs @@ -44,6 +44,3 @@ let genInteractionListContaining containingInteraction afterFilter = Gen.frequency [ 1, genTrivialList; 9, genNonTrivialList ] | _ -> genNonTrivialList } - -let genInteractionListThatEndsAtTime time = - genInteractionListContaining (Interaction.TimeChanged time) (not << _.IsTimeChanged) diff --git a/NightLight.Core.Tests/NightLight.Core.Tests.fsproj b/NightLight.Core.Tests/NightLight.Core.Tests.fsproj index 66f25e0..8dbe2c5 100644 --- a/NightLight.Core.Tests/NightLight.Core.Tests.fsproj +++ b/NightLight.Core.Tests/NightLight.Core.Tests.fsproj @@ -9,7 +9,7 @@ - + diff --git a/NightLight.Core.Tests/NightLightTests.fs b/NightLight.Core.Tests/NightLightTests.fs index 4ca2fb7..292a417 100644 --- a/NightLight.Core.Tests/NightLightTests.fs +++ b/NightLight.Core.Tests/NightLightTests.fs @@ -1,9 +1,8 @@ namespace NightLight.Core.Tests open NightLight.Core.Core -open NightLight.Core.Tests.ArbitraryInteractionLists +open NightLight.Core.Tests.TimeChangedGenerators open NightLight.Core.Tests.InteractionListGenerators -open FsCheck open FsCheck.Xunit open FsCheck.FSharp @@ -24,15 +23,25 @@ type NightLightTests() = fakeHome - [ |])>] - let ``All lights that are on should be white or yellow during the day`` (interactions: Interaction list) = - let fakeHome = createFakeHomeWithNightLightAndInteract interactions - fakeHome.ForAllLightsThatAreOn(fun (_, _, color) -> color = White || color = Yellow) + [] + let ``All lights that are on should be white or yellow during the day`` () = + genTimeChangedToDay + |> Gen.bind (fun timeChangedToDay -> genInteractionListContaining timeChangedToDay (not << _.IsTimeChanged)) + |> Arb.fromGen + |> Prop.forAll + <| fun interactions -> + let fakeHome = createFakeHomeWithNightLightAndInteract interactions + fakeHome.ForAllLightsThatAreOn(fun (_, _, color) -> color = White || color = Yellow) - [ |])>] - let ``All lights that are on should be red during the night`` (interactions: Interaction list) = - let fakeHome = createFakeHomeWithNightLightAndInteract interactions - fakeHome.ForAllLightsThatAreOn(fun (_, _, color) -> color = Red) + [] + let ``All lights that are on should be red during the night`` () = + genTimeChangedToNight + |> Gen.bind (fun timeChangedToNight -> genInteractionListContaining timeChangedToNight (not << _.IsTimeChanged)) + |> Arb.fromGen + |> Prop.forAll + <| fun interactions -> + let fakeHome = createFakeHomeWithNightLightAndInteract interactions + fakeHome.ForAllLightsThatAreOn(fun (_, _, color) -> color = Red) [] let ``After pressing 'Off' on the remote, the remotely controlled lights should stay off until 'On' is pressed again`` diff --git a/NightLight.Core.Tests/TimeChangedGenerators.fs b/NightLight.Core.Tests/TimeChangedGenerators.fs new file mode 100644 index 0000000..6f1300d --- /dev/null +++ b/NightLight.Core.Tests/TimeChangedGenerators.fs @@ -0,0 +1,20 @@ +module NightLight.Core.Tests.TimeChangedGenerators + +open System +open FsCheck.FSharp + +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 genTimeChangedToNight = + ArbMap.defaults + |> ArbMap.generate + |> Gen.filter (not << isDay) + |> Gen.map Interaction.TimeChanged From 2443468eb4b2d2508e92589cfb7d5885bd0be433 Mon Sep 17 00:00:00 2001 From: Sven van Heugten Date: Mon, 5 Jan 2026 22:48:42 +0100 Subject: [PATCH 09/13] Fix the bug by keeping state --- NightLight.Core/NightLightStateMachine.fs | 35 ++++++++++++++++------- 1 file changed, 24 insertions(+), 11 deletions(-) diff --git a/NightLight.Core/NightLightStateMachine.fs b/NightLight.Core/NightLightStateMachine.fs index 5a66ec4..556300f 100644 --- a/NightLight.Core/NightLightStateMachine.fs +++ b/NightLight.Core/NightLightStateMachine.fs @@ -11,14 +11,17 @@ open FsToolkit.ErrorHandling let internal tryFindLight friendlyName = Seq.tryFind (fun light -> light.FriendlyName = friendlyName) lights -let internal generateZigbeeCommandToFixLight partOfDay light = +let internal generateZigbeeCommandsToFixLight state partOfDay light = let color, brightness = getDesiredMood light.Room partOfDay |> getDesiredColorAndBrightness light.Bulb - generateZigbeeCommand color brightness light + seq { + generateZigbeeCommand color brightness light + generateStateCommand state light + } -type NightLightStateMachine private (maybeTime: DateTime option) = - new() = NightLightStateMachine None +type NightLightStateMachine private (maybeTime: DateTime option, lightToState: Map) = + new() = NightLightStateMachine(None, lights |> Seq.map (fun light -> light, On) |> Map.ofSeq) member this.OnEventReceived(event: Event) : Result = result { @@ -29,28 +32,38 @@ type NightLightStateMachine private (maybeTime: DateTime option) = let! zigbeeEvent = parseZigbeeEvent payload |> Result.mapError ParseZigbeeEventError return - this, match zigbeeEvent with | DeviceAnnounce friendlyName -> let maybeLight = tryFindLight friendlyName + this, match maybeLight with - | Some light -> generateZigbeeCommandToFixLight partOfDay light |> Seq.singleton + | Some light -> generateZigbeeCommandsToFixLight lightToState[light] partOfDay light | None -> Seq.empty | ButtonPress action -> + let desiredLightState = + match action with + | PressedOn -> On + | PressedOff -> Off + let remoteControlledLights = lights |> Seq.filter _.ControlledWithRemote - match action with - | PressedOn -> remoteControlledLights |> Seq.map (generateStateCommand On) - | PressedOff -> remoteControlledLights |> Seq.map (generateStateCommand Off) + let newLightToState = + remoteControlledLights + |> Seq.fold (fun acc key -> Map.add key desiredLightState acc) lightToState + + NightLightStateMachine(maybeTime, newLightToState), + remoteControlledLights |> Seq.map (generateStateCommand desiredLightState) | TimeChanged newTime, maybePartOfDay -> - let newState = NightLightStateMachine(Some newTime) + let newState = NightLightStateMachine(Some newTime, lightToState) let newPartOfDay = getPartOfDay newTime return newState, if maybePartOfDay <> Some newPartOfDay then - lights |> Seq.map (generateZigbeeCommandToFixLight newPartOfDay) + lights + |> Seq.collect (fun light -> + generateZigbeeCommandsToFixLight lightToState[light] newPartOfDay light) else Seq.empty | _, None -> return! Error TimeIsUnknown From b9a318a5f1bb15df9d8052893298480c5457f62d Mon Sep 17 00:00:00 2001 From: Sven van Heugten Date: Mon, 5 Jan 2026 22:51:30 +0100 Subject: [PATCH 10/13] Improve test name --- NightLight.Core.Tests/NightLightTests.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/NightLight.Core.Tests/NightLightTests.fs b/NightLight.Core.Tests/NightLightTests.fs index 292a417..f19afa7 100644 --- a/NightLight.Core.Tests/NightLightTests.fs +++ b/NightLight.Core.Tests/NightLightTests.fs @@ -44,7 +44,7 @@ type NightLightTests() = fakeHome.ForAllLightsThatAreOn(fun (_, _, color) -> color = Red) [] - let ``After pressing 'Off' on the remote, the remotely controlled lights should stay off until 'On' is pressed again`` + let ``After pressing 'Off' on the remote, the remotely controlled lights should stay off until 'On' is pressed`` () = genInteractionListContaining From 9bc76cdf8e4a193b88bd34d8acfab7dadf99e79c Mon Sep 17 00:00:00 2001 From: Sven van Heugten Date: Mon, 5 Jan 2026 23:04:18 +0100 Subject: [PATCH 11/13] Invert helper function --- NightLight.Core.Tests/InteractionListGenerators.fs | 4 ++-- NightLight.Core.Tests/NightLightTests.fs | 6 +++--- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/NightLight.Core.Tests/InteractionListGenerators.fs b/NightLight.Core.Tests/InteractionListGenerators.fs index d901847..269c94e 100644 --- a/NightLight.Core.Tests/InteractionListGenerators.fs +++ b/NightLight.Core.Tests/InteractionListGenerators.fs @@ -28,12 +28,12 @@ let private genInteractionsListThatStartsWithTimeChanged = return firstInteraction :: remainingInteractions } -let genInteractionListContaining containingInteraction afterFilter = +let genInteractionListContaining containingInteraction disqualifiedAfter = gen { let genNonTrivialList = gen { let! before = genInteractionsListThatStartsWithTimeChanged - let! after = Gen.listOf (genInteraction |> Gen.filter afterFilter) + let! after = Gen.listOf (genInteraction |> Gen.filter (not << disqualifiedAfter)) return before @ containingInteraction :: after } diff --git a/NightLight.Core.Tests/NightLightTests.fs b/NightLight.Core.Tests/NightLightTests.fs index f19afa7..57ed0f4 100644 --- a/NightLight.Core.Tests/NightLightTests.fs +++ b/NightLight.Core.Tests/NightLightTests.fs @@ -26,7 +26,7 @@ type NightLightTests() = [] let ``All lights that are on should be white or yellow during the day`` () = genTimeChangedToDay - |> Gen.bind (fun timeChangedToDay -> genInteractionListContaining timeChangedToDay (not << _.IsTimeChanged)) + |> Gen.bind (fun timeChangedToDay -> genInteractionListContaining timeChangedToDay _.IsTimeChanged) |> Arb.fromGen |> Prop.forAll <| fun interactions -> @@ -36,7 +36,7 @@ type NightLightTests() = [] let ``All lights that are on should be red during the night`` () = genTimeChangedToNight - |> Gen.bind (fun timeChangedToNight -> genInteractionListContaining timeChangedToNight (not << _.IsTimeChanged)) + |> Gen.bind (fun timeChangedToNight -> genInteractionListContaining timeChangedToNight _.IsTimeChanged) |> Arb.fromGen |> Prop.forAll <| fun interactions -> @@ -49,7 +49,7 @@ type NightLightTests() = = genInteractionListContaining (HumanInteraction RemotePressedOffButton) - ((<>) (HumanInteraction RemotePressedOnButton)) + ((=) (HumanInteraction RemotePressedOnButton)) |> Arb.fromGen |> Prop.forAll <| fun interactions -> From 10d858817de4f0843314b3c6195578af87d7a2f5 Mon Sep 17 00:00:00 2001 From: Sven van Heugten Date: Mon, 5 Jan 2026 23:10:26 +0100 Subject: [PATCH 12/13] Turn on lights before changing brightness and color --- NightLight.Core/NightLightStateMachine.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/NightLight.Core/NightLightStateMachine.fs b/NightLight.Core/NightLightStateMachine.fs index 556300f..0d6728e 100644 --- a/NightLight.Core/NightLightStateMachine.fs +++ b/NightLight.Core/NightLightStateMachine.fs @@ -16,8 +16,8 @@ let internal generateZigbeeCommandsToFixLight state partOfDay light = getDesiredMood light.Room partOfDay |> getDesiredColorAndBrightness light.Bulb seq { - generateZigbeeCommand color brightness light generateStateCommand state light + generateZigbeeCommand color brightness light } type NightLightStateMachine private (maybeTime: DateTime option, lightToState: Map) = From c1d9029a73e7d140c506c70b74df4505b3dc00af Mon Sep 17 00:00:00 2001 From: Sven van Heugten Date: Mon, 5 Jan 2026 23:21:46 +0100 Subject: [PATCH 13/13] Demonstrate and fix some odd behaviour with some bulbs --- NightLight.Core.Tests/FakeHome.fs | 3 +++ NightLight.Core/NightLightStateMachine.fs | 15 +++++++++------ 2 files changed, 12 insertions(+), 6 deletions(-) diff --git a/NightLight.Core.Tests/FakeHome.fs b/NightLight.Core.Tests/FakeHome.fs index 11e0bb0..bf1b919 100644 --- a/NightLight.Core.Tests/FakeHome.fs +++ b/NightLight.Core.Tests/FakeHome.fs @@ -46,6 +46,9 @@ type FakeLight(light: Light) = if hasPower then brightness <- newBrightness + if light.Bulb = IkeaBulb then + state <- true + member _.SetColor(newColor: Color) = if hasPower then color <- newColor diff --git a/NightLight.Core/NightLightStateMachine.fs b/NightLight.Core/NightLightStateMachine.fs index 0d6728e..6068de5 100644 --- a/NightLight.Core/NightLightStateMachine.fs +++ b/NightLight.Core/NightLightStateMachine.fs @@ -12,12 +12,14 @@ let internal tryFindLight friendlyName = Seq.tryFind (fun light -> light.FriendlyName = friendlyName) lights let internal generateZigbeeCommandsToFixLight state partOfDay light = - let color, brightness = - getDesiredMood light.Room partOfDay |> getDesiredColorAndBrightness light.Bulb - seq { - generateStateCommand state light - generateZigbeeCommand color brightness light + yield generateStateCommand state light + + if state = On then + let color, brightness = + getDesiredMood light.Room partOfDay |> getDesiredColorAndBrightness light.Bulb + + yield generateZigbeeCommand color brightness light } type NightLightStateMachine private (maybeTime: DateTime option, lightToState: Map) = @@ -53,7 +55,8 @@ type NightLightStateMachine private (maybeTime: DateTime option, lightToState: M |> Seq.fold (fun acc key -> Map.add key desiredLightState acc) lightToState NightLightStateMachine(maybeTime, newLightToState), - remoteControlledLights |> Seq.map (generateStateCommand desiredLightState) + remoteControlledLights + |> Seq.collect (fun light -> generateZigbeeCommandsToFixLight desiredLightState partOfDay light) | TimeChanged newTime, maybePartOfDay -> let newState = NightLightStateMachine(Some newTime, lightToState) let newPartOfDay = getPartOfDay newTime