blucontrol 0.3.2.0 → 0.4.0.0

raw patch · 18 files changed

+215/−222 lines, 18 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +11/−0
• Main.hs +2/−0
• blucontrol.cabal +1/−1
• src/Blucontrol.hs +1/−10
• src/Blucontrol/Gamma.hs +4/−4
• src/Blucontrol/Gamma/Const.hs +3/−3
• src/Blucontrol/Gamma/Linear.hs +39/−40
• src/Blucontrol/Gamma/Modifier.hs +8/−8
• src/Blucontrol/Main.hs +18/−2
• src/Blucontrol/Main/Control.hs +15/−19
• src/Blucontrol/RGB.hs +35/−39
• src/Blucontrol/RGB/Brightness.hs +6/−17
• src/Blucontrol/RGB/Temperature.hs +24/−22
• src/Blucontrol/Recolor.hs +7/−4
• src/Blucontrol/Recolor/Print.hs +7/−6
• src/Blucontrol/Recolor/X.hs +6/−9
• test/Blucontrol/Test/Gamma/Linear.hs +21/−20
• test/Blucontrol/Test/RGB.hs +7/−18

@@ -1,5 +1,16 @@ # Revision history for blucontrol +## 0.4.0.0 *06 Jun 2021*++* Remove `RGB` class.+* Remove `Chromaticity`.+* Replace `Trichromaticity` by `RGB`.+* Add type families `GammaValue` and `RecolorValue` to `MonadGamma` and `MonadRecolor`.+* Add `coerceValue` to `ConfigControl`.+* `RecolorXT` now uses `RGB Float` instead of `Trichromaticity`.+* `Temperature` is now explicitly convertible to `RGB Word8` using `toRGBWord8`.+* Rename parametric field of `WithBrightness` record from `rgb` to `color`.+ ## 0.3.2.0 *04 Jun 2021*  * New module `Blucontrol.RGB.Brightness`.

@@ -8,6 +8,7 @@ import Blucontrol.Control.Wait import Blucontrol.Gamma.Linear import Blucontrol.Recolor.X+import Blucontrol.RGB import Blucontrol.RGB.Temperature  main :: IO ()@@ -15,6 +16,7 @@   where configControl = ConfigControl { runControl = runControlPrintT !> runControlCountT def !> runControlWaitT def                                       , runGamma = runGammaLinearT @Temperature rgbMap                                       , runRecolor = runRecolorXTIO def+                                      , coerceValue = mapRGB word8ToFloat . toRGBWord8                                       }         rgbMap = 00:.00 ==> 4000             :| [ 08:.00 ==> 4600

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

@@ -5,20 +5,12 @@    @$XDG_CONFIG_HOME\/blucontrol\/blucontrol.hs@ -}   blucontrol+, BlucontrolConstraints {- | 'ConfigControl' will set the monads in which recoloring and calculation of the gamma values   will take place. -} , ConfigControl (..) --- * RGB--- | RGB values are represented by 'Trichromaticity'.-, Trichromaticity (..)--{- | An alternative way, which avoids declaring 'Trichromaticity' directly, uses the 'RGB' type-    class.--}-, RGB (..)- -- * Control -- | Modules with instances of 'MonadControl' can be found under @Blucontrol.Control.*@. , MonadControl (..)@@ -48,4 +40,3 @@ import Blucontrol.Gamma import Blucontrol.Main import Blucontrol.Recolor-import Blucontrol.RGB

