{-
Copyright (c) 2008, 2009
Russell O'Connor

Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included in
all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
THE SOFTWARE.
-}
module Data.Colour.Internal where

import Data.List
import qualified Data.Colour.Chan as Chan
import Data.Colour.Chan (Chan(Chan))
import Data.Monoid
import Data.Semigroup

data Red = Red
data Green = Green
data Blue = Blue

-- |This type represents the human preception of colour.
-- The @a@ parameter is a numeric type used internally for the
-- representation.
--
-- The 'Monoid' instance allows one to add colours, but beware that adding
-- colours can take you out of gamut.  Consider using 'blend' whenever
-- possible.

-- Internally we store the colour in linear ITU-R BT.709 RGB colour space.
data Colour a = RGB !(Chan Red a) !(Chan Green a) !(Chan Blue a)
                deriving (Colour a -> Colour a -> Bool
(Colour a -> Colour a -> Bool)
-> (Colour a -> Colour a -> Bool) -> Eq (Colour a)
forall a. Eq a => Colour a -> Colour a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Colour a -> Colour a -> Bool
$c/= :: forall a. Eq a => Colour a -> Colour a -> Bool
== :: Colour a -> Colour a -> Bool
$c== :: forall a. Eq a => Colour a -> Colour a -> Bool
Eq)

-- |Change the type used to represent the colour coordinates.
colourConvert :: (Fractional b, Real a) => Colour a -> Colour b
colourConvert :: Colour a -> Colour b
colourConvert (RGB Chan Red a
r Chan Green a
g Chan Blue a
b) =
  Chan Red b -> Chan Green b -> Chan Blue b -> Colour b
forall a. Chan Red a -> Chan Green a -> Chan Blue a -> Colour a
RGB (Chan Red a -> Chan Red b
forall b a p. (Fractional b, Real a) => Chan p a -> Chan p b
Chan.convert Chan Red a
r) (Chan Green a -> Chan Green b
forall b a p. (Fractional b, Real a) => Chan p a -> Chan p b
Chan.convert Chan Green a
g) (Chan Blue a -> Chan Blue b
forall b a p. (Fractional b, Real a) => Chan p a -> Chan p b
Chan.convert Chan Blue a
b)

-- 'black' is the colourless colour.  It is the identity colour in
-- additive colour spaces.
black :: (Num a) => Colour a
black :: Colour a
black = Chan Red a -> Chan Green a -> Chan Blue a -> Colour a
forall a. Chan Red a -> Chan Green a -> Chan Blue a -> Colour a
RGB Chan Red a
forall a p. Num a => Chan p a
Chan.empty Chan Green a
forall a p. Num a => Chan p a
Chan.empty Chan Blue a
forall a p. Num a => Chan p a
Chan.empty

instance (Num a) => Semigroup (Colour a) where
  <> :: Colour a -> Colour a -> Colour a
(<>) = Colour a -> Colour a -> Colour a
forall a. Monoid a => a -> a -> a
mappend

instance (Num a) => Monoid (Colour a) where
  mempty :: Colour a
mempty = Colour a
forall a. Num a => Colour a
black
  (RGB Chan Red a
r1 Chan Green a
g1 Chan Blue a
b1) mappend :: Colour a -> Colour a -> Colour a
`mappend` (RGB Chan Red a
r2 Chan Green a
g2 Chan Blue a
b2) =
    Chan Red a -> Chan Green a -> Chan Blue a -> Colour a
forall a. Chan Red a -> Chan Green a -> Chan Blue a -> Colour a
RGB (Chan Red a
r1 Chan Red a -> Chan Red a -> Chan Red a
forall a p. Num a => Chan p a -> Chan p a -> Chan p a
`Chan.add` Chan Red a
r2) (Chan Green a
g1 Chan Green a -> Chan Green a -> Chan Green a
forall a p. Num a => Chan p a -> Chan p a -> Chan p a
`Chan.add` Chan Green a
g2) (Chan Blue a
b1 Chan Blue a -> Chan Blue a -> Chan Blue a
forall a p. Num a => Chan p a -> Chan p a -> Chan p a
`Chan.add` Chan Blue a
b2)
  mconcat :: [Colour a] -> Colour a
