blucontrol 0.2.1.1 → 0.3.0.0

raw patch · 11 files changed

+112/−85 lines, 11 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• Main.hs +8/−5
• blucontrol.cabal +1/−1
• src/Blucontrol.hs +3/−5
• src/Blucontrol/Control.hs +1/−1
• src/Blucontrol/Control/Wait.hs +1/−1
• src/Blucontrol/Gamma/Const.hs +6/−6
• src/Blucontrol/Gamma/Linear.hs +44/−31
• src/Blucontrol/RGB.hs +9/−1
• src/Blucontrol/RGB/Temperature.hs +22/−24
• test/Blucontrol/Test/Gamma/Linear.hs +11/−10

@@ -1,5 +1,11 @@ # Revision history for blucontrol +## 0.3.0.0 *18 Apr 2021*++* Add `RGB` class.+* Remove `temperature` conversion function in favor of `toRGB`.+* `GammaLinearT` now interpolates between `Temperature`s instead of `Trichromaticity`s.+ ## 0.2.1.1 *12 Aug 2020*  * Improve miscallenous documentation.

@@ -1,3 +1,5 @@+{-# LANGUAGE TypeApplications #-}+ module Main where  import Blucontrol@@ -6,15 +8,16 @@ import Blucontrol.Control.Wait import Blucontrol.Gamma.Linear import Blucontrol.Recolor.X+import Blucontrol.RGB.Temperature  main :: IO () main = blucontrol configControl   where configControl = ConfigControl { runControl = runControlPrintT !> runControlCountT def !> runControlWaitT def-                                      , runGamma = runGammaLinearT rgbMap+                                      , runGamma = runGammaLinearT @Temperature rgbMap                                       , runRecolor = runRecolorXTIO def                                       }-        rgbMap = 00:.00 ==> temperature 4000-            :| [ 08:.00 ==> temperature 4600-               , 12:.00 ==> temperature 6600-               , 18:.00 ==> temperature 6000+        rgbMap = 00:.00 ==> 4000+            :| [ 08:.00 ==> 4600+               , 12:.00 ==> 6600+               , 18:.00 ==> 6000                ]

@@ -1,5 +1,5 @@ name:                blucontrol-version:             0.2.1.1+version:             0.3.0.0 synopsis:            Configurable blue light filter description:         This application is a blue light filter, with the main focus on                      configurability.

@@ -14,11 +14,10 @@ -- | RGB values are represented by 'Trichromaticity'. , Trichromaticity (..) -{- | An alternative way to declaring 'Trichromaticity' directly is to use 'Temperature' and the-  conversion function 'temperature'.+{- | An alternative way, which avoids declaring 'Trichromaticity' directly, uses the 'RGB' type+    class. -}-, Temperature-, temperature+, RGB (..)  -- * Control -- | Modules with instances of 'MonadControl' can be found under @Blucontrol.Control.*@.@@ -50,4 +49,3 @@ import Blucontrol.Main import Blucontrol.Recolor import Blucontrol.RGB-import Blucontrol.RGB.Temperature

@@ -21,5 +21,5 @@               -> m () -- ^ the side effect to be run inbetween recoloring  instance MonadControl IO where-  type ControlConstraint IO a = ()+  type ControlConstraint IO _ = ()   doInbetween _ = return ()

@@ -21,7 +21,7 @@   deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b, MonadTrans, MonadTransControl)  instance MonadBaseControl IO m => MonadControl (ControlWaitT m) where-  type ControlConstraint (ControlWaitT m) a = ()+  type ControlConstraint (ControlWaitT m) _ = ()   doInbetween _ = liftBase . threadDelay . interval =<< ControlWaitT ask  runControlWaitT :: ConfigWait -> ControlWaitT m a -> m a

@@ -13,16 +13,16 @@ import Blucontrol.Gamma import Blucontrol.RGB -newtype GammaConstT m a = GammaConstT { unGammaConstT :: ReaderT Trichromaticity m a }+newtype GammaConstT c m a = GammaConstT { unGammaConstT :: ReaderT c m a }   deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b, MonadTrans, MonadTransControl) -instance Monad m => MonadGamma (GammaConstT m) where-  gamma = GammaConstT ask--instance MonadReader r m => MonadReader r (GammaConstT m) where+instance MonadReader r m => MonadReader r (GammaConstT c m) where   ask = lift ask   local f tma = liftWith $ \ run ->     local f $ run tma -runGammaConstT :: Trichromaticity -> GammaConstT m a -> m a+instance (Monad m, RGB c) => MonadGamma (GammaConstT c m) where+  gamma = toRGB <$> GammaConstT ask++runGammaConstT :: RGB c => c -> GammaConstT c m a -> m a runGammaConstT rgb tma = runReaderT (unGammaConstT tma) rgb