@@ -2,12 +2,12 @@   MonadGamma (..) ) where -import Blucontrol.RGB+class Monad m => MonadGamma m where -class (Monad m, RGB c) => MonadGamma c m | m -> c where+  type GammaValue m -  {- | Calculate an 'RGB' value.+  {- | Calculate a gamma value.      This is a monadic function, to allow the value to be dependent on side effects like time and      location.   -}-  gamma :: m c+  gamma :: m (GammaValue m)

@@ -11,7 +11,6 @@ import Control.Monad.Reader  import Blucontrol.Gamma-import Blucontrol.RGB  newtype GammaConstT c m a = GammaConstT { unGammaConstT :: ReaderT c m a }   deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b, MonadTrans, MonadTransControl)@@ -21,8 +20,9 @@   local f tma = liftWith $ \ run ->     local f $ run tma -instance (Monad m, RGB c) => MonadGamma c (GammaConstT c m) where+instance Monad m => MonadGamma (GammaConstT c m) where+  type GammaValue (GammaConstT c m) = c   gamma = GammaConstT ask -runGammaConstT :: RGB c => c -> GammaConstT c m a -> m a+runGammaConstT :: c -> GammaConstT c m a -> m a runGammaConstT !rgb tma = runReaderT (unGammaConstT tma) rgb

