-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.Color.HSV
-- Copyright   :  (c) 2013 Brent Yorgey
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  byorgey@cis.upenn.edu
--
-- Utilities for working with color in HSV space.
--
-- Right now, the only utility is a function for blending colors in
-- HSV space.  This has the effect of \"travelling around the color
-- wheel\", which can be especially nice when one wants to blend
-- smoothly from one color to another (blending in RGB space can tend
-- to travel across some icky brown/grey colors).
--
-----------------------------------------------------------------------------

module Diagrams.Color.HSV
       ( hsvBlend
       ) where

import           Data.Colour              (Colour)
import           Data.Colour.RGBSpace     (uncurryRGB)
import           Data.Colour.RGBSpace.HSV (hsv, hsvView)
import           Data.Colour.SRGB         (sRGB, toSRGB)
import           Data.List                (minimumBy)
import           Data.Ord                 (comparing)

-- | Blend two colors in HSV space---that is, linearly interpolate
--   between their hues, saturations, and values independently
--   (wrapping around appropriately in the case of hue).  In
--   particular, @hsvBlend a c1 c2@ is like doing @(a-1)*c1 + a*c2@ in
--   HSV space.  That is, a parameter of @0@ results in only the first
--   color; @1@ results in only the second color; and anything in
--   between results in a blend.
hsvBlend :: RealFloat n => n -> Colour n -> Colour n -> Colour n
hsvBlend :: forall n. RealFloat n => n -> Colour n -> Colour n -> Colour n
hsvBlend n
t Colour n
c1 Colour n
c2 = (n -> n -> n -> Colour n) -> RGB n -> Colour n
forall a b. (a -> a -> a -> b) -> RGB a -> b
uncurryRGB n -> n -> n -> Colour n
forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
sRGB (RGB n -> Colour n)
-> ((n, n, n) -> RGB n) -> (n, n, n) -> Colour n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (n, n, n) -> RGB n
forall {a}. RealFrac a => (a, a, a) -> RGB a
hsv3
                 ((n, n, n) -> Colour n) -> (n, n, n) -> Colour n
forall a b. (a -> b) -> a -> b
$ (n -> n -> n -> n -> n
forall n. RealFrac n => n -> n -> n -> n -> n
lerpWrap n
h1 n
h2 n
360 n
t, n -> n -> n -> n
forall n. Num n => n -> n -> n -> n
lerp' n
s1 n
s2 n
t, n -> n -> n -> n
forall n. Num n => n -> n -> n -> n
lerp' n
v1 n
v2 n
t)
  where
    [(n
h1,n
s1,n
v1), (n
h2,n
s2,n
v2)] = (Colour n -> (n, n, n)) -> [Colour n] -> [(n, n, n)]
forall a b. (a -> b) -> [a] -> [b]
map (RGB n -> (n, n, n)
forall a. (Fractional a, Ord a) => RGB a -> (a, a, a)
hsvView (RGB n -> (n, n, n))
-> (Colour n -> RGB n) -> Colour n -> (n, n, n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Colour n -> RGB n
forall b. (Ord b, Floating b) => Colour b -> RGB b
toSRGB) [Colour n
c1,Colour n
c2]
    hsv3 :: (a, a, a) -> RGB a
hsv3 (a
h,a
s,a
v) = a -> a -> a -> RGB a
forall a. (RealFrac a, Ord a) => a -> a -> a -> RGB a
hsv a
h a
s a
v

lerpWrap :: (RealFrac n) => n -> n -> n -> n -> n
lerpWrap :: forall n. RealFrac n => n -> n -> n -> n -> n
lerpWrap n
a n
b n
m n
t = n -> n -> n -> n
forall n. Num n => n -> n -> n -> n
lerp' n
a n
b' n
t n -> n -> n
forall n. RealFrac n => n -> n -> n
`dmod` n
m
  where
    b' :: n
b' = (n -> n -> Ordering) -> [n] -> n
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy ((n -> n) -> n -> n -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (n -> n
forall a. Num a => a -> a
abs (n -> n) -> (n -> n) -> n -> n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> n -> n
forall a. Num a => a -> a -> a
subtract n
a)) [n
b n -> n -> n
forall a. Num a => a -> a -> a
- n
m, n
b, n
b n -> n -> n
forall a. Num a => a -> a -> a
+ n
m]

-- | Interpolate linearly between two values.  The third argument is
--   the parameter.  A parameter of @0@ results in the first argument;
--   with a parameter of @1@, @lerp'@ returns its second argument.
lerp' :: Num n => n -> n -> n -> n
lerp' :: forall n. Num n => n -> n -> n -> n
lerp' n
a n
b n
t = (n
1 n -> n -> n
forall a. Num a => a -> a -> a
- n
t) n -> n -> n
forall a. Num a => a -> a -> a
* n
a n -> n -> n
forall a. Num a => a -> a -> a
+ n
t n -> n -> n
forall a. Num a => a -> a -> a
* n
b

dmod :: RealFrac n => n -> n -> n
dmod :: forall n. RealFrac n => n -> n -> n
dmod n
a n
m = n
a n -> n -> n
forall a. Num a => a -> a -> a
- n
m n -> n -> n
forall a. Num a => a -> a -> a
* Integer -> n
forall a. Num a => Integer -> a
fromInteger (n -> Integer
forall b. Integral b => n -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (n
an -> n -> n
forall a. Fractional a => a -> a -> a
/n
m))