mconcat [Colour a]
l = Chan Red a -> Chan Green a -> Chan Blue a -> Colour a
forall a. Chan Red a -> Chan Green a -> Chan Blue a -> Colour a
RGB ([Chan Red a] -> Chan Red a
forall a p. Num a => [Chan p a] -> Chan p a
Chan.sum [Chan Red a]
lr) ([Chan Green a] -> Chan Green a
forall a p. Num a => [Chan p a] -> Chan p a
Chan.sum [Chan Green a]
lg) ([Chan Blue a] -> Chan Blue a
forall a p. Num a => [Chan p a] -> Chan p a
Chan.sum [Chan Blue a]
lb)
   where
    ([Chan Red a]
lr,[Chan Green a]
lg,[Chan Blue a]
lb) = [(Chan Red a, Chan Green a, Chan Blue a)]
-> ([Chan Red a], [Chan Green a], [Chan Blue a])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ((Colour a -> (Chan Red a, Chan Green a, Chan Blue a))
-> [Colour a] -> [(Chan Red a, Chan Green a, Chan Blue a)]
forall a b. (a -> b) -> [a] -> [b]
map Colour a -> (Chan Red a, Chan Green a, Chan Blue a)
forall a. Colour a -> (Chan Red a, Chan Green a, Chan Blue a)
toRGB [Colour a]
l)
    toRGB :: Colour a -> (Chan Red a, Chan Green a, Chan Blue a)
toRGB (RGB Chan Red a
r Chan Green a
g Chan Blue a
b) = (Chan Red a
r,Chan Green a
g,Chan Blue a
b)

data Alpha = Alpha

-- |This type represents a 'Colour' that may be semi-transparent.
--
-- The 'Monoid' instance allows you to composite colours.
--
-- >x `mappend` y == x `over` y
--
-- To get the (pre-multiplied) colour channel of an 'AlphaColour' @c@,
-- simply composite @c@ over black.
--
-- >c `over` black

-- Internally we use a premultiplied-alpha representation.
data AlphaColour a = RGBA !(Colour a) !(Chan Alpha a) deriving (AlphaColour a -> AlphaColour a -> Bool
(AlphaColour a -> AlphaColour a -> Bool)
-> (AlphaColour a -> AlphaColour a -> Bool) -> Eq (AlphaColour a)
forall a. Eq a => AlphaColour a -> AlphaColour a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AlphaColour a -> AlphaColour a -> Bool
$c/= :: forall a. Eq a => AlphaColour a -> AlphaColour a -> Bool
== :: AlphaColour a -> AlphaColour a -> Bool
$c== :: forall a. Eq a => AlphaColour a -> AlphaColour a -> Bool
Eq)

-- |This 'AlphaColour' is entirely transparent and has no associated
-- colour channel.
transparent :: (Num a) => AlphaColour a
transparent :: AlphaColour a
transparent = Colour a -> Chan Alpha a -> AlphaColour a
forall a. Colour a -> Chan Alpha a -> AlphaColour a
RGBA (Chan Red a -> Chan Green a -> Chan Blue a -> Colour a
forall a. Chan Red a -> Chan Green a -> Chan Blue a -> Colour a
RGB Chan Red a
forall a p. Num a => Chan p a
Chan.empty Chan Green a
forall a p. Num a => Chan p a
Chan.empty Chan Blue a
forall a p. Num a => Chan p a
Chan.empty) Chan Alpha a
forall a p. Num a => Chan p a
Chan.empty

-- |Change the type used to represent the colour coordinates.
alphaColourConvert :: (Fractional b, Real a) =>
  AlphaColour a -> AlphaColour b
alphaColourConvert :: AlphaColour a -> AlphaColour b
alphaColourConvert (RGBA Colour a
c Chan Alpha a
a) = Colour b -> Chan Alpha b -> AlphaColour b
forall a. Colour a -> Chan Alpha a -> AlphaColour a
RGBA (Colour a -> Colour b
forall b a. (Fractional b, Real a) => Colour a -> Colour b
colourConvert Colour a
c) (Chan Alpha a -> Chan Alpha b
forall b a p. (Fractional b, Real a) => Chan p a -> Chan p b
Chan.convert Chan Alpha a
a)

-- |Creates an opaque 'AlphaColour' from a 'Colour'.
opaque :: (Num a) => Colour a -> AlphaColour a
opaque :: Colour a -> AlphaColour a
opaque Colour a
c = Colour a -> Chan Alpha a -> AlphaColour a
forall a. Colour a -> Chan Alpha a -> AlphaColour a
RGBA Colour a
c Chan Alpha a
forall a p. Num a => Chan p a
Chan.full

