-----------------------------------------------------------------------------
-- |
-- 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 = forall a b. (a -> a -> a -> b) -> RGB a -> b
uncurryRGB forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
sRGB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. RealFrac a => (a, a, a) -> RGB a
hsv3
                 forall a b. (a -> b) -> a -> b
$ (forall n. RealFrac n => n -> n -> n -> n -> n
lerpWrap n
h1 n
h2 n
360 n
t, forall n. Num n => n -> n -> n -> n
lerp' n
s1 n
s2 n
t, 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)] = forall a b. (a -> b) -> [a] -> [b]
map (forall a. (Fractional a, Ord a) => RGB a -> (a, a, a)
hsvView forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) = 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 = forall n. Num n => n -> n -> n -> n
lerp' n
a n
b' n
t forall n. RealFrac n => n -> n -> n
`dmod` n
m
  where
    b' :: n
b' = forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (forall a. Num a => a -> a
abs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a -> a
subtract n
a)) [n
b forall a. Num a => a -> a -> a
- n
m, n
b, n
b 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 forall a. Num a => a -> a -> a
- n
t) forall a. Num a => a -> a -> a
* n
a forall a. Num a => a -> a -> a
+ n
t 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 forall a. Num a => a -> a -> a
- n
m forall a. Num a => a -> a -> a
* forall a. Num a => Integer -> a
fromInteger (forall a b. (RealFrac a, Integral b) => a -> b
floor (n
aforall a. Fractional a => a -> a -> a
/n
m))