@@ -8,7 +8,8 @@ , Minute , (==>) , N.NonEmpty (..) -- TODO: keep here?-, calculateGamma -- TODO: export for testing+, calculateRGB -- TODO: export for testing+, weightedAverageTrichromaticity -- TODO: export for testing ) where  import Control.DeepSeq@@ -25,26 +26,25 @@  import Blucontrol.Gamma import Blucontrol.RGB+import Blucontrol.RGB.Temperature -newtype GammaLinearT m a = GammaLinearT { unGammaLinearT :: ReaderT (M.Map TimeOfDay Trichromaticity) m a }+newtype GammaLinearT c m a = GammaLinearT { unGammaLinearT :: ReaderT (M.Map TimeOfDay c) m a }   deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b, MonadTrans, MonadTransControl) -instance MonadBase IO m => MonadGamma (GammaLinearT m) where-  gamma = calculateGamma . zonedTimeToLocalTime =<< liftBase getZonedTime+instance MonadReader r m => MonadReader r (GammaLinearT c m) where+  ask = lift ask+  local f tma = liftWith $ \ run ->+    local f $ run tma -calculateGamma :: Monad m => LocalTime -> GammaLinearT m Trichromaticity-calculateGamma time = do-  m <- GammaLinearT ask-  return . fromJust $ do-    (nextTime , nextGamma) <- nextTimeGamma m time-    (prevTime , prevGamma) <- prevTimeGamma m time-    let diffSeconds t1 t2 = nominalDiffTimeToSeconds $ t1 `diffLocalTime` t2-        timeFraction = toRational $ (time `diffSeconds` prevTime) / (nextTime `diffSeconds` prevTime)-    return $ weightedAverage timeFraction prevGamma nextGamma+instance MonadBase IO m => MonadGamma (GammaLinearT Trichromaticity m) where+  gamma = calculateRGB weightedAverageTrichromaticity . zonedTimeToLocalTime =<< liftBase getZonedTime -nextTimeGamma :: M.Map TimeOfDay Trichromaticity -> LocalTime -> Maybe (LocalTime,Trichromaticity)-nextTimeGamma m time = catchError (toLocalTimeToday <$> M.lookupGT (localTimeOfDay time) m) $-                         const (toLocalTimeTomorrow <$> M.lookupMin m)+instance MonadBase IO m => MonadGamma (GammaLinearT Temperature m) where+  gamma = fmap toRGB $ calculateRGB weightedAverageTemperature . zonedTimeToLocalTime =<< liftBase getZonedTime++nextTimeRGB :: M.Map TimeOfDay c -> LocalTime -> Maybe (LocalTime,c)+nextTimeRGB m time = catchError (toLocalTimeToday <$> M.lookupGT (localTimeOfDay time) m) $+                     const (toLocalTimeTomorrow <$> M.lookupMin m)   where toLocalTimeToday (tod,tc) = let t = LocalTime { localDay = localDay time                                                       , localTimeOfDay = tod                                                       }@@ -53,9 +53,9 @@                                     t' = t { localDay = succ $ localDay t }                                  in (t',tc) -prevTimeGamma :: M.Map TimeOfDay Trichromaticity -> LocalTime -> Maybe (LocalTime,Trichromaticity)-prevTimeGamma m time = catchError (toLocalTimeToday <$> M.lookupLE (localTimeOfDay time) m) $-                         const (toLocalTimeYesterday <$> M.lookupMax m)+prevTimeRGB :: M.Map TimeOfDay c -> LocalTime -> Maybe (LocalTime,c)+prevTimeRGB m time = catchError (toLocalTimeToday <$> M.lookupLE (localTimeOfDay time) m) $+                     const (toLocalTimeYesterday <$> M.lookupMax m)   where toLocalTimeToday (tod,tc) = let t = LocalTime { localDay = localDay time                                                       , localTimeOfDay = tod                                                       }@@ -64,22 +64,34 @@                                      t' = t { localDay = pred $ localDay t }                                   in (t',tc) -weightedAverage :: Rational -> Trichromaticity -> Trichromaticity -> Trichromaticity-weightedAverage w tc1 tc2 = Trichromaticity { red = f (red tc1) (red tc2)-                                            , green = f (green tc1) (green tc2)-                                            , blue = f (blue tc1) (blue tc2)-                                            }+calculateRGB :: Monad m+             => (Rational -> c -> c -> c)+             -> LocalTime -> GammaLinearT c m c+calculateRGB weightedAverage time = do+  m <- GammaLinearT ask+  return . fromJust $ do+    (nextTime , nextRGB) <- nextTimeRGB m time+    (prevTime , prevRGB) <- prevTimeRGB m time+    let diffSeconds t1 t2 = nominalDiffTimeToSeconds $ t1 `diffLocalTime` t2+        timeFraction = toRational $ (time `diffSeconds` prevTime) / (nextTime `diffSeconds` prevTime)+    return $ weightedAverage timeFraction prevRGB nextRGB++weightedAverageTrichromaticity :: Rational -> Trichromaticity -> Trichromaticity -> Trichromaticity+weightedAverageTrichromaticity w tc1 tc2 = Trichromaticity { red = f (red tc1) (red tc2)+                                                           , green = f (green tc1) (green tc2)+                                                           , blue = f (blue tc1) (blue tc2)+                                                           }   where f c1 c2 = round $ fromIntegral c1 + w * (fromIntegral c2 - fromIntegral c1) -instance MonadReader r m => MonadReader r (GammaLinearT m) where-  ask = lift ask-  local f tma = liftWith $ \ run ->-    local f $ run tma+weightedAverageTemperature :: Rational -> Temperature -> Temperature -> Temperature+weightedAverageTemperature w t1 t2 = fromRational $ toRational t1 + w * (toRational t2 - toRational t1) -runGammaLinearT' :: M.Map TimeOfDay Trichromaticity -> GammaLinearT m a -> m a+-- TODO: maybe remove RGB constraint+runGammaLinearT' :: RGB c => M.Map TimeOfDay c -> GammaLinearT c m a -> m a runGammaLinearT' rgbs tma = runReaderT (unGammaLinearT tma) rgbs -runGammaLinearT :: N.NonEmpty (TimeOfDay,Trichromaticity) -> GammaLinearT m a -> m a+-- TODO: maybe remove RGB constraint+runGammaLinearT :: RGB c => N.NonEmpty (TimeOfDay,c) -> GammaLinearT c m a -> m a runGammaLinearT rgbs = runGammaLinearT' $ M.fromList . N.toList $ rgbs  newtype Hour = Hour { unHour :: F.Finite 24 }@@ -103,8 +115,9 @@   toEnum i = let (h , m) = i `divMod` succ (fromEnum $ maxBound @Minute)               in toEnum h :. toEnum m +-- TODO: maybe remove RGB constraint infix 6 ==>-(==>) :: Time -> Trichromaticity -> (TimeOfDay,Trichromaticity)+(==>) :: RGB c => Time -> c -> (TimeOfDay,c) (==>) (h :. m) c = (time,c)   where time = TimeOfDay { todHour = fromIntegral h                          , todMin = fromIntegral m

@@ -1,5 +1,6 @@ module Blucontrol.RGB (-  Chromaticity+  RGB (..)+, Chromaticity , Trichromaticity (..) ) where @@ -8,6 +9,10 @@ import Data.Word import GHC.Generics +-- | convertible to 8-bit RGB values+class RGB c where+  toRGB :: c -> Trichromaticity+ -- | 8-bit value for color channel intensity newtype Chromaticity = Chromaticity Word8   deriving (Bounded, Enum, Eq, Generic, Integral, Num, Ord, Read, Real, Show)@@ -45,3 +50,6 @@                         , green = def                         , blue = def                         }++instance RGB Trichromaticity where+  toRGB = id