@@ -8,8 +8,8 @@ , Minute , (==>) , N.NonEmpty (..) -- TODO: keep here?-, calculateRGB -- TODO: export for testing-, weightedAverageTrichromaticity -- TODO: export for testing+, calculateValue -- TODO: export for testing+, weightedAverageRGB -- TODO: export for testing ) where  import Control.DeepSeq@@ -22,6 +22,7 @@ import qualified Data.Map as M import Data.Maybe (fromJust) import Data.Time+import Data.Word import GHC.Generics  import Blucontrol.Gamma@@ -37,28 +38,29 @@   local f tma = liftWith $ \ run ->     local f $ run tma -instance MonadBase IO m => MonadGamma Trichromaticity (GammaLinearT Trichromaticity m) where-  gamma = calculateRGB weightedAverageTrichromaticity . zonedTimeToLocalTime =<< liftBase getZonedTime+instance MonadBase IO m => MonadGamma (GammaLinearT (RGB Word8) m) where+  type GammaValue (GammaLinearT (RGB Word8) m) = RGB Word8+  gamma = calculateValue weightedAverageRGB . zonedTimeToLocalTime =<< liftBase getZonedTime -instance MonadBase IO m => MonadGamma Temperature (GammaLinearT Temperature m) where-  gamma = calculateRGB weightedAverageTemperature . zonedTimeToLocalTime =<< liftBase getZonedTime+instance MonadBase IO m => MonadGamma (GammaLinearT Temperature m) where+  type GammaValue (GammaLinearT Temperature m) = Temperature+  gamma = calculateValue weightedAverageTemperature . zonedTimeToLocalTime =<< liftBase getZonedTime -instance (RGB Trichromaticity, MonadBase IO m) => MonadGamma (WithBrightness Trichromaticity) (GammaLinearT (WithBrightness Trichromaticity) m) where-  gamma = calculateRGB weightedAverage . zonedTimeToLocalTime =<< liftBase getZonedTime-    where weightedAverage w WithBrightness { brightness = b1, rgb = tc1 } WithBrightness { brightness = b2, rgb = tc2 } =-            WithBrightness { brightness = weightedAverageBrightness w b1 b2-                           , rgb = weightedAverageTrichromaticity w tc1 tc2-                           }+instance (MonadBase IO m, MonadGamma (GammaLinearT c m)) => MonadGamma (GammaLinearT (WithBrightness c) m) where+  type GammaValue (GammaLinearT (WithBrightness c) m) = WithBrightness (GammaValue (GammaLinearT c m))+  -- TODO: It would be nice to use the same exact time for `color'` and `brightness'`.+  gamma = do+    color' <- withGammaLinearT color gamma+    brightness' <- withGammaLinearT brightness $ calculateValue weightedAverageBrightness . zonedTimeToLocalTime =<< liftBase getZonedTime+    return WithBrightness { brightness = brightness'+                          , color = color'+                          } -instance (RGB Temperature, MonadBase IO m) => MonadGamma (WithBrightness Temperature) (GammaLinearT (WithBrightness Temperature) m) where-  gamma = calculateRGB weightedAverage . zonedTimeToLocalTime =<< liftBase getZonedTime-    where weightedAverage w WithBrightness { brightness = b1, rgb = tc1 } WithBrightness { brightness = b2, rgb = tc2 } =-            WithBrightness { brightness = weightedAverageBrightness w b1 b2-                           , rgb = weightedAverageTemperature w tc1 tc2-                           }+withGammaLinearT :: (c' -> c) -> GammaLinearT c m a -> GammaLinearT c' m a+withGammaLinearT f m = GammaLinearT $ withReaderT (fmap f) $ unGammaLinearT m -nextTimeRGB :: M.Map TimeOfDay c -> LocalTime -> Maybe (LocalTime,c)-nextTimeRGB m time = catchError (toLocalTimeToday <$> M.lookupGT (localTimeOfDay time) m) $+nextTimeValue :: M.Map TimeOfDay c -> LocalTime -> Maybe (LocalTime,c)+nextTimeValue 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@@ -68,8 +70,8 @@                                     t' = t { localDay = succ $ localDay t }                                  in (t',tc) -prevTimeRGB :: M.Map TimeOfDay c -> LocalTime -> Maybe (LocalTime,c)-prevTimeRGB m time = catchError (toLocalTimeToday <$> M.lookupLE (localTimeOfDay time) m) $+prevTimeValue :: M.Map TimeOfDay c -> LocalTime -> Maybe (LocalTime,c)+prevTimeValue 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@@ -79,23 +81,23 @@                                      t' = t { localDay = pred $ localDay t }                                   in (t',tc) -calculateRGB :: Monad m-             => (Rational -> c -> c -> c)-             -> LocalTime -> GammaLinearT c m c-calculateRGB weightedAverage time = do+calculateValue :: Monad m+               => (Rational -> c -> c -> c)+               -> LocalTime -> GammaLinearT c m c+calculateValue weightedAverage time = do   m <- GammaLinearT ask   return . fromJust $ do-    (nextTime , nextRGB) <- nextTimeRGB m time-    (prevTime , prevRGB) <- prevTimeRGB m time+    (nextTime , nextValue) <- nextTimeValue m time+    (prevTime , prevValue) <- prevTimeValue m time     let diffSeconds t1 t2 = nominalDiffTimeToSeconds $ t1 `diffLocalTime` t2         timeFraction = toRational $ (time `diffSeconds` prevTime) / (nextTime `diffSeconds` prevTime)-    return $ weightedAverage timeFraction prevRGB nextRGB+    return $ weightedAverage timeFraction prevValue nextValue -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)-                                                           }+weightedAverageRGB :: Rational -> RGB Word8 -> RGB Word8 -> RGB Word8+weightedAverageRGB w rgb1 rgb2 = RGB { red = f (red rgb1) (red rgb2)+                                     , green = f (green rgb1) (green rgb2)+                                     , blue = f (blue rgb1) (blue rgb2)+                                     }   where f c1 c2 = round $ fromIntegral c1 + w * (fromIntegral c2 - fromIntegral c1)  weightedAverageTemperature :: Rational -> Temperature -> Temperature -> Temperature@@ -104,12 +106,10 @@ weightedAverageBrightness :: Rational -> Brightness -> Brightness -> Brightness weightedAverageBrightness w b1 b2 = fromRational $ toRational b1 + w * (toRational b2 - toRational b1) --- TODO: maybe remove RGB constraint-runGammaLinearT' :: RGB c => M.Map TimeOfDay c -> GammaLinearT c m a -> m a+runGammaLinearT' :: M.Map TimeOfDay c -> GammaLinearT c m a -> m a runGammaLinearT' !rgbs tma = runReaderT (unGammaLinearT tma) rgbs --- TODO: maybe remove RGB constraint-runGammaLinearT :: RGB c => N.NonEmpty (TimeOfDay,c) -> GammaLinearT c m a -> m a+runGammaLinearT :: 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 }@@ -133,9 +133,8 @@   toEnum i = let (h , m) = i `divMod` succ (fromEnum $ maxBound @Minute)               in toEnum h :. toEnum m --- TODO: maybe remove RGB constraint infix 6 ==>-(==>) :: RGB c => Time -> c -> (TimeOfDay,c)+(==>) :: Time -> c -> (TimeOfDay,c) (==>) (h :. m) c = (time,c)   where time = TimeOfDay { todHour = fromIntegral h                          , todMin = fromIntegral m