-- |Returns an 'AlphaColour' more transparent by a factor of @o@.
dissolve :: (Num a) => a -> AlphaColour a -> AlphaColour a
dissolve :: a -> AlphaColour a -> AlphaColour a
dissolve a
o (RGBA Colour a
c Chan Alpha a
a) = Colour a -> Chan Alpha a -> AlphaColour a
forall a. Colour a -> Chan Alpha a -> AlphaColour a
RGBA (a -> Colour a -> Colour a
forall (f :: * -> *) a. (ColourOps f, Num a) => a -> f a -> f a
darken a
o Colour a
c) (a -> Chan Alpha a -> Chan Alpha a
forall a p. Num a => a -> Chan p a -> Chan p a
Chan.scale a
o Chan Alpha a
a)

-- |Creates an 'AlphaColour' from a 'Colour' with a given opacity.
--
-- >c `withOpacity` o == dissolve o (opaque c)
withOpacity :: (Num a) => Colour a -> a -> AlphaColour a
Colour a
c withOpacity :: Colour a -> a -> AlphaColour a
`withOpacity` a
o = Colour a -> Chan Alpha a -> AlphaColour a
forall a. Colour a -> Chan Alpha a -> AlphaColour a
RGBA (a -> Colour a -> Colour a
forall (f :: * -> *) a. (ColourOps f, Num a) => a -> f a -> f a
darken a
o Colour a
c) (a -> Chan Alpha a
forall p a. a -> Chan p a
Chan a
o)

--------------------------------------------------------------------------
-- Blending
--------------------------------------------------------------------------

class AffineSpace f where
 -- |Compute a affine Combination (weighted-average) of points.
 -- The last parameter will get the remaining weight.
 -- e.g.
 --
 -- >affineCombo [(0.2,a), (0.3,b)] c == 0.2*a + 0.3*b + 0.5*c
 --
 -- Weights can be negative, or greater than 1.0; however, be aware
 -- that non-convex combinations may lead to out of gamut colours.
 affineCombo :: (Num a) => [(a,f a)] -> f a -> f a

-- |Compute the weighted average of two points.
-- e.g.
--
-- >blend 0.4 a b = 0.4*a + 0.6*b
--
-- The weight can be negative, or greater than 1.0; however, be aware
-- that non-convex combinations may lead to out of gamut colours.
blend :: (Num a, AffineSpace f) => a -> f a -> f a -> f a
blend :: a -> f a -> f a -> f a
blend a
weight f a
c1 f a
c2 = [(a, f a)] -> f a -> f a
forall (f :: * -> *) a.
(AffineSpace f, Num a) =>
[(a, f a)] -> f a -> f a
affineCombo [(a
weight,f a
c1)] f a
c2

instance AffineSpace Colour where
 affineCombo :: [(a, Colour a)] -> Colour a -> Colour a
affineCombo [(a, Colour a)]
l Colour a
z =
   (Colour a -> Colour a -> Colour a) -> [Colour a] -> Colour a
forall a. (a -> a -> a) -> [a] -> a
foldl1' Colour a -> Colour a -> Colour a
forall a. Monoid a => a -> a -> a
mappend [a -> Colour a -> Colour a
forall (f :: * -> *) a. (ColourOps f, Num a) => a -> f a -> f a
darken a
w Colour a
a | (a
w,Colour a
a) <- (a
1a -> a -> a
forall a. Num a => a -> a -> a
-a
total,Colour a
z)(a, Colour a) -> [(a, Colour a)] -> [(a, Colour a)]
forall a. a -> [a] -> [a]
:[(a, Colour a)]
l]
  where
   total :: a
