diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,10 @@ - Awesome upcoming features! +## 0.1.0.0 - Support differently designed lamps - 2025-05-29 + +- Separate lamp specification from WLED interaction - so that own designs could be integrated. + ## 0.0.1.1 - Small cosmetic improvements - 2025-03-28 - Demonstration: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -13,23 +13,14 @@ - **Color:** Set the color of your lights using various color spaces (RGB, HSV, etc.) - **Brightness:** Adjust the overall brightness of your lights -## Installation ⚙️ - -```bash -# Using cabal -cabal add wled-json - -# Using stack -stack add wled-json -``` - ## Usage 📲 ```haskell -import Control.Concurrent -import WLED.Device -import WLED.Octocat.Flags (france) -import WLED.Types +import Control.Concurrent (threadDelay) +import WLED.Device (getLampState, setLampState) +import WLED.Lamp.Octocat (octocatSpec) +import WLED.Pattern.Flags (bulgaria) +import WLED.Types (diff) main :: IO () main = do @@ -38,19 +29,18 @@ case lampState of Left errMsg -> putStrLn errMsg Right initialState -> do - -- Display the French flag on an Octolamp - _ <- setLampState wledUrl france + -- Display the Bulgarian flag on an Octolamp + _ <- setLampState wledUrl (bulgaria octocatSpec) - -- Just sleep one second - threadDelay 1000000 - + -- Just sleep five seconds + threadDelay 5000000 + -- Restore the initial state Right currentState <- getLampState wledUrl _ <- setLampState wledUrl (diff currentState initialState) pure () where wledUrl = "http://192.168.178.34" - ``` ## Features 👍 @@ -59,6 +49,7 @@ - Type-safe interactions - Easy-to-use API - Specific support for Octolamps +- Reusable pattern for other lamp designs ## Contributing 🤝 diff --git a/app-simple/Main.hs b/app-simple/Main.hs new file mode 100644 --- /dev/null +++ b/app-simple/Main.hs @@ -0,0 +1,27 @@ +module Main (main) where + +import Control.Concurrent (threadDelay) +import WLED.Device (getLampState, setLampState) +import WLED.Lamp.Octocat (octocatSpec) +import WLED.Pattern.Flags (bulgaria) +import WLED.Types (diff) + +main :: IO () +main = do + -- Connect to a WLED device + lampState <- getLampState wledUrl + case lampState of + Left errMsg -> putStrLn errMsg + Right initialState -> do + -- Display the Bulgarian flag on an Octolamp + _ <- setLampState wledUrl (bulgaria octocatSpec) + + -- Just sleep five seconds + threadDelay 5000000 + + -- Restore the initial state + Right currentState <- getLampState wledUrl + _ <- setLampState wledUrl (diff currentState initialState) + pure () + where + wledUrl = "http://192.168.178.34" diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -15,7 +15,8 @@ import System.Environment (getArgs) import System.IO (BufferMode (NoBuffering), hSetBuffering, stdout) import WLED.Device -import WLED.Octocat.Flags (belgium, cameroon, chad, france, guatemala, guinea, ireland, italy, ivoryCoast, mali, nigeria, peru) +import WLED.Lamp.Octocat (octocatSpec) +import WLED.Pattern.Flags (belgium, bulgaria, cameroon, chad, france, guatemala, guinea, ireland, italy, ivoryCoast, mali, nigeria, peru) import WLED.Types waitForEnter :: ClSF (ExceptT () IO) StdinClock () () @@ -34,7 +35,7 @@ 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] + allFlags = ($ octocatSpec) <$> [bulgaria, 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 @@ -62,7 +63,7 @@ putStrLn "3: Traverse single LED." putStrLn "q: Quit." putStrLn "" - putStr $ "(" ++ wledUrl ++ ") > " + putStr $ "(" <> wledUrl <> ") > " choice <- getLine case choice of "1" -> do @@ -72,12 +73,12 @@ "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) + 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) + localLampState wledUrl . void . runExceptT . flow $ waitForEnter @@ StdinClock |@| (traverseLed >-> arrMCl (liftIO . void . setLampState wledUrl)) @@ liftClock @IO @(ExceptT ()) (waitClock @100) mainLoop wledUrl "q" -> pure () "Q" -> pure () diff --git a/src/WLED/Device.hs b/src/WLED/Device.hs --- a/src/WLED/Device.hs +++ b/src/WLED/Device.hs @@ -54,4 +54,3 @@ req <- parseRequest wledUrl res <- httpBS $ setRequestBodyJSON patch req { method = "POST", path = "json/state" } pure (toStrict body, getResponseBody res) - diff --git a/src/WLED/Lamp/Octocat.hs b/src/WLED/Lamp/Octocat.hs new file mode 100644 --- /dev/null +++ b/src/WLED/Lamp/Octocat.hs @@ -0,0 +1,113 @@ +module WLED.Lamp.Octocat(octocatSpec) where + +import WLED.LampSpec (LampSpec (..)) + +octocatSpec :: LampSpec Int +octocatSpec = LampSpec { positions = lightPositions, size = (100, 100) } + +-- >>> length lightPositions +-- 101 +lightPositions :: [(Int, Int)] +lightPositions = [ + (51,96), + (54,96), + (61,95), + (70,92), + (77,88), + (82,83), + (88,77), + (92,69), + (94,63), + (96,55), + (95,46), + (94,37), + (91,31), + (88,24), + (82,17), + (77,12), + (71,8), + (64,5), + (57,3), + (48,3), + (41,4), + (33,6), + (25,10), + (19,14), + (14,19), + (9,26), + (5,33), + (4,39), + (3,48), + (3,55), + (5,63), + (8,71), + (13,79), + (17,84), + (23,88), + (30,92), + (37,95), + (45,96), + (46,98), + (41,93), + (33,92), + (25,87), + (19,82), + (13,76), + (8,68), + (6,60), + (4,51), + (5,43), + (8,34), + (11,27), + (17,19), + (23,14), + (30,10), + (38,7), + (45,5), + (55,5), + (63,7), + (71,11), + (78,16), + (84,22), + (88,29), + (91,37), + (93,46), + (93,54), + (91,62), + (88,71), + (83,79), + (77,84), + (71,88), + (63,92), + (56,87), + (57,79), + (56,70), + (60,65), + (66,63), + (71,58), + (73,51), + (72,43), + (68,37), + (69,28), + (65,30), + (56,31), + (49,32), + (42,32), + (33,29), + (29,28), + (30,36), + (26,42), + (25,51), + (28,58), + (33,63), + (40,66), + (42,73), + (36,77), + (28,74), + (23,69), + (24,72), + (28,78), + (34,79), + (42,84), + (41,88) + ] diff --git a/src/WLED/LampSpec.hs b/src/WLED/LampSpec.hs new file mode 100644 --- /dev/null +++ b/src/WLED/LampSpec.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE StandaloneKindSignatures #-} + +{-| +Module : WLED.Device +Copyright : (c) Andreas Ländle, 2024-2025 +License : BSD-3 +Stability : experimental + +Represent the logical model fo the lamp. +-} + +module WLED.LampSpec (LampSpec(..)) where + +import Data.Kind (Type) + +type LampSpec :: Type -> Type +data LampSpec a = LampSpec { positions :: [(a, a)], size :: (a, a) } diff --git a/src/WLED/Octocat/Flags.hs b/src/WLED/Octocat/Flags.hs deleted file mode 100644 --- a/src/WLED/Octocat/Flags.hs +++ /dev/null @@ -1,122 +0,0 @@ - -{-| -Module : WLED.Octocat.Flags -Copyright : (c) Andreas Ländle, 2024-2025 -License : BSD-3 -Stability : experimental - -Octolamp specific feature to display flags. --} - -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 = threeVerticalStripes ral5002 white ral3020 - --- | 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/Pattern/Flags.hs b/src/WLED/Pattern/Flags.hs new file mode 100644 --- /dev/null +++ b/src/WLED/Pattern/Flags.hs @@ -0,0 +1,139 @@ + +{-| +Module : WLED.Pattern.Flags +Copyright : (c) Andreas Ländle, 2024-2025 +License : BSD-3 +Stability : experimental + +Module containing flags. +-} + +module WLED.Pattern.Flags(bulgaria, belgium, cameroon, chad, france, guatemala, guinea, ireland, italy, ivoryCoast, mali, nigeria, peru) where + +import Data.List (group) +import WLED.LampSpec (LampSpec (LampSpec)) +import WLED.Types (State (stateSeg), StatePatch, segment) + +-- | The Belgian flag. +belgium :: Real a => LampSpec a -> StatePatch +belgium = threeVerticalStripes ral9017 ral2007 ral3028 + +-- | The Cameroonian flag. +cameroon :: Real a => LampSpec a -> StatePatch +cameroon = threeVerticalStripes ral6024 ral3028 ral1018 + +-- | The Chad flag. +chad :: Real a => LampSpec a -> StatePatch +chad = threeVerticalStripes ral5026 ral2007 ral3028 + +-- | The French flag. +france :: Real a => LampSpec a -> StatePatch +france = threeVerticalStripes ral5002 white ral3020 + +-- | The Guatemalan flag. +guatemala :: Real a => LampSpec a -> StatePatch +guatemala = threeVerticalStripes ral5012 white ral5012 + +-- | The Guinean flag. +guinea :: Real a => LampSpec a -> StatePatch +guinea = threeVerticalStripes ral3028 ral1018 ral6024 + +-- | The Irish flag. +ireland :: Real a => LampSpec a -> StatePatch +ireland = threeVerticalStripes ral6024 white ral1028 + +-- | The Italian flag. +italy :: Real a => LampSpec a -> StatePatch +italy = threeVerticalStripes ral6024 ral9016 ral3028 + +-- | The Ivory Coast flag. +ivoryCoast :: Real a => LampSpec a -> StatePatch +ivoryCoast = threeVerticalStripes ral1028 white ral6024 + +-- | The Malian flag. +mali :: Real a => LampSpec a -> StatePatch +mali = threeVerticalStripes ral6038 ral1018 ral3028 + +-- | The Nigerian flag. +nigeria :: Real a => LampSpec a -> StatePatch +nigeria = threeVerticalStripes ral6001 white ral6001 + +-- | The Peruvian flag. +peru :: Real a => LampSpec a -> StatePatch +peru = threeVerticalStripes ral3028 white ral3028 + +-- | The Bulgarian flag. +bulgaria :: Real a => LampSpec a -> StatePatch +bulgaria = threeHorizontalStripes white ral5021 ral3028 + +threeVerticalStripes :: Real a => [Int] -> [Int] -> [Int] -> LampSpec a -> StatePatch +threeVerticalStripes leftColor middleColor rightColor lampSpec = (mempty :: StatePatch) { stateSeg = segments } where + segments = Just $ (\(start, stop, index) -> segment start stop ([leftColor, middleColor, rightColor] !! index)) <$> buildSegments (verticalLayer lampSpec 3) + +threeHorizontalStripes :: Real a => [Int] -> [Int] -> [Int] -> LampSpec a -> StatePatch +threeHorizontalStripes topColor middleColor buttomColor lampSpec = (mempty :: StatePatch) { stateSeg = segments } where + segments = Just $ (\(start, stop, index) -> segment start stop ([topColor, middleColor, buttomColor] !! index)) <$> buildSegments (horizontalLayer lampSpec 3) + +-- >>> length <$> (group $ horizontalLayer (LampSpec lightPositions (100,100)) 3) +-- [8,4,15,4,14,4,12,4,8,6,7,6,9] +horizontalLayer :: Real a => LampSpec a -> Int -> [Int] +horizontalLayer (LampSpec pos (_, sy)) n = fmap (\(_, y) -> floor (toRational y / toRational sy * toRational n)) pos + +-- >>> length <$> (group $ verticalLayer (LampSpec lightPositions (100,100)) 3) +-- [3,14,4,15,4,13,4,12,6,5,4,7,3,4,3] +verticalLayer :: Real a => LampSpec a -> Int -> [Int] +verticalLayer (LampSpec pos (sx, _)) n = fmap (\(x, _) -> floor (toRational x / toRational sx * toRational n)) pos + +-- >>> buildSegments $ verticalLayer (LampSpec lightPositions (100,100)) 3 +-- [(0,3,1),(3,17,2),(17,21,1),(21,36,0),(36,40,1),(40,53,0),(53,57,1),(57,69,2),(69,75,1),(75,80,2),(80,84,1),(84,91,0),(91,94,1),(94,98,0),(98,101,1)] +buildSegments :: [Int] -> [(Int, Int, Int)] +buildSegments = step 0 . group where + step :: Int -> [[Int]] -> [(Int, Int, Int)] + step n (xs@(x:_):r) = (n, n + length xs, x) : step (n + length xs) r + step _ _ = [] + + +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] + +ral5021 :: [Int] +ral5021 = [0, 150, 110] + +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 @@ -215,7 +215,7 @@ d' :: (AllB Eq (b Covered), Eq (b Bare Identity), Monoid (b Covered Maybe), ConstraintsB (b Covered), ApplicativeB (b Covered), BareB b) => b Bare Identity -> b Bare Identity -> Maybe (b Covered Maybe) 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 }) + 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 } diff --git a/wled-json.cabal b/wled-json.cabal --- a/wled-json.cabal +++ b/wled-json.cabal @@ -1,11 +1,11 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.37.0. +-- This file has been generated from package.yaml by hpack version 0.38.0. -- -- see: https://github.com/sol/hpack name: wled-json -version: 0.0.1.1 +version: 0.1.0.0 synopsis: Convenient interface for interacting with WLED devices description: Please see the README on GitHub at category: Interfaces @@ -20,10 +20,10 @@ tested-with: GHC == 9.2.8 , GHC == 9.4.8 - , GHC == 9.6.6 + , GHC == 9.6.7 , GHC == 9.8.4 - , GHC == 9.10.1 - , GHC == 9.12.1 + , GHC == 9.10.2 + , GHC == 9.12.2 extra-source-files: README.md extra-doc-files: @@ -36,7 +36,9 @@ library exposed-modules: WLED.Device - WLED.Octocat.Flags + WLED.Lamp.Octocat + WLED.LampSpec + WLED.Pattern.Flags WLED.Types other-modules: Paths_wled_json @@ -54,7 +56,7 @@ , http-conduit >=2.3.9.1 && <2.4 default-language: Haskell2010 -executable wled-json-exe +executable wled-json-demo main-is: Main.hs other-modules: Paths_wled_json @@ -66,6 +68,20 @@ build-depends: base >=4.7 && <5 , rhine >=1.4.0.1 && <1.6 + , wled-json + default-language: Haskell2010 + +executable wled-json-simple + main-is: Main.hs + other-modules: + Paths_wled_json + autogen-modules: + Paths_wled_json + hs-source-dirs: + app-simple + 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 , wled-json default-language: Haskell2010