-----------------------------------------------------------------------------
-- |
-- Module      :  Palette.Harmony
-- Copyright   :  (c) 2013 Jeffrey Rosenbluth
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  jeffrey.rosenbluth@gmail.com
--
-- Utility functions to creating color schemes.
--
-----------------------------------------------------------------------------

module Data.Colour.Palette.Harmony
       ( -- * Choosing color schemes

        -- ** Synonym for Colour Double

           Kolor

         -- ** Color utilities

         , tint, tone, shade, sliders, rotateColor

         -- ** Color harmonies

         , monochrome
         , complement
         , triad
         , tetrad
         , analogic
         , accentAnalogic
         , bwg
         , colorRamp

       ) where

import           Data.Colour
import           Data.Colour.Names
import           Data.Colour.Palette.Types
import           Data.Colour.RGBSpace.HSV
import           Data.Colour.SRGB          (RGB (..), sRGB, toSRGB)

-- > import Data.Colour.Palette.Harmony
-- > import Data.Colour.SRGB (sRGB24read)
-- > wheel [] = circle 1 # fc black
-- > wheel cs = wheel' # rotateBy r
-- >   where
-- >     wheel' = mconcat $ zipWith fc cs (iterateN n (rotateBy a) w)
-- >     n = length cs
-- >     a = 1 / (fromIntegral n) :: Turn
-- >     w = wedge 1 (0 :: Turn) a # lw 0
-- >     r = 1/4 - 1/(2*(fromIntegral n))
-- > base = sRGB24read "#95a78d"
-- > mono = wheel $ monochrome base
-- > comp = wheel $ complement base
-- > tria = wheel $ triad base
-- > tetr = wheel $ tetrad base
-- > anal = wheel $ analogic base
-- > acce = wheel $ accentAnalogic base
-- > bw = wheel $ bwg base

-- This function and it's inverse below are the key to using the artists'
-- pigment color wheel. Red, blue and yellow are the primary colors and the
-- corresponding secondary colors are green, oragne and violet. We convert a
-- hue from the HSV in degrees (red = 0) to a hue on the artists' color wheel.
hsvToRyb :: Double -> Double
hsvToRyb :: Double -> Double
hsvToRyb Double
x
  | Double
x forall a. Ord a => a -> a -> Bool
< Double
35    =       Double
1.71 forall a. Num a => a -> a -> a
*  Double
x
  | Double
x forall a. Ord a => a -> a -> Bool
< Double
60    = Double
60  forall a. Num a => a -> a -> a
+ Double
2.40 forall a. Num a => a -> a -> a
* (Double
x forall a. Num a => a -> a -> a
- Double
35)
  | Double
x forall a. Ord a => a -> a -> Bool
< Double
135   = Double
120 forall a. Num a => a -> a -> a
+ Double
0.80 forall a. Num a => a -> a -> a
* (Double
x forall a. Num a => a -> a -> a
- Double
60)
  | Double
x forall a. Ord a => a -> a -> Bool
< Double
225   = Double
180 forall a. Num a => a -> a -> a
+ Double
0.67 forall a. Num a => a -> a -> a
* (Double
x forall a. Num a => a -> a -> a
- Double
135)
  | Double
x forall a. Ord a => a -> a -> Bool
< Double
275   = Double
240 forall a. Num a => a -> a -> a
+ Double
1.20 forall a. Num a => a -> a -> a
* (Double
x forall a. Num a => a -> a -> a
- Double
225)
  | Bool
otherwise = Double
300 forall a. Num a => a -> a -> a
+ Double
0.71 forall a. Num a => a -> a -> a
* (Double
x forall a. Num a => a -> a -> a
- Double
275)

-- Convert of hue on the artists color wheel to a hue in HSV space.
rybToHsv :: Double -> Double
rybToHsv :: Double -> Double
rybToHsv Double
x
  | Double
x forall a. Ord a => a -> a -> Bool
< Double
60    =       Double
0.58 forall a. Num a => a -> a -> a
*  Double
x
  | Double
