-- | Utilities to manipulate colors, and setting them for Cairo drawings.
module Draw.Color (
  Color
, AlphaColor
, CairoColor(..)
, rgb
, hsv
, hsl
, rgba
, hsva
, hsla
, parseRgbaHex
, parseRgbHex
, module ReExport
, average
, black
, white
, adjustHsl
, adjustHsv
) where



import           Data.Colour
import qualified Data.Colour              as ReExport hiding (black)
import           Data.Colour.Names        hiding (grey)
import           Data.Colour.RGBSpace     as Colour
import qualified Data.Colour.RGBSpace.HSL as Colour
import qualified Data.Colour.RGBSpace.HSV as Colour
import           Data.Colour.SRGB         as Colour
import qualified Graphics.Rendering.Cairo as C
import           Text.Read



-- $setup
-- >>> import Draw
-- >>> import Geometry.Core
-- >>> import qualified Graphics.Rendering.Cairo as C



-- | Anything we can instruct Cairo to set its color to.
class CairoColor color where
    -- |
    -- >>> :{
    -- haddockRender "Draw/Color/set_color.svg" 140 40 $ \_ -> do
    --     for_ (zip [0..] [30, 40 .. 150-30]) $ \(i, x) -> do
    --         setColor (mma i)
    --         sketch (Circle (Vec2 x 20) 10)
    --         C.fill
    -- :}
    -- Generated file: size 4KB, crc32: 0xe0e16234
    --
    -- <<docs/haddock/Draw/Color/set_color.svg>>
    setColor :: color -> C.Render ()
    setColor = color -> Render ()
forall color. CairoColor color => color -> Render ()
setColour

    setColour :: color -> C.Render ()
    setColour = color -> Render ()
forall color. CairoColor color => color -> Render ()
setColor

instance Real a => CairoColor (Colour a) where
    setColor :: Colour a -> Render ()
setColor = (Double -> Double -> Double -> Render ())
-> RGB Double -> Render ()
forall a b. (a -> a -> a -> b) -> RGB a -> b
uncurryRGB Double -> Double -> Double -> Render ()
C.setSourceRGB (RGB Double -> Render ())
-> (Colour a -> RGB Double) -> Colour a -> Render ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color Double -> RGB Double
forall b. (Ord b, Floating b) => Colour b -> RGB b
toSRGB (Color Double -> RGB Double)
-> (Colour a -> Color Double) -> Colour a -> RGB Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Colour a -> Color Double
forall b a. (Fractional b, Real a) => Colour a -> Colour b
colourConvert

instance (Real a, Floating a) => CairoColor (AlphaColour a) where
    setColor :: AlphaColour a -> Render ()
setColor AlphaColour a
color = (Double -> Double -> Double -> Double -> Render ())
-> RGB Double -> Double -> Render ()
forall a b. (a -> a -> a -> b) -> RGB a -> b
uncurryRGB Double -> Double -> Double -> Double -> Render ()
C.setSourceRGBA
        (Color Double -> RGB Double
forall b. (Ord b, Floating b) => Colour b -> RGB b
toSRGB (Colour a -> Color Double
forall b a. (Fractional b, Real a) => Colour a -> Colour b
colourConvert (a -> AlphaColour a -> AlphaColour a
forall a. Num a => a -> AlphaColour a -> AlphaColour a
dissolve (a
1a -> a -> a
forall a. Fractional a => a -> a -> a
/a
alpha) AlphaColour a
color AlphaColour a -> Colour a -> Colour a
forall a. Num a => AlphaColour a -> Colour a -> Colour a
forall (f :: * -> *) a.
(ColourOps f, Num a) =>
AlphaColour a -> f a -> f a
`over` Colour a
forall a. Num a => Colour a
black)))
        (a -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac a
alpha)
      where alpha :: a
alpha = AlphaColour a -> a
forall a. AlphaColour a -> a
alphaChannel AlphaColour a
color

-- | American English type synonym
type Color a = Colour a

-- | American English type synonym
type AlphaColor a = AlphaColour a