@@ -12,18 +12,18 @@  import Blucontrol.Gamma -newtype GammaModifierT c m a = GammaModifierT { unGammaModifierT :: ReaderT (c -> IO c) m a }-  deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b, MonadTrans, MonadTransControl)+newtype GammaModifierT m a = GammaModifierT { unGammaModifierT :: ReaderT (GammaValue m -> IO (GammaValue m)) m a }+  deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b)+-- TODO: A `MonadTransControl` instance seems to be impossible -instance MonadReader r m => MonadReader r (GammaModifierT c m) where-  ask = lift ask-  local f tma = liftWith $ \ run ->-    local f $ run tma+instance MonadTrans GammaModifierT where+  lift = GammaModifierT . lift -instance (MonadBase IO m, MonadGamma c m) => MonadGamma c (GammaModifierT c m) where+instance (MonadBase IO m, MonadGamma m) => MonadGamma (GammaModifierT m) where+  type GammaValue (GammaModifierT m) = GammaValue m   gamma = do oldGamma <- lift gamma              modifyGamma <- GammaModifierT ask              liftBase $ modifyGamma oldGamma -runGammaModifierT :: (c -> IO c) -> GammaModifierT c m a -> m a+runGammaModifierT :: (GammaValue m -> IO (GammaValue m)) -> GammaModifierT m a -> m a runGammaModifierT modify tma = runReaderT (unGammaModifierT tma) modify

@@ -1,5 +1,6 @@ module Blucontrol.Main (   blucontrol+, BlucontrolConstraints , ConfigControl (..) ) where @@ -11,8 +12,23 @@ import Blucontrol.Gamma import Blucontrol.Recolor -blucontrol :: (ControlConstraint m (StM g (StM r ())), MonadControl m, MonadBaseControl IO g, MonadBaseControl IO r, MonadGamma c g, MonadRecolor r)+type BlucontrolConstraints m g r =+  ( ControlConstraint m (StM g (StM r ()))+  , MonadControl m+  , MonadBaseControl IO g+  , MonadBaseControl IO r+  , MonadGamma g+  , MonadRecolor r+  )++blucontrol :: BlucontrolConstraints m g r            => ConfigControl m g r            -> IO () blucontrol c = do launch-                  runControl c $ loopRecolor (runGamma c) (runRecolor c)+                  runControl c $ loopRecolor (runGamma c) (runRecolor c) (coerceValue c)++data ConfigControl m g r = ConfigControl { runControl :: forall a. m a -> IO a+                                         , runGamma   :: forall a. g a -> IO (StM g a)+                                         , runRecolor :: forall a. r a -> IO (StM r a)+                                         , coerceValue :: GammaValue g -> RecolorValue r+                                         }