x forall a. Ord a => a -> a -> Bool
< Double
120   = Double
35  forall a. Num a => a -> a -> a
+ Double
0.42 forall a. Num a => a -> a -> a
* (Double
x forall a. Num a => a -> a -> a
- Double
60)
  | Double
x forall a. Ord a => a -> a -> Bool
< Double
180   = Double
60  forall a. Num a => a -> a -> a
+ Double
1.25 forall a. Num a => a -> a -> a
* (Double
x forall a. Num a => a -> a -> a
- Double
120)
  | Double
x forall a. Ord a => a -> a -> Bool
< Double
240   = Double
135 forall a. Num a => a -> a -> a
+ Double
1.50 forall a. Num a => a -> a -> a
* (Double
x forall a. Num a => a -> a -> a
- Double
180)
  | Double
x forall a. Ord a => a -> a -> Bool
< Double
300   = Double
225 forall a. Num a => a -> a -> a
+ Double
0.83 forall a. Num a => a -> a -> a
* (Double
x forall a. Num a => a -> a -> a
- Double
240)
  | Bool
otherwise = Double
275 forall a. Num a => a -> a -> a
+ Double
1.42 forall a. Num a => a -> a -> a
* (Double
x forall a. Num a => a -> a -> a
- Double
300)

-- Rotate a hue on the RYB color wheel.
rotateHue :: Double -> Double -> Double
rotateHue :: Double -> Double -> Double
rotateHue Double
h Double
degrees =  Double -> Double
rybToHsv (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
k)
  where
    k :: Int
k = (forall a b. (RealFrac a, Integral b) => a -> b
round forall a b. (a -> b) -> a -> b
$ Double -> Double
hsvToRyb Double
h forall a. Num a => a -> a -> a
+ Double
degrees :: Int) forall a. Integral a => a -> a -> a
`mod` Int
360

-- | Rotate a color and apply one function to its saturation and another to its value.
sliders :: Kolor -> Double -> (Double -> Double)
       -> (Double -> Double) -> Kolor
sliders :: Kolor
-> Double -> (Double -> Double) -> (Double -> Double) -> Kolor
sliders Kolor
c Double
rot Double -> Double
fs Double -> Double
fv = forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
sRGB Double
r Double
g Double
b
  where
    (Double
h, Double
s, Double
v) = forall a. (Fractional a, Ord a) => RGB a -> (a, a, a)
hsvView (forall b. (Ord b, Floating b) => Colour b -> RGB b
toSRGB Kolor
c)
    h' :: Double
h' = Double -> Double -> Double
rotateHue Double
h Double
rot
    s' :: Double
s' = forall a. Ord a => a -> a -> a
max Double
0 (forall a. Ord a => a -> a -> a
min Double
1 (Double -> Double
fs Double
s))
    v' :: Double
v' = forall a. Ord a => a -> a -> a
max Double
0 (forall a. Ord a => a -> a -> a
min Double
1 (Double -> Double
fv Double
v))
    RGB Double
r Double
g Double
b = forall a. (RealFrac a, Ord a) => a -> a -> a -> RGB a
hsv Double
h' Double
s' Double
v'

-- | Rotate a color on the RYB color wheel
rotateColor :: Double -> Kolor -> Kolor
rotateColor :: Double -> Kolor -> Kolor
rotateColor Double
degrees Kolor
c  = forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
sRGB Double
r Double
g Double
b
  where
    (Double
h, Double
s, Double
v) = forall a. (Fractional a, Ord a) => RGB a -> (a, a, a)
hsvView (forall b. (Ord b, Floating b) => Colour b -> RGB b
toSRGB Kolor
c)
    RGB Double
r Double
g Double
b = forall a. (RealFrac a, Ord a) => a -> a -> a -> RGB a
hsv (Double -> Double -> Double
rotateHue Double
h Double
degrees) Double
s Double
v

-- | Tints a color by adding blending t * white + (1 - t) color.
--   t should be between 0 and 1.
tint :: Double -> Kolor -> Kolor
tint :: Double -> Kolor -> Kolor
tint Double
t = forall a (f :: * -> *).
(Num a, AffineSpace f) =>
a -> f a -> f a -> f a
blend Double
t forall a. (Ord a, Floating a) => Colour a
white