total = [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([a] -> a) -> [a] -> a
forall a b. (a -> b) -> a -> b
$ ((a, Colour a) -> a) -> [(a, Colour a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, Colour a) -> a
forall a b. (a, b) -> a
fst [(a, Colour a)]
l

instance AffineSpace AlphaColour where
 affineCombo :: [(a, AlphaColour a)] -> AlphaColour a -> AlphaColour a
affineCombo [(a, AlphaColour a)]
l AlphaColour a
z =
   (AlphaColour a -> AlphaColour a -> AlphaColour a)
-> [AlphaColour a] -> AlphaColour a
forall a. (a -> a -> a) -> [a] -> a
foldl1' AlphaColour a -> AlphaColour a -> AlphaColour a
forall a. Num a => AlphaColour a -> AlphaColour a -> AlphaColour a
rgbaAdd [a -> AlphaColour a -> AlphaColour a
forall a. Num a => a -> AlphaColour a -> AlphaColour a
dissolve a
w AlphaColour a
a | (a
w,AlphaColour a
a) <- (a
1a -> a -> a
forall a. Num a => a -> a -> a
-a
total,AlphaColour a
z)(a, AlphaColour a) -> [(a, AlphaColour a)] -> [(a, AlphaColour a)]
forall a. a -> [a] -> [a]
:[(a, AlphaColour a)]
l]
  where
   total :: a
total = [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([a] -> a) -> [a] -> a
forall a b. (a -> b) -> a -> b
$ ((a, AlphaColour a) -> a) -> [(a, AlphaColour a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, AlphaColour a) -> a
forall a b. (a, b) -> a
fst [(a, AlphaColour a)]
l

--------------------------------------------------------------------------
-- composite
--------------------------------------------------------------------------

class ColourOps f where
 -- |@c1 \`over\` c2@ returns the 'Colour' created by compositing the
 -- 'AlphaColour' @c1@ over @c2@, which may be either a 'Colour' or
 -- 'AlphaColour'.
 over :: (Num a) => AlphaColour a -> f a -> f a
 -- |@darken s c@ blends a colour with black without changing it's opacity.
 --
 -- For 'Colour', @darken s c = blend s c mempty@
 darken :: (Num a) => a -> f a -> f a

instance ColourOps Colour where
 (RGBA (RGB Chan Red a
r0 Chan Green a
g0 Chan Blue a
b0) (Chan a
a0)) over :: AlphaColour a -> Colour a -> Colour a
`over` (RGB Chan Red a
r1 Chan Green a
g1 Chan Blue a
b1) =
   Chan Red a -> Chan Green a -> Chan Blue a -> Colour a
forall a. Chan Red a -> Chan Green a -> Chan Blue a -> Colour a
RGB (Chan Red a -> a -> Chan Red a -> Chan Red a
forall a p. Num a => Chan p a -> a -> Chan p a -> Chan p a
Chan.over Chan Red a
r0 a
a0 Chan Red a
r1)
       (Chan Green a -> a -> Chan Green a -> Chan Green a
forall a p. Num a => Chan p a -> a -> Chan p a -> Chan p a
Chan.over Chan Green a
g0 a
a0 Chan Green a
g1)
       (Chan Blue a -> a -> Chan Blue a -> Chan Blue a
forall a p. Num a => Chan p a -> a -> Chan p a -> Chan p a
Chan.over Chan Blue a
b0 a
a0 Chan Blue a
b1)
 darken :: a -> Colour a -> Colour a
darken a
s (RGB Chan Red a
r Chan Green a
g Chan Blue a
b) = Chan Red a -> Chan Green a -> Chan Blue a -> Colour a
forall a. Chan Red a -> Chan Green a -> Chan Blue a -> Colour a
RGB (a -> Chan Red a -> Chan Red a
forall a p. Num a => a -> Chan p a -> Chan p a
Chan.scale a
s Chan Red a
r)
                            (a -> Chan Green a -> Chan Green a
forall a p. Num a => a -> Chan p a -> Chan p a
Chan.scale a
s Chan Green a
g)
                            (a -> Chan Blue a -> Chan Blue a
forall a p. Num a => a -> Chan p a -> Chan p a
Chan.scale a
s Chan Blue a
b)

instance ColourOps AlphaColour where
 c0 :: AlphaColour a
c0@(RGBA Colour a
_ a0 :: Chan Alpha a
a0@(Chan a
a0')) over :: AlphaColour a -> AlphaColour a -> AlphaColour a
`over` (RGBA Colour a
c1 Chan Alpha a
a1) =
   Colour a -> Chan Alpha a -> AlphaColour a
forall a. Colour a -> Chan Alpha a -> AlphaColour a
RGBA (AlphaColour a
c0 AlphaColour a -> Colour a -> Colour a
forall (f :: * -> *) a.
(ColourOps f, Num a) =>
AlphaColour a -> f a -> f a
`over` Colour a
c1) (Chan Alpha a -> a -> Chan Alpha a -> Chan Alpha a
forall a p. Num a => Chan p a -> a -> Chan p a -> Chan p a
Chan.over Chan Alpha a
a0 a
a0' Chan Alpha a
a1)
 darken :: a -> AlphaColour a -> AlphaColour a
darken a
s (RGBA Colour a
c Chan Alpha a
a) = Colour a -> Chan Alpha a -> AlphaColour a
forall a. Colour a -> Chan Alpha a -> AlphaColour a
RGBA (a -> Colour a -> Colour a
forall (f :: * -> *) a. (ColourOps f, Num a) => a -> f a -> f a
darken a
s Colour a
c) Chan Alpha a
a

-- | 'AlphaColour' forms a monoid with 'over' and 'transparent'.
instance (Num a) => Semigroup (AlphaColour a) where
  <> :: AlphaColour a -> AlphaColour a -> AlphaColour a
(<>) = AlphaColour a -> AlphaColour a -> AlphaColour a
forall a. Monoid a => a -> a -> a
mappend

instance (Num a) => Monoid (AlphaColour a) where
  mempty :: AlphaColour a
mempty = AlphaColour a
forall a. Num a => AlphaColour a
transparent
  mappend :: AlphaColour a -> AlphaColour a -> AlphaColour a
mappend = AlphaColour a -> AlphaColour a -> AlphaColour a
forall (f :: * -> *) a.
(ColourOps f, Num a) =>
AlphaColour a -> f a -> f a
over

-- | @c1 \`atop\` c2@ returns the 'AlphaColour' produced by covering
-- the portion of @c2@ visible by @c1@.
-- The resulting alpha channel is always the same as the alpha channel
-- of @c2@.
--
-- >c1 `atop` (opaque c2) == c1 `over` (opaque c2)
-- >AlphaChannel (c1 `atop` c2) == AlphaChannel c2
atop :: (Fractional a) => AlphaColour a -> AlphaColour a -> AlphaColour a
atop :: AlphaColour a -> AlphaColour a -> AlphaColour a
atop (RGBA Colour a
c0 (Chan a
a0)) (RGBA Colour a
c1 (Chan a
a1)) =
  Colour a -> Chan Alpha a -> AlphaColour a
forall a. Colour a -> Chan Alpha a -> AlphaColour a
RGBA (a -> Colour a -> Colour a
forall (f :: * -> *) a. (ColourOps f, Num a) => a -> f a -> f a
darken a
a1 Colour a
c0 Colour a -> Colour a -> Colour a
forall a. Monoid a => a -> a -> a
`mappend` a -> Colour a -> Colour a
forall (f :: * -> *) a. (ColourOps f, Num a) => a -> f a -> f a
darken (a
1a -> a -> a
forall a. Num a => a -> a -> a
-a
a0) Colour a
c1) (a -> Chan Alpha a
forall p a. a -> Chan p a
Chan a
a1)

-- |'round's and then clamps @x@ between 0 and 'maxBound'.
quantize :: (RealFrac a1, Integral a, Bounded a) => a1 -> a
quantize :: a1 -> a
quantize a1
x | a1
x a1 -> a1 -> Bool
forall a. Ord a => a -> a -> Bool
<= a -> a1
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
l = a
l
           | a -> a1
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
h a1 -> a1 -> Bool
forall a. Ord a => a -> a -> Bool
<= a1
x = a
h
           | Bool
otherwise           = a1 -> a
forall a b. (RealFrac a, Integral b) => a -> b
round a1
x
 where
  l :: a
l = a
forall a. Bounded a => a
minBound
  h :: a
h = a
forall a. Bounded a => a
maxBound

{- Avoid using -}
-- |Returns the opacity of an 'AlphaColour'.
alphaChannel :: AlphaColour a -> a
alphaChannel :: AlphaColour a -> a
alphaChannel (RGBA Colour a
_ (Chan a
a)) = a
a

-- |Returns the colour of an 'AlphaColour'.
-- @colourChannel transparent@ is undefined and may result in @nan@ or an
-- error.
-- Its use is discouraged.
-- If you are desperate, use
--
-- >darken (recip (alphaChannel c)) (c `over` black)
colourChannel :: (Fractional a) => AlphaColour a -> Colour a
colourChannel :: AlphaColour a -> Colour a
colourChannel (RGBA Colour a
c (Chan a
a)) = a -> Colour a -> Colour a
forall (f :: * -> *) a. (ColourOps f, Num a) => a -> f a -> f a
darken (a -> a
forall a. Fractional a => a -> a
recip a
a) Colour a
c

--------------------------------------------------------------------------
-- not for export
--------------------------------------------------------------------------

rgbaAdd :: AlphaColour a -> AlphaColour a -> AlphaColour a
rgbaAdd (RGBA Colour a
c1 Chan Alpha a
a1) (RGBA Colour a
c2 Chan Alpha a
a2) =
  Colour a -> Chan Alpha a -> AlphaColour a
forall a. Colour a -> Chan Alpha a -> AlphaColour a
RGBA (Colour a
c1 Colour a -> Colour a -> Colour a
forall a. Monoid a => a -> a -> a
`mappend` Colour a
c2) (Chan Alpha a
a1 Chan Alpha a -> Chan Alpha a -> Chan Alpha a
forall a p. Num a => Chan p a -> Chan p a -> Chan p a
`Chan.add` Chan Alpha a
a2)