@@ -1,6 +1,5 @@ module Blucontrol.Main.Control (   loopRecolor-, ConfigControl (..) ) where  import Control.Monad.Base@@ -11,46 +10,43 @@ import Blucontrol.Control import Blucontrol.Gamma import Blucontrol.Recolor-import Blucontrol.RGB  -- | Run the loop, using `gamma`, `recolor` and `doInbetween`. -- The arguments are the actual monad runners.-loopRecolor :: (ControlConstraint m (StM g (StM r ())), MonadBaseControl IO g, MonadBaseControl IO r, MonadControl m, MonadGamma c g, MonadRecolor r)+loopRecolor :: (ControlConstraint m (StM g (StM r ())), MonadBaseControl IO g, MonadBaseControl IO r, MonadControl m, MonadGamma g, MonadRecolor r)             => (forall a. g a -> IO (StM g a))             -> (forall a. r a -> IO (StM r a))+            -> (GammaValue g -> RecolorValue r)             -> m ()-loopRecolor runG runR = void $+loopRecolor runG runR coerceValue = void $   liftBaseWith $ \ runCIO ->     runR $ liftBaseWith $ \ runRIO ->       runG $ liftBaseWith $ \ runGIO -> do-        firstResult <- doRecolorGamma runGIO runRIO-        evalStateT (doLoopRecolor runCIO runGIO runRIO) firstResult+        firstResult <- doRecolorGamma runGIO runRIO coerceValue+        evalStateT (doLoopRecolor runCIO runGIO runRIO coerceValue) firstResult  -- | Use `gamma` and give the result to `recolor`. -- The arguments are runners from `liftBaseWith`.-doRecolorGamma :: (MonadBaseControl IO g, MonadBaseControl IO r, MonadGamma c g, MonadRecolor r)+doRecolorGamma :: (MonadBaseControl IO g, MonadBaseControl IO r, MonadGamma g, MonadRecolor r)                => (forall a. g a -> IO (StM g a))                -> (forall a. r a -> IO (StM r a))+               -> (GammaValue g -> RecolorValue r)                -> IO (StM g (StM r ()))-doRecolorGamma runGIO runRIO = runGIO $ do-  rgb <- toRGB <$> gamma-  liftBase $ runRIO $ recolor rgb+doRecolorGamma runGIO runRIO coerceValue = runGIO $ do+  value <- coerceValue <$> gamma+  liftBase $ runRIO $ recolor value  -- | A single iteration of `loopRecolor`. -- The arguments are runners from `liftBaseWith`.-doLoopRecolor :: (ControlConstraint m (StM g (StM r ())), MonadBaseControl IO g, MonadBaseControl IO r, MonadControl m, MonadGamma c g, MonadRecolor r)+doLoopRecolor :: (ControlConstraint m (StM g (StM r ())), MonadBaseControl IO g, MonadBaseControl IO r, MonadControl m, MonadGamma g, MonadRecolor r)               => (forall a. m a -> IO (StM m a))               -> (forall a. g a -> IO (StM g a))               -> (forall a. r a -> IO (StM r a))+              -> (GammaValue g -> RecolorValue r)               -> StateT (StM g (StM r ())) IO ()-doLoopRecolor runCIO runGIO runRIO = do+doLoopRecolor runCIO runGIO runRIO coerceValue = do   lastResult <- get   void $ liftBase $ runCIO $ doInbetween lastResult-  nextResult <- liftBase $ doRecolorGamma runGIO runRIO+  nextResult <- liftBase $ doRecolorGamma runGIO runRIO coerceValue   put nextResult-  doLoopRecolor runCIO runGIO runRIO--data ConfigControl m g r = ConfigControl { runControl :: forall a. m a -> IO a-                                         , runGamma   :: forall a. g a -> IO (StM g a)-                                         , runRecolor :: forall a. r a -> IO (StM r a)-                                         }+  doLoopRecolor runCIO runGIO runRIO coerceValue

