diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -6,6 +6,16 @@
## Unreleased
+- Awesome upcoming features!
+
+## 0.0.1.1 - Small cosmetic improvements - 2025-03-28
+
+- Demonstration:
+ - Added menu and option to change wled device URL via terminal or command line argument
+ - Added tool to traverse every single LED (to be able to better detect positions)
+- Octolamp Support:
+ - Added more flags with three vertical stripes
+
## 0.0.1.0 - Initial release - 2024-12-02
- Core Functionality:
diff --git a/LICENSE b/LICENSE
--- a/LICENSE
+++ b/LICENSE
@@ -1,4 +1,4 @@
-Copyright 2024 Andreas Ländle
+Copyright 2024-2025 Andreas Ländle
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -3,7 +3,7 @@
Haskell bindings for controlling WLED devices, with a focus on Octolamps
- 
+ 
## Introduction 💡
diff --git a/app/Main.hs b/app/Main.hs
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -1,45 +1,100 @@
-{-# LANGUAGE Arrows #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+#if __GLASGOW_HASKELL__ < 904
+{-# LANGUAGE TypeFamilies #-}
+#endif
module Main (main) where
import Control.Monad (void)
-import Data.Kind (Type)
import FRP.Rhine
-import GHC.TypeLits (Nat)
+import System.Environment (getArgs)
+import System.IO (BufferMode (NoBuffering), hSetBuffering, stdout)
import WLED.Device
-import WLED.Octocat.Flags (france)
+import WLED.Octocat.Flags (belgium, cameroon, chad, france, guatemala, guinea, ireland, italy, ivoryCoast, mali, nigeria, peru)
import WLED.Types
waitForEnter :: ClSF (ExceptT () IO) StdinClock () ()
waitForEnter = arrMCl throwE
-type TimeClock :: Nat -> Type
-type TimeClock ms = LiftClock IO (ExceptT ()) (Millisecond ms)
-
-sinusWave :: (Int -> ExceptT () IO ()) -> ClSF (ExceptT () IO) (TimeClock 100) () ()
-sinusWave signalHandler = sinceStart >>> proc time -> do
- arrMCl (signalHandler . scaledSinusWave 0 255 0.1) -< time
- returnA -< ()
+sinusWave :: Monad m => Int -> Int -> Double -> ClSF m cl Double Int
+sinusWave low high frequency = arr scaledSinusWave
where
- timeToSinusWave :: Double -> Double -> Double
- timeToSinusWave frequency t = sin (2 * pi * frequency * t)
- scaledSinusWave :: Int -> Int -> Double -> Double -> Int
- scaledSinusWave a b frequency time = round $ fromIntegral (b - a) / 2 * timeToSinusWave frequency time + fromIntegral (a + b) / 2
+ timeToSinusWave :: Double -> Double
+ timeToSinusWave t = sin (2 * pi * frequency * t)
+ scaledSinusWave :: Double -> Int
+ scaledSinusWave time = round $ fromIntegral (high - low) / 2 * timeToSinusWave time + fromIntegral (high + low) / 2
+brightnessSinus :: Monad m => Double -> ClSF m cl Double StatePatch
+brightnessSinus frequency = sinusWave 0 255 frequency >-> arr (\bri -> (mempty :: StatePatch) { stateBri = Just bri })
+
+switchFlags :: Monad m => Double -> ClSF m cl Double StatePatch
+switchFlags frequency = arr (\t -> allFlags !! (floor (t * frequency) `mod` length allFlags)) where
+ allFlags = [belgium, cameroon, chad, france, guatemala, guinea, ireland, italy, ivoryCoast, mali, nigeria, peru]
+
+animation :: (Monad m, TimeDomain (Time cl), Diff (Time cl) ~ Double) => ClSF m cl () StatePatch
+animation = sinceStart >-> proc time -> do
+ brightness <- brightnessSinus 0.1 -< time
+ flag <- switchFlags 0.2 -< time
+ returnA -< brightness <> flag
+
+traverseLed :: (Monad m, TimeDomain (Time cl), Diff (Time cl) ~ Double) => ClSF m cl () StatePatch
+traverseLed = sinceStart >-> arr (\t -> (mempty :: StatePatch) { stateBri = Just 255, stateSeg = Just [segment (floor (t / 3.0)) (floor (t / 3.0) + 1 ) [255, 255, 255]]})
+
main :: IO ()
main = do
- lampState <- getLampState wledUrl
- case lampState of
+ hSetBuffering stdout NoBuffering
+ putStrLn "-----------------------------------------------------------------------"
+ putStrLn "Welcome to the wled-json demo."
+ putStrLn "-----------------------------------------------------------------------"
+ args <- getArgs
+ mainLoop $ case args of (url:_) -> url; _ -> defaultWledUrl
+ where
+ mainLoop :: String -> IO ()
+ mainLoop wledUrl = do
+ putStrLn ""
+ putStrLn "1: Change URL for WLED device."
+ putStrLn "2: Run octolamp flags demo."
+ putStrLn "3: Traverse single LED."
+ putStrLn "q: Quit."
+ putStrLn ""
+ putStr $ "(" ++ wledUrl ++ ") > "
+ choice <- getLine
+ case choice of
+ "1" -> do
+ putStrLn ""
+ putStr "Enter new URL: "
+ getLine >>= mainLoop
+ "2" -> do
+ putStrLn ""
+ putStrLn "Press [Enter] to stop demonstration."
+ localLampState wledUrl $ void $ runExceptT $ flow $ waitForEnter @@ StdinClock |@| (animation >-> arrMCl (liftIO . void . setLampState wledUrl)) @@ liftClock @IO @(ExceptT ()) (waitClock @100)
+ mainLoop wledUrl
+ "3" -> do
+ putStrLn ""
+ putStrLn "Press [Enter] to stop traversal."
+ localLampState wledUrl $ void $ runExceptT $ flow $ waitForEnter @@ StdinClock |@| (traverseLed >-> arrMCl (liftIO . void . setLampState wledUrl)) @@ liftClock @IO @(ExceptT ()) (waitClock @100)
+ mainLoop wledUrl
+ "q" -> pure ()
+ "Q" -> pure ()
+ _ -> do
+ putStrLn "Could not recognize option."
+ mainLoop wledUrl
+ localLampState :: String -> IO () -> IO ()
+ localLampState wledUrl action = do
+ lampState <- getLampState wledUrl
+ case lampState of
Left errMsg -> putStrLn errMsg
Right initialState -> do
- _ <- setLampState wledUrl france
- void $ runExceptT $ flow $ waitForEnter @@ StdinClock |@| sinusWave (\bri -> liftIO $ void $ setLampState wledUrl (mempty :: StatePatch) { stateBri = Just bri }) @@ liftClock waitClock
- Right currentState <- getLampState wledUrl
- _ <- setLampState wledUrl (diff currentState initialState)
- -- validate that initial state is restored
- Right restoredState <- getLampState wledUrl
- putStrLn $ "Initial state is restored: " <> show (initialState == restoredState)
- where
- wledUrl = "http://192.168.178.34"
+ action
+ Right currentState <- getLampState wledUrl
+ _ <- setLampState wledUrl (diff currentState initialState)
+ -- validate that initial state is restored
+ Right restoredState <- getLampState wledUrl
+ putStrLn $ "Initial state is restored: " <> show (initialState == restoredState)
+ defaultWledUrl :: String
+ defaultWledUrl = "http://192.168.178.34"
diff --git a/src/WLED/Device.hs b/src/WLED/Device.hs
--- a/src/WLED/Device.hs
+++ b/src/WLED/Device.hs
@@ -3,7 +3,7 @@
{-|
Module : WLED.Device
-Copyright : (c) Andreas Ländle, 2024
+Copyright : (c) Andreas Ländle, 2024-2025
License : BSD-3
Stability : experimental
diff --git a/src/WLED/Octocat/Flags.hs b/src/WLED/Octocat/Flags.hs
--- a/src/WLED/Octocat/Flags.hs
+++ b/src/WLED/Octocat/Flags.hs
@@ -1,26 +1,122 @@
{-|
Module : WLED.Octocat.Flags
-Copyright : (c) Andreas Ländle, 2024
+Copyright : (c) Andreas Ländle, 2024-2025
License : BSD-3
Stability : experimental
Octolamp specific feature to display flags.
-}
-module WLED.Octocat.Flags(france) where
+module WLED.Octocat.Flags(belgium, cameroon, chad, france, guatemala, guinea, ireland, italy, ivoryCoast, mali, nigeria, peru) where
import WLED.Types
+-- | The Belgian flag.
+belgium :: StatePatch
+belgium = threeVerticalStripes ral9017 ral2007 ral3028
+
+-- | The Cameroonian flag.
+cameroon :: StatePatch
+cameroon = threeVerticalStripes ral6024 ral3028 ral1018
+
+-- | The Chad flag.
+chad :: StatePatch
+chad = threeVerticalStripes ral5026 ral2007 ral3028
+
-- | The French flag.
france :: StatePatch
-france = (mempty :: StatePatch) { stateSeg = Just [ seg 0 5 white, seg 5 16 red, seg 16 23 white, seg 23 34 blue, seg 34 41 white, seg 41 52 blue, seg 52 57 white, seg 57 68 red, seg 68 101 white ]} where
- red :: [Int]
- red = [255,0,0]
- white :: [Int]
- white = [255,255,255]
- blue :: [Int]
- blue = [0,0,255]
+france = threeVerticalStripes ral5002 white ral3020
-seg :: Int -> Int -> [Int] -> SegmentPatch
-seg start stop color = (mempty :: SegmentPatch) { segmentStart = Just start, segmentStop = Just stop, segmentCol = Just [color], segmentFx = Just 0 }
+-- | The Guatemalan flag.
+guatemala :: StatePatch
+guatemala = threeVerticalStripes ral5012 white ral5012
+
+-- | The Guinean flag.
+guinea :: StatePatch
+guinea = threeVerticalStripes ral3028 ral1018 ral6024
+
+-- | The Irish flag.
+ireland :: StatePatch
+ireland = threeVerticalStripes ral6024 white ral1028
+
+-- | The Italian flag.
+italy :: StatePatch
+italy = threeVerticalStripes ral6024 ral9016 ral3028
+
+-- | The Ivory Coast flag.
+ivoryCoast :: StatePatch
+ivoryCoast = threeVerticalStripes ral1028 white ral6024
+
+-- | The Malian flag.
+mali :: StatePatch
+mali = threeVerticalStripes ral6038 ral1018 ral3028
+
+-- | The Nigerian flag.
+nigeria :: StatePatch
+nigeria = threeVerticalStripes ral6001 white ral6001
+
+-- | The Peruvian flag.
+peru :: StatePatch
+peru = threeVerticalStripes ral3028 white ral3028
+
+threeVerticalStripes :: [Int] -> [Int] -> [Int] -> StatePatch
+threeVerticalStripes leftColor middleColor rightColor = (mempty :: StatePatch) { stateSeg = Just [
+ segment 0 3 middleColor,
+ segment 3 17 rightColor,
+ segment 17 21 middleColor,
+ segment 21 36 leftColor,
+ segment 36 40 middleColor,
+ segment 40 53 leftColor,
+ segment 53 57 middleColor,
+ segment 57 69 rightColor,
+ segment 69 75 middleColor,
+ segment 75 80 rightColor,
+ segment 80 84 middleColor,
+ segment 84 91 leftColor,
+ segment 91 94 middleColor,
+ segment 94 98 leftColor,
+ segment 98 101 middleColor ]}
+--threeVerticalStripes leftColor middleColor rightColor = (mempty :: StatePatch) { stateSeg = Just [ segment 0 5 middleColor, segment 5 16 rightColor, segment 16 23 middleColor, segment 23 34 leftColor, segment 34 41 middleColor, segment 41 52 leftColor, segment 52 57 middleColor, segment 57 68 rightColor, segment 68 101 middleColor ]}
+
+ral1018 :: [Int]
+ral1018 = [252, 209, 22]
+
+ral1028 :: [Int]
+ral1028 = [255, 120, 0]
+
+ral2007 :: [Int]
+ral2007 = [255, 205, 0]
+
+ral3020 :: [Int]
+ral3020 = [255,0,15]
+
+ral3028 :: [Int]
+ral3028 = [200, 16, 46]
+
+ral5002 :: [Int]
+ral5002 = [0,0,145]
+
+ral5012 :: [Int]
+ral5012 = [73, 151, 208]
+
+ral5026 :: [Int]
+ral5026 = [0, 38, 100]
+
+ral6001 :: [Int]
+ral6001 = [27, 115, 57]
+
+ral6024 :: [Int]
+ral6024 = [0, 154, 68]
+
+ral6038 :: [Int]
+ral6038 = [20, 181, 58]
+
+ral9016 :: [Int]
+ral9016 = [244, 249, 255]
+
+ral9017 :: [Int]
+ral9017 = [45, 41, 28]
+
+white :: [Int]
+white = [255,255,255]
diff --git a/src/WLED/Types.hs b/src/WLED/Types.hs
--- a/src/WLED/Types.hs
+++ b/src/WLED/Types.hs
@@ -11,14 +11,14 @@
{-|
Module : WLED.Device
-Copyright : (c) Andreas Ländle, 2024
+Copyright : (c) Andreas Ländle, 2024-2025
License : BSD-3
Stability : experimental
Types representing states and state changes of a WLED device.
-}
-module WLED.Types (State (..), Nightlight (..), Segment (..), StateComplete, StatePatch, NightlightComplete, NightlightPatch, SegmentComplete, SegmentPatch, append, diff) where
+module WLED.Types (State (..), Nightlight (..), Segment (..), StateComplete, StatePatch, NightlightComplete, NightlightPatch, SegmentComplete, SegmentPatch, append, diff, segment) where
import Barbies.Bare
import Control.Applicative (Alternative ((<|>)), empty)
@@ -216,6 +216,9 @@
d' a b = if a == b then Nothing else Just $ diff' a b
d'' :: [Segment Bare Identity] -> [Segment Bare Identity] -> Maybe [Segment Covered Maybe]
d'' a b = if a == b then Nothing else Just $ zipWith (\i bb -> maybe (bmap (Just . runIdentity) $ bcover bb) (`diff'` bb) (a !? i)) [0..] b ++ replicate (length a - length b) ((mempty :: SegmentPatch) { segmentStop = Just 0 })
+
+segment :: Int -> Int -> [Int] -> SegmentPatch
+segment start stop color = (mempty :: SegmentPatch) { segmentStart = Just start, segmentStop = Just stop, segmentCol = Just [color], segmentFx = Just 0 }
#if __GLASGOW_HASKELL__ <= 906
-- | A total variant of the list index function `(!!)`.
diff --git a/wled-json.cabal b/wled-json.cabal
--- a/wled-json.cabal
+++ b/wled-json.cabal
@@ -5,7 +5,7 @@
-- see: https://github.com/sol/hpack
name: wled-json
-version: 0.0.1.0
+version: 0.0.1.1
synopsis: Convenient interface for interacting with WLED devices
description: Please see the README on GitHub at
category: Interfaces
@@ -13,10 +13,17 @@
bug-reports: https://github.com/alaendle/wled-json/issues
author: Andreas Ländle
maintainer: Andreas Ländle
-copyright: 2024 Andreas Ländle
+copyright: 2024-2025 Andreas Ländle
license: BSD-3-Clause
license-file: LICENSE
build-type: Simple
+tested-with:
+ GHC == 9.2.8
+ , GHC == 9.4.8
+ , GHC == 9.6.6
+ , GHC == 9.8.4
+ , GHC == 9.10.1
+ , GHC == 9.12.1
extra-source-files:
README.md
extra-doc-files:
@@ -37,7 +44,7 @@
Paths_wled_json
hs-source-dirs:
src
- ghc-options: -O0 -Weverything -Wno-unsafe -Wno-missing-import-lists -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-safe
+ ghc-options: -O0 -Weverything -Wno-unsafe -Wno-missing-import-lists -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-safe -Wno-missing-role-annotations
build-depends:
aeson >=2.2.3 && <2.3
, barbies >=2.0.5 && <2.2
@@ -55,7 +62,7 @@
Paths_wled_json
hs-source-dirs:
app
- ghc-options: -O0 -Weverything -Wno-unsafe -Wno-missing-import-lists -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-safe -threaded -rtsopts -with-rtsopts=-N
+ ghc-options: -O0 -Weverything -Wno-unsafe -Wno-missing-import-lists -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-safe -Wno-missing-role-annotations -threaded -rtsopts -with-rtsopts=-N
build-depends:
base >=4.7 && <5
, rhine >=1.4.0.1 && <1.6
@@ -72,7 +79,7 @@
Paths_wled_json
hs-source-dirs:
test
- ghc-options: -O0 -Weverything -Wno-unsafe -Wno-missing-import-lists -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-safe -threaded -rtsopts -with-rtsopts=-N
+ ghc-options: -O0 -Weverything -Wno-unsafe -Wno-missing-import-lists -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-safe -Wno-missing-role-annotations -threaded -rtsopts -with-rtsopts=-N
build-depends:
QuickCheck
, aeson