@@ -2,7 +2,6 @@  module Blucontrol.RGB.Temperature (   Temperature-, temperature ) where  import Control.DeepSeq@@ -24,26 +23,25 @@ instance Default Temperature where   def = 6600 --- TODO: test and implement more accurate, currently based on blugon--- | Calculate a 'Trichromaticity' from a 'Temperature'.-temperature :: Temperature -> Trichromaticity-temperature (Temperature temp) = Trichromaticity {..}-  where red = round . inBounds $-          if t <= 66-             then 255-             else 329.698727446 * ((t - 60) ** (-0.1332047592))-        green = round . inBounds $-          if t <= 66-             then 99.4708025861 * log t - 161.1195681661-             else 288.1221695283 * ((t - 60) ** (-0.0755148492))-        blue = round . inBounds $-          if t <= 0-             then 0-             else if t >= 66-                     then 255-                     else 138.5177312231 * log (t - 10) - 305.0447927307-        t = fromRational $ temp / 100 :: Double-        inBounds x-          | x < 0 = 0-          | x > 255 = 255-          | otherwise = x+instance RGB Temperature where+  -- TODO: test and implement more accurate, currently based on blugon+  toRGB (Temperature temp) = Trichromaticity {..}+    where red = round . inBounds $+            if t <= 66+               then 255+               else 329.698727446 * ((t - 60) ** (-0.1332047592))+          green = round . inBounds $+            if t <= 66+               then 99.4708025861 * log t - 161.1195681661+               else 288.1221695283 * ((t - 60) ** (-0.0755148492))+          blue = round . inBounds $+            if t <= 0+               then 0+               else if t >= 66+                       then 255+                       else 138.5177312231 * log (t - 10) - 305.0447927307+          t = fromRational $ temp / 100 :: Double+          inBounds x+            | x < 0 = 0+            | x > 255 = 255+            | otherwise = x