@@ -1,7 +1,9 @@+{-# LANGUAGE ScopedTypeVariables #-}+ module Blucontrol.RGB (   RGB (..)-, Chromaticity-, Trichromaticity (..)+, mapRGB+, word8ToFloat ) where  import Control.DeepSeq@@ -9,47 +11,41 @@ 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)--instance NFData Chromaticity--instance Default Chromaticity where-  def = maxBound---- | combination of 'Chromaticity's for the colors 'red', 'green' and 'blue'-data Trichromaticity = Trichromaticity { red :: Chromaticity-                                       , green :: Chromaticity-                                       , blue :: Chromaticity-                                       }+-- | Values for the colors 'red', 'green' and 'blue'+data RGB a = RGB { red :: a+                 , green :: a+                 , blue :: a+                 }   deriving (Bounded, Eq, Generic, Ord, Read, Show) -instance NFData Trichromaticity+instance NFData a => NFData (RGB a) -instance Enum Trichromaticity where-  fromEnum tc = sum [ fromEnum (red tc)-                    , fromEnum (green tc) * range-                    , fromEnum (blue tc) * range * range-                    ]-    where range = succ . fromEnum $ maxBound @Chromaticity+-- TODO: Is this instance really necessary?+instance (Bounded a, Enum a) => Enum (RGB a) where+  fromEnum rgb = sum [ fromEnum (red rgb)+                     , fromEnum (green rgb) * range+                     , fromEnum (blue rgb) * range * range+                     ]+    where range = succ . fromEnum $ maxBound @a   toEnum i = let (b , i') = i `divMod` (range * range)                  (g , r) = i' `divMod` range-              in Trichromaticity { red = toEnum r-                                 , green = toEnum g-                                 , blue = toEnum b-                                 }-    where range = succ . fromEnum $ maxBound @Chromaticity+              in RGB { red = toEnum r+                     , green = toEnum g+                     , blue = toEnum b+                     }+    where range = succ . fromEnum $ maxBound @a -instance Default Trichromaticity where-  def = Trichromaticity { red = def-                        , green = def-                        , blue = def-                        }+instance Default (RGB Word8) where+  def = RGB { red = maxBound+            , green = maxBound+            , blue = maxBound+            } -instance RGB Trichromaticity where-  toRGB = id+mapRGB :: (a -> b) -> RGB a -> RGB b+mapRGB f rgb = RGB { red = f $ red rgb+                   , green = f $ green rgb+                   , blue = f $ blue rgb+                   }++word8ToFloat :: Word8 -> Float+word8ToFloat = (/ fromIntegral (maxBound @Word8)) . fromIntegral

@@ -1,5 +1,3 @@-{-# LANGUAGE RecordWildCards #-}- module Blucontrol.RGB.Brightness (   Brightness , WithBrightness (..)@@ -9,8 +7,6 @@ import Data.Default import GHC.Generics -import Blucontrol.RGB- -- | Arbitrary precision brightness between 0 and 1 newtype Brightness = Brightness Rational   deriving (Enum, Eq, Fractional, Generic, Num, Ord, Read, Real, RealFrac, Show)@@ -24,9 +20,9 @@ instance Default Brightness where   def = 1 --- | Parametric RGB value with an associated brightness+-- | Combination of a color value and a 'Brightness' data WithBrightness a = WithBrightness { brightness :: Brightness-                                       , rgb :: a+                                       , color :: a                                        }   deriving (Eq, Generic, Ord, Read, Show) @@ -34,16 +30,9 @@  instance Default a => Default (WithBrightness a) where   def = WithBrightness { brightness = def-                       , rgb = def+                       , color = def                        } --- TODO: maybe create separate instances for Trichromaticity and Temperature-instance RGB a => RGB (WithBrightness a) where-  toRGB WithBrightness {..} = mapChromaticity applyBrightness $ toRGB rgb-      where applyBrightness = truncate . (toRational brightness *) . toRational--mapChromaticity :: (Chromaticity -> Chromaticity) -> Trichromaticity -> Trichromaticity-mapChromaticity f rgb = Trichromaticity { red = f $ red rgb-                                        , green = f $ green rgb-                                        , blue = f $ blue rgb-                                        }+-- TODO: Maybe allow applying to RGB?+--toRGB WithBrightness {..} = mapRGB applyBrightness $ toRGB rgb+--  where applyBrightness = truncate . (toRational brightness *) . toRational

@@ -2,10 +2,12 @@  module Blucontrol.RGB.Temperature (   Temperature+, toRGBWord8 ) where  import Control.DeepSeq import Data.Default+import Data.Word import GHC.Generics  import Blucontrol.RGB@@ -23,25 +25,25 @@ instance Default Temperature where   def = 6600 -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+-- TODO: Test and implement more accurately. Currently based on blugon. Don't enforce Word8.+toRGBWord8 :: Temperature -> RGB Word8+toRGBWord8 (Temperature temp) = RGB {..}+  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

@@ -2,9 +2,12 @@   MonadRecolor (..) ) where -import Blucontrol.RGB- class Monad m => MonadRecolor m where -  -- | Apply a 'Trichromaticity'.-  recolor :: Trichromaticity -> m ()+  type RecolorValue m++  {- | Apply a gamma value.+     This is a monadic function, to allow application to external programs like an X display+     server.+  -}+  recolor :: RecolorValue m -> m ()

@@ -11,19 +11,20 @@  import Blucontrol.Recolor -newtype RecolorPrintT m a = RecolorPrintT { unRecolorPrintT :: m a }+newtype RecolorPrintT c m a = RecolorPrintT { unRecolorPrintT :: m a }   deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b) -instance MonadTrans RecolorPrintT where+instance MonadTrans (RecolorPrintT c) where   lift = RecolorPrintT -instance MonadTransControl RecolorPrintT where-  type StT RecolorPrintT a = a+instance MonadTransControl (RecolorPrintT c) where+  type StT (RecolorPrintT c) a = a   liftWith inner = RecolorPrintT $ inner unRecolorPrintT   restoreT = RecolorPrintT -instance MonadBaseControl IO m => MonadRecolor (RecolorPrintT m) where+instance (MonadBaseControl IO m, Show c) => MonadRecolor (RecolorPrintT c m) where+  type RecolorValue (RecolorPrintT c m) = c   recolor = liftBase . print -runRecolorPrintT :: RecolorPrintT m a -> m a+runRecolorPrintT :: RecolorPrintT c m a -> m a runRecolorPrintT = unRecolorPrintT