-- | Alter the tone of a color by adding blending t * gray + (1 - t) color.
--   t should be between 0 and 1.
tone :: Double -> Kolor -> Kolor
tone :: Double -> Kolor -> Kolor
tone Double
t = forall a (f :: * -> *).
(Num a, AffineSpace f) =>
a -> f a -> f a -> f a
blend Double
t forall a. (Ord a, Floating a) => Colour a
gray

-- | Shades a color by adding blending s * black + (1 - t) color.
--   t should be between 0 and 1.
shade :: Double -> Kolor -> Kolor
shade :: Double -> Kolor -> Kolor
shade Double
t = forall a (f :: * -> *).
(Num a, AffineSpace f) =>
a -> f a -> f a -> f a
blend Double
t forall a. Num a => Colour a
black

-- | Create a monochromatic set of 5 colors based in the input color.
-- <<diagrams/src_Data_Colour_Palette_Harmony_mono.svg#diagram=mono&width=200>>
monochrome :: Kolor -> [Kolor]
monochrome :: Kolor -> [Kolor]
monochrome Kolor
c = [Kolor
c, Double -> Kolor -> Kolor
tint Double
0.25 Kolor
c, Double -> Kolor -> Kolor
tone Double
0.5 Kolor
c, Double -> Kolor -> Kolor
shade Double
0.5 Kolor
c, Double -> Kolor -> Kolor
shade Double
0.75 Kolor
c]

-- | A color harmony using the base color and its opposite.
-- <<diagrams/src_Data_Colour_Palette_Harmony_comp.svg#diagram=comp&width=200>>
complement :: Kolor -> [Kolor]
complement :: Kolor -> [Kolor]
complement Kolor
c = [Kolor
c, Double -> Kolor -> Kolor
shade Double
0.5 Kolor
d, Double -> Kolor -> Kolor
tint Double
0.25 Kolor
c, Double -> Kolor -> Kolor
shade Double
0.75 Kolor
c, Kolor
d]
  where d :: Kolor
d = Double -> Kolor -> Kolor
rotateColor Double
180 Kolor
c

-- | A color chord based on three equally spaced hues.
-- <<diagrams/src_Data_Colour_Palette_Harmony_tria.svg#diagram=tria&width=200>>
triad :: Kolor -> [Kolor]
triad :: Kolor -> [Kolor]
triad Kolor
c = [ Kolor
c, Double -> Kolor -> Kolor
rotateColor Double
240 Kolor
c, Double -> Kolor -> Kolor
shade Double
0.5 forall a b. (a -> b) -> a -> b
$ Double -> Kolor -> Kolor
rotateColor Double
210 Kolor
c
          , Double -> Kolor -> Kolor
shade Double
0.35 forall a b. (a -> b) -> a -> b
$ Double -> Kolor -> Kolor
rotateColor Double
120 Kolor
c, Double -> Kolor -> Kolor
shade Double
0.67 Kolor
c]

-- | Scheme based on 4 colors on a rectangle incscribed in the RYB color
--   wheel.
-- <<diagrams/src_Data_Colour_Palette_Harmony_tetr.svg#diagram=tetr&width=200>>
tetrad :: Kolor -> [Kolor]
tetrad :: Kolor -> [Kolor]
tetrad Kolor
c = [ Kolor
c, Double -> Kolor -> Kolor
rotateColor Double
180 Kolor
c, Double -> Kolor -> Kolor
tone Double
0.25 forall a b. (a -> b) -> a -> b
$ Double -> Kolor -> Kolor
rotateColor Double
30 Kolor
c
           , Double -> Kolor -> Kolor
shade Double
0.5 forall a b. (a -> b) -> a -> b
$ Double -> Kolor -> Kolor
rotateColor Double
210 Kolor
c, Double -> Kolor -> Kolor
tone Double
0.5 forall a b. (a -> b) -> a -> b
$ Double -> Kolor -> Kolor
rotateColor Double
180 Kolor
c]