@@ -22,8 +22,9 @@   it "convert Time to TimeOfDay" $     property prop_timeToTimeOfDay -  it "calculateGamma between surrounding values" $-    property prop_calculateGamma+  -- TODO: this tests `calculateRGB weightedAverageTrichromaticity`+  it "calculateTrichromaticity between surrounding values" $+    property prop_calculateTrichromaticity  newtype Arbitrary_Time = Arbitrary_Time Time   deriving (Bounded, Enum, Eq, Generic, Ord, Read, Show)@@ -40,19 +41,19 @@   , 0 == todSec   ]   where h :. m = time-        TimeOfDay {..} = fst $ time Blucontrol.Gamma.Linear.==> undefined+        TimeOfDay {..} = fst $ time Blucontrol.Gamma.Linear.==> (undefined :: Trichromaticity) -prop_calculateGamma :: Arbitrary_Time-                    -> (Arbitrary_Time,Arbitrary_Trichromaticity)-                    -> (Arbitrary_Time,Arbitrary_Trichromaticity)-                    -> Bool-prop_calculateGamma (Arbitrary_Time time) (Arbitrary_Time xt , Arbitrary_Trichromaticity xtc) (Arbitrary_Time yt , Arbitrary_Trichromaticity ytc) =+prop_calculateTrichromaticity :: Arbitrary_Time+                              -> (Arbitrary_Time,Arbitrary_Trichromaticity)+                              -> (Arbitrary_Time,Arbitrary_Trichromaticity)+                              -> Bool+prop_calculateTrichromaticity (Arbitrary_Time time) (Arbitrary_Time xt , Arbitrary_Trichromaticity xtc) (Arbitrary_Time yt , Arbitrary_Trichromaticity ytc) =   rgb `prop_TrichromaticityBetween` (xtc , ytc)-  where rgb = runIdentity . runGammaLinearT rgbMap $ calculateGamma tod+  where rgb = runIdentity . runGammaLinearT rgbMap $ calculateRGB weightedAverageTrichromaticity tod         rgbMap = xt Blucontrol.Gamma.Linear.==> xtc             :| [ yt Blucontrol.Gamma.Linear.==> ytc                ]-        tod = LocalTime (ModifiedJulianDay 0) . fst $ time Blucontrol.Gamma.Linear.==> undefined+        tod = LocalTime (ModifiedJulianDay 0) . fst $ time Blucontrol.Gamma.Linear.==> (undefined :: Trichromaticity)  prop_TrichromaticityBetween :: Trichromaticity -> (Trichromaticity,Trichromaticity) -> Bool prop_TrichromaticityBetween x (a,b) = and