@@ -39,6 +39,7 @@   restoreT = defaultRestoreT2 RecolorXT  instance MonadBaseControl IO m => MonadRecolor (RecolorXT m) where+  type RecolorValue (RecolorXT m) = RGB Float   recolor rgb = do     display <- RecolorXT ask     root <- liftXIO XErrorRead $@@ -88,12 +89,8 @@   , maybe "" (("." <>) . T.pack . show) screen   ] -translateRGB :: Trichromaticity -> XRRGamma-translateRGB Trichromaticity {..} = XRRGamma {..}-  where xrr_gamma_red = translateColor red-        xrr_gamma_green = translateColor green-        xrr_gamma_blue = translateColor blue---- | Create a normalized value for a 'Chromaticity'.-translateColor :: (Fractional a, Num a) => Chromaticity -> a-translateColor = (/ fromIntegral (maxBound @Chromaticity)) . fromIntegral+translateRGB :: RGB Float -> XRRGamma+translateRGB RGB {..} = XRRGamma {..}+  where xrr_gamma_red = red+        xrr_gamma_green = green+        xrr_gamma_blue = blue

@@ -10,11 +10,12 @@ import Control.DeepSeq import Control.Monad.Identity import Data.Time+import Data.Word import GHC.Generics  import Blucontrol.Gamma.Linear import Blucontrol.RGB-import Blucontrol.Test.RGB (Arbitrary_Trichromaticity (..))+import Blucontrol.Test.RGB (Arbitrary_RGBWord8 (..))  test :: Spec test = describe "Blucontrol.Gamma.Linear" $ do@@ -22,9 +23,9 @@   it "convert Time to TimeOfDay" $     property prop_timeToTimeOfDay -  -- TODO: this tests `calculateRGB weightedAverageTrichromaticity`-  it "calculateTrichromaticity between surrounding values" $-    property prop_calculateTrichromaticity+  -- TODO: this tests `calculateValue weightedAverageRGB`+  it "calculateRGB between surrounding values" $+    property prop_calculateRGB  newtype Arbitrary_Time = Arbitrary_Time Time   deriving (Bounded, Enum, Eq, Generic, Ord, Read, Show)@@ -41,26 +42,26 @@   , 0 == todSec   ]   where h :. m = time-        TimeOfDay {..} = fst $ time Blucontrol.Gamma.Linear.==> (undefined :: Trichromaticity)+        TimeOfDay {..} = fst $ time Blucontrol.Gamma.Linear.==> (undefined :: RGB Word8) -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 $ calculateRGB weightedAverageTrichromaticity tod+prop_calculateRGB :: Arbitrary_Time+                  -> (Arbitrary_Time,Arbitrary_RGBWord8)+                  -> (Arbitrary_Time,Arbitrary_RGBWord8)+                  -> Bool+prop_calculateRGB (Arbitrary_Time time) (Arbitrary_Time xt , Arbitrary_RGBWord8 xtc) (Arbitrary_Time yt , Arbitrary_RGBWord8 ytc) =+  rgb `prop_RGBBetween` (xtc , ytc)+  where rgb = runIdentity . runGammaLinearT rgbMap $ calculateValue weightedAverageRGB tod         rgbMap = xt Blucontrol.Gamma.Linear.==> xtc             :| [ yt Blucontrol.Gamma.Linear.==> ytc                ]-        tod = LocalTime (ModifiedJulianDay 0) . fst $ time Blucontrol.Gamma.Linear.==> (undefined :: Trichromaticity)+        tod = LocalTime (ModifiedJulianDay 0) . fst $ time Blucontrol.Gamma.Linear.==> (undefined :: RGB Word8) -prop_TrichromaticityBetween :: Trichromaticity -> (Trichromaticity,Trichromaticity) -> Bool-prop_TrichromaticityBetween x (a,b) = and-  [ red x `prop_ChromaticityBetween` (red a , red b)-  , green x `prop_ChromaticityBetween` (green a , green b)-  , blue x `prop_ChromaticityBetween` (blue a , blue b)+prop_RGBBetween :: RGB Word8 -> (RGB Word8,RGB Word8) -> Bool+prop_RGBBetween x (a,b) = and+  [ red x `prop_between` (red a , red b)+  , green x `prop_between` (green a , green b)+  , blue x `prop_between` (blue a , blue b)   ] -prop_ChromaticityBetween :: Chromaticity -> (Chromaticity,Chromaticity) -> Bool-prop_ChromaticityBetween x (a,b) = x <= max a b && x >= min a b+prop_between :: Ord a => a -> (a,a) -> Bool+prop_between x (a,b) = x <= max a b && x >= min a b

@@ -2,14 +2,14 @@  module Blucontrol.Test.RGB (   test-, Arbitrary_Chromaticity (..)-, Arbitrary_Trichromaticity (..)+, Arbitrary_RGBWord8 (..) ) where  import Test.Hspec import Test.QuickCheck  import Control.DeepSeq+import Data.Word import GHC.Generics  import Blucontrol.RGB@@ -17,24 +17,13 @@ test :: Spec test = describe "Blucontrol.RGB" $ do -  it "Chromaticity in bounds." $-    property $ total @Arbitrary_Chromaticity--  it "Trichromaticity in bounds." $-    property $ total @Arbitrary_Trichromaticity--newtype Arbitrary_Chromaticity = Arbitrary_Chromaticity Chromaticity-  deriving (Bounded, Enum, Eq, Generic, Ord, Read, Show)--instance NFData Arbitrary_Chromaticity--instance Arbitrary Arbitrary_Chromaticity where-  arbitrary = elements [minBound .. maxBound]+  it "(RGB Word8) in bounds." $+    property $ total @Arbitrary_RGBWord8 -newtype Arbitrary_Trichromaticity = Arbitrary_Trichromaticity Trichromaticity+newtype Arbitrary_RGBWord8 = Arbitrary_RGBWord8 (RGB Word8)   deriving (Bounded, Enum, Eq, Generic, Ord, Read, Show) -instance NFData Arbitrary_Trichromaticity+instance NFData Arbitrary_RGBWord8 -instance Arbitrary Arbitrary_Trichromaticity where+instance Arbitrary Arbitrary_RGBWord8 where   arbitrary = elements [minBound .. maxBound]