-- | Chord base on three adjacent colors on the artists color wheel.
-- <<diagrams/src_Data_Colour_Palette_Harmony_anal.svg#diagram=anal&width=200>>
analogic :: Kolor -> [Kolor]
analogic :: Kolor -> [Kolor]
analogic Kolor
c = [ Kolor
c,  Double -> Kolor -> Kolor
shade Double
0.3 forall a b. (a -> b) -> a -> b
$ Double -> Kolor -> Kolor
rotateColor Double
330 Kolor
c, Double -> Kolor -> Kolor
tone Double
0.25 forall a b. (a -> b) -> a -> b
$ Double -> Kolor -> Kolor
rotateColor Double
30 Kolor
c
             , Double -> Kolor -> Kolor
rotateColor Double
330 Kolor
c, Double -> Kolor -> Kolor
tone Double
0.5 Kolor
c]

-- | Analogic chord plus the color opposite to the base color.
-- <<diagrams/src_Data_Colour_Palette_Harmony_acce.svg#diagram=acce&width=200>>
accentAnalogic :: Kolor -> [Kolor]
accentAnalogic :: Kolor -> [Kolor]
accentAnalogic Kolor
c = [ Kolor
c, Double -> Kolor -> Kolor
tint Double
0.5 forall a b. (a -> b) -> a -> b
$ Double -> Kolor -> Kolor
rotateColor Double
180 Kolor
c
                   , Double -> Kolor -> Kolor
tone Double
0.25 forall a b. (a -> b) -> a -> b
$ Double -> Kolor -> Kolor
rotateColor Double
30 Kolor
c, Double -> Kolor -> Kolor
rotateColor Double
330 Kolor
c
                   , Double -> Kolor -> Kolor
rotateColor Double
180 Kolor
c]

-- | Black, white and gray with a touch of the base color added.
-- <<diagrams/src_Data_Colour_Palette_Harmony_bw.svg#diagram=bw&width=200>>
bwg :: Kolor -> [Kolor]
bwg :: Kolor -> [Kolor]
bwg Kolor
c = [Kolor
c, Double -> Kolor -> Kolor
tint Double
0.8 Kolor
c, Double -> Kolor -> Kolor
tone Double
0.8 Kolor
c, Double -> Kolor -> Kolor
shade Double
0.9 Kolor
c]

-- | Interpolate n colors from a list of colors using linear piecewise
-- interpolation to add additional colors to a palette.
colorRamp :: Int -> [Kolor] -> [Kolor]
colorRamp :: Int -> [Kolor] -> [Kolor]
colorRamp Int
n [Kolor]
xs0 = if Int
n forall a. Ord a => a -> a -> Bool
<= forall (t :: * -> *) a. Foldable t => t a -> Int
length [Kolor]
xs0 then forall a. Int -> [a] -> [a]
take Int
n [Kolor]
xs0 else forall a. Int -> [a] -> [a]
take Int
n (forall {f :: * -> *}.
AffineSpace f =>
Double -> [f Double] -> [f Double]
go Double
0 [Kolor]
xs0)
  where
    di :: Double
di = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Kolor]
xs0 forall a. Num a => a -> a -> a
- Int
1) forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
n forall a. Num a => a -> a -> a
- Int
1)
    go :: Double -> [f Double] -> [f Double]
go Double
_ [f Double
x] = [f Double
x]
    go Double
i xs' :: [f Double]
xs'@(f Double
x1 : xs :: [f Double]
xs@(f Double
x2 : [f Double]
_))
        | Double
i forall a. Ord a => a -> a -> Bool
> Double
1 = Double -> [f Double] -> [f Double]
go (Double
i forall a. Num a => a -> a -> a
- Double
1) [f Double]
xs
        | Bool
otherwise = forall a (f :: * -> *).
(Num a, AffineSpace f) =>
a -> f a -> f a -> f a
blend Double
i f Double
x2 f Double
x1 forall a. a -> [a] -> [a]
: Double -> [f Double] -> [f Double]
go (Double
i forall a. Num a => a -> a -> a
+ Double
di) [f Double]
xs'
    go Double
_ [f Double]
_ = []