-- | Convert a color from HSL space
hsl :: Double -- ^ Hue [0..360]
    -> Double -- ^ Saturation [0..1]
    -> Double -- ^ Lightness [0..1]
    -> Color Double
hsl :: Double -> Double -> Double -> Color Double
hsl Double
h Double
s Double
l = (Double -> Double -> Double -> Color Double)
-> RGB Double -> Color Double
forall a b. (a -> a -> a -> b) -> RGB a -> b
uncurryRGB (RGBSpace Double -> Double -> Double -> Double -> Color Double
forall a. Fractional a => RGBSpace a -> a -> a -> a -> Colour a
rgbUsingSpace RGBSpace Double
forall a. (Ord a, Floating a) => RGBSpace a
sRGBSpace) (Double -> Double -> Double -> RGB Double
forall a. (RealFrac a, Ord a) => a -> a -> a -> RGB a
Colour.hsl Double
h Double
s Double
l)

-- | Convert a color from HSLA space
hsla:: Double -- ^ Hue [0..360]
    -> Double -- ^ Saturation [0..1]
    -> Double -- ^ Lightness [0..1]
    -> Double -- ^ Alpha [0..1]
    -> AlphaColor Double
hsla :: Double -> Double -> Double -> Double -> AlphaColor Double
hsla Double
h Double
s Double
l Double
a = Double -> Double -> Double -> Color Double
Draw.Color.hsl Double
h Double
s Double
l Color Double -> Double -> AlphaColor Double
forall a. Num a => Colour a -> a -> AlphaColour a
`withOpacity` Double
a

-- | Convert a color from HSV space
hsv :: Double -- ^ Hue [0..360]
    -> Double -- ^ Saturation [0..1]
    -> Double -- ^ Value (~ brightness) [0..1]
    -> Color Double
hsv :: Double -> Double -> Double -> Color Double
hsv Double
h Double
s Double
v = (Double -> Double -> Double -> Color Double)
-> RGB Double -> Color Double
forall a b. (a -> a -> a -> b) -> RGB a -> b
uncurryRGB (RGBSpace Double -> Double -> Double -> Double -> Color Double
forall a. Fractional a => RGBSpace a -> a -> a -> a -> Colour a
rgbUsingSpace RGBSpace Double
forall a. (Ord a, Floating a) => RGBSpace a
sRGBSpace) (Double -> Double -> Double -> RGB Double
forall a. (RealFrac a, Ord a) => a -> a -> a -> RGB a
Colour.hsv Double
h Double
s Double
v)

-- | Convert a color from HSVA space
hsva:: Double -- ^ Hue [0..360]
    -> Double -- ^ Saturation [0..1]
    -> Double -- ^ Value (~ brightness) [0..1]
    -> Double -- ^ Alpha [0..1]
    -> AlphaColor Double
hsva :: Double -> Double -> Double -> Double -> AlphaColor Double
hsva Double
h Double
s Double
v Double
a = Double -> Double -> Double -> Color Double
Draw.Color.hsv Double
h Double
s Double
v Color Double -> Double -> AlphaColor Double
forall a. Num a => Colour a -> a -> AlphaColour a
`withOpacity` Double
a

-- | Convert a color from sRGB space
rgb :: Double  -- ^ Red [0..1]
    -> Double  -- ^ Green [0..1]
    -> Double  -- ^ Blue [0..1]
    -> Color Double
rgb :: Double -> Double -> Double -> Color Double
rgb = Double -> Double -> Double -> Color Double
forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
sRGB

-- | Convert a color from sRGBA space
rgba:: Double -- ^ Red [0..1]
    -> Double -- ^ Green [0..1]
    -> Double -- ^ Blue [0..1]
    -> Double -- ^ Alpha [0..1]
    -> AlphaColor Double
rgba :: Double -> Double -> Double -> Double -> AlphaColor Double
rgba Double
r Double
g Double
b Double
a = Double -> Double -> Double -> Color Double
forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
sRGB Double
r Double
g Double
b Color Double -> Double -> AlphaColor Double
forall a. Num a => Colour a -> a -> AlphaColour a
`withOpacity` Double
a

-- | Parse a RGBA hex value. 'error's on bad input, so be careful!
--
-- @
-- 'parseRgbaHex' "0x123456ab"
-- '=='
-- 'rgba' ('fromIntegral' 0x12/255) ('fromIntegral' 0x34/255) ('fromIntegral' 0x56/255) ('fromIntegral' 0xab/255)
-- @
parseRgbaHex :: String -> AlphaColor Double
parseRgbaHex :: String -> AlphaColor Double
parseRgbaHex (Char
'#' : String
rrggbbaa) = String -> AlphaColor Double
parseRgbaHex String
rrggbbaa
parseRgbaHex [Char
r1, Char
r2, Char
g1, Char
g2, Char
b1, Char
b2, Char
a1, Char
a2] = String -> Either String (AlphaColor Double) -> AlphaColor Double
forall rgb. String -> Either String rgb -> rgb
rightOrError String
"parseRgbaHex" (Either String (AlphaColor Double) -> AlphaColor Double)
-> Either String (AlphaColor Double) -> AlphaColor Double
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double -> Double -> AlphaColor Double
rgba
    (Double -> Double -> Double -> Double -> AlphaColor Double)
-> Either String Double
-> Either String (Double -> Double -> Double -> AlphaColor Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Char -> Either String Double
parseHexPair Char
r1 Char
r2
    Either String (Double -> Double -> Double -> AlphaColor Double)
-> Either String Double
-> Either String (Double -> Double -> AlphaColor Double)
forall a b.
Either String (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Char -> Char -> Either String Double
parseHexPair Char
g1 Char
g2
    Either String (Double -> Double -> AlphaColor Double)
-> Either String Double
-> Either String (Double -> AlphaColor Double)
forall a b.
Either String (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Char -> Char -> Either String Double
parseHexPair Char
b1 Char
b2
    Either String (Double -> AlphaColor Double)
-> Either String Double -> Either String (AlphaColor Double)
forall a b.
Either String (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Char -> Char -> Either String Double
parseHexPair Char
a1 Char
a2
parseRgbaHex String
str
    | String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
8 = String -> AlphaColor Double
forall a. HasCallStack => String -> a
error (String
"parseRgbaHex: input too short: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str)
    | Bool
otherwise      = String -> AlphaColor Double
forall a. HasCallStack => String -> a
error (String
"parseRgbaHex: input too long: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str)

-- | Parse a RGB hex value. 'error's on bad input, so be careful!
--
-- @
-- 'parseRgbHex' "0x123456"
-- '=='
-- 'rgb' ('fromIntegral' 0x12/255) ('fromIntegral' 0x34/255) ('fromIntegral' 0x56/255)
-- @
parseRgbHex :: String -> Color Double
parseRgbHex :: String -> Color Double
parseRgbHex (Char
'#' : String
rrggbb) = String -> Color Double
parseRgbHex String
rrggbb
parseRgbHex [Char
r1, Char
r2, Char
g1, Char
g2, Char
b1, Char
b2] = String -> Either String (Color Double) -> Color Double
forall rgb. String -> Either String rgb -> rgb
rightOrError String
"parseRgbHex" (Either String (Color Double) -> Color Double)
-> Either String (Color Double) -> Color Double
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double -> Color Double
rgb
    (Double -> Double -> Double -> Color Double)
-> Either String Double
-> Either String (Double -> Double -> Color Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Char -> Either String Double
parseHexPair Char
r1 Char
r2
    Either String (Double -> Double -> Color Double)
-> Either String Double -> Either String (Double -> Color Double)
forall a b.
Either String (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Char -> Char -> Either String Double
parseHexPair Char
g1 Char
g2
    Either String (Double -> Color Double)
-> Either String Double -> Either String (Color Double)
forall a b.
Either String (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Char -> Char -> Either String Double
parseHexPair Char
b1 Char
b2
parseRgbHex String
str
    | String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
6 = String -> Color Double
forall a. HasCallStack => String -> a
error (String
"parseRgbHex: input too short: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str)
    | Bool
otherwise      = String -> Color Double
forall a. HasCallStack => String -> a
error (String
"parseRgbHex: input too long: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str)

rightOrError :: String -> Either String rgb -> rgb
rightOrError :: forall rgb. String -> Either String rgb -> rgb
rightOrError String
_ (Right rgb
r) = rgb
r
rightOrError String
source (Left String
err) = String -> rgb
forall a. HasCallStack => String -> a
error (String
source String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err)

parseHexPair :: Char -> Char -> Either String Double
parseHexPair :: Char -> Char -> Either String Double
parseHexPair Char
a Char
b = case String -> Maybe Double
forall a. Read a => String -> Maybe a
readMaybe (String
"0x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
a,Char
b]) of
    Just Double
r -> Double -> Either String Double
forall a b. b -> Either a b
Right (Double
r Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
255)
    Maybe Double
Nothing -> String -> Either String Double
forall a b. a -> Either a b
Left (String
"Cannot parse hex pair: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
a,Char
b])

average :: [Color Double] -> Color Double
average :: [Color Double] -> Color Double
average [Color Double]
colors = [Color Double] -> Color Double
forall a. Monoid a => [a] -> a
mconcat (Double -> Color Double -> Color Double
forall a. Num a => a -> Colour a -> Colour a
forall (f :: * -> *) a. (ColourOps f, Num a) => a -> f a -> f a
darken (Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Color Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Color Double]
colors)) (Color Double -> Color Double) -> [Color Double] -> [Color Double]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Color Double]
colors)

-- | Adjust a HSV value per component.
adjustHsv
    :: (Double -> Double) -- ^ Adjust Hue [0..360]
    -> (Double -> Double) -- ^ Adjust Saturation [0..1]
    -> (Double -> Double) -- ^ Adjust Value (~ Brightness) [0..1]
    -> Color Double -> Color Double
adjustHsv :: (Double -> Double)
-> (Double -> Double)
-> (Double -> Double)
-> Color Double
-> Color Double
adjustHsv Double -> Double
fh Double -> Double
fs Double -> Double
fv Color Double
color = Double -> Double -> Double -> Color Double
hsv (Double -> Double
fh Double
h) (Double -> Double
fs Double
s) (Double -> Double
fv Double
v)
  where (Double
h, Double
s, Double
v) = RGB Double -> (Double, Double, Double)
forall a. (Fractional a, Ord a) => RGB a -> (a, a, a)
Colour.hsvView (Color Double -> RGB Double
forall b. (Ord b, Floating b) => Colour b -> RGB b
toSRGB Color Double
color)

-- | Adjust a HSL value per component.
adjustHsl
    :: (Double -> Double) -- ^ Adjust Hue [0..360]
    -> (Double -> Double) -- ^ Adjust Saturation [0..1]
    -> (Double -> Double) -- ^ Adjust Luminance [0..1]
    -> Color Double -> Color Double
adjustHsl :: (Double -> Double)
-> (Double -> Double)
-> (Double -> Double)
-> Color Double
-> Color Double
adjustHsl Double -> Double
fh Double -> Double
fs Double -> Double
fl Color Double
color = (Double -> Double -> Double -> Color Double)
-> RGB Double -> Color Double
forall a b. (a -> a -> a -> b) -> RGB a -> b
uncurryRGB (RGBSpace Double -> Double -> Double -> Double -> Color Double
forall a. Fractional a => RGBSpace a -> a -> a -> a -> Colour a
rgbUsingSpace RGBSpace Double
forall a. (Ord a, Floating a) => RGBSpace a
sRGBSpace) (Double -> Double -> Double -> RGB Double
forall a. (RealFrac a, Ord a) => a -> a -> a -> RGB a
Colour.hsl (Double -> Double
fh Double
h) (Double -> Double
fs Double
s) (Double -> Double
fl Double
l))
  where (Double
h, Double
s, Double
l) = RGB Double -> (Double, Double, Double)
forall a. (Fractional a, Ord a) => RGB a -> (a, a, a)
Colour.hslView (Color Double -> RGB Double
forall b. (Ord b, Floating b) => Colour b -> RGB b
toSRGB Color Double
color)