add hsv support (#27)

* added `hsv`, `hsva`, `toHSVA`

Author: safareli

src/Color.purs

@@ -23,13 +23,16 @@ module Color
   , rgb'
   , hsla
   , hsl
+  , hsva
+  , hsv
   , xyz
   , lab
   , lch
   , fromHexString
   , fromInt
   -- Convert
   , toHSLA
+  , toHSVA
   , toRGBA
   , toRGBA'
   , toXYZ
@@ -160,22 +163,40 @@ rgba' r g b a = rgba (round $ r * 255.0)
 rgb' :: Number -> Number -> Number -> Color
 rgb' r g b = rgba' r g b 1.0
 
--- | Create a `Color` from hue, saturation, lightness and alpha values. The
--- | hue is given in degrees, as a `Number` between 0.0 and 360.0. Saturation,
--- | lightness and alpha are numbers between 0.0 and 1.0.
+-- | Create a `Color` from Hue, Saturation, Lightness and Alpha values. The
+-- | Hue is given in degrees, as a `Number` between 0.0 and 360.0. Saturation,
+-- | Lightness and Alpha are numbers between 0.0 and 1.0.
 hsla :: Number -> Number -> Number -> Number -> Color
 hsla h s l a = HSLA h' s' l' a'
   where h' = if h == 360.0 then h else h `modPos` 360.0
         s' = clamp 0.0 1.0 s
         l' = clamp 0.0 1.0 l
         a' = clamp 0.0 1.0 a
 
--- | Create a `Color` from hue, saturation and lightness values. The hue is
--- | given in degrees, as a `Number` between 0.0 and 360.0. Both saturation and
--- | lightness are numbers between 0.0 and 1.0.
+-- | Create a `Color` from Hue, Saturation and Lightness values. The Hue is
+-- | given in degrees, as a `Number` between 0.0 and 360.0. Both Saturation and
+-- | Lightness are numbers between 0.0 and 1.0.
 hsl :: Number -> Number -> Number -> Color
 hsl h s l = hsla h s l 1.0
 
+-- | Create a `Color` from Hue, Saturation, Value and Alpha values. The
+-- | Hue is given in degrees, as a `Number` between 0.0 and 360.0. Saturation,
+-- | Value and Alpha are numbers between 0.0 and 1.0.
+hsva :: Number → Number → Number → Number → Color
+hsva h s   0.0 a = HSLA h (s / (2.0 - s)) 0.0 a
+hsva h 0.0 1.0 a = HSLA h 0.0 1.0 a
+hsva h s'  v'  a = HSLA h s l a
+  where
+    tmp = (2.0 - s') * v'
+    s = s' * v' / (if tmp < 1.0 then tmp else 2.0 - tmp)
+    l = tmp / 2.0
+
+-- | Create a `Color` from Hue, Saturation and Value values. The Hue is
+-- | given in degrees, as a `Number` between 0.0 and 360.0. Both Saturation and
+-- | Value are numbers between 0.0 and 1.0.
+hsv :: Number → Number → Number → Color
+hsv h s v = hsva h s v 1.0
+
 -- | Create a `Color` from XYZ coordinates in the CIE 1931 color space. Note
 -- | that a `Color` always represents a color in the sRGB gamut (colors that
 -- | can be represented on a typical computer screen) while the XYZ color space
@@ -273,11 +294,22 @@ fromInt m = rgb r g b
         r = (n `shr` 16) .&. 0xff
         n = clamp 0 0xffffff m
 
--- | Convert a `Color` to its hue, saturation, lightness and alpha values. See
+-- | Convert a `Color` to its Hue, Saturation, Lightness and Alpha values. See
 -- | `hsla` for the ranges of each channel.
 toHSLA :: Color -> { h :: Number, s :: Number, l :: Number, a :: Number }
 toHSLA (HSLA h s l a) = { h, s, l, a }
 
+-- | Convert a `Color` to its Hue, Saturation, Value and Alpha values. See
+-- | `hsva` for the ranges of each channel.
+toHSVA :: Color -> { h :: Number, s :: Number, v :: Number, a :: Number }
+toHSVA (HSLA h s   0.0 a) = { h, s: 2.0 * s / (1.0 + s), v: 0.0, a }
+toHSVA (HSLA h 0.0 1.0 a) = { h, s: 0.0, v: 1.0, a }
+toHSVA (HSLA h s'  l'  a) = { h, s, v, a }
+  where
+    tmp = s' * (if l' < 0.5 then l' else 1.0 - l')
+    s = 2.0 * tmp / (l' + tmp)
+    v = l' + tmp
+
 -- | Convert a `Color` to its red, green, blue and alpha values. The RGB values
 -- | are integers in the range from 0 to 255. The alpha channel is a number
 -- | between 0.0 and 1.0.

test/Main.purs

@@ -1,7 +1,8 @@
 module Test.Main where
 
 import Prelude
-import Color (Color, ColorSpace(..), rgb', toHexString, toRGBA, toHSLA, saturate, lighten, white, black, graytone, mix, rgb, distance, textColor, contrast, luminance, brightness, fromInt, toGray, desaturate, darken, complementary, rotateHue, rgba, cssStringRGBA, hsla, cssStringHSLA, hsl, fromHexString, lch, toLCh, lab, toLab, xyz, toXYZ)
+
+import Color (Color, ColorSpace(..), rgb', toHexString, toRGBA, toHSLA, toHSVA, saturate, lighten, white, black, graytone, mix, rgb, distance, textColor, contrast, luminance, brightness, fromInt, toGray, desaturate, darken, complementary, rotateHue, rgba, cssStringRGBA, hsla, cssStringHSLA, hsl, hsva, fromHexString, lch, toLCh, lab, toLab, xyz, toXYZ)
 import Color.Blending (BlendMode(..), blend)
 import Color.Scale (grayscale, sample, colors, uniformScale, colorStop, colorScale)
 import Color.Scheme.X11 (orangered, seagreen, yellow, red, blue, magenta, hotpink, purple, pink, darkslateblue, aquamarine, cyan, green, lime)
@@ -24,20 +25,20 @@ import Test.Unit.Main (runTest)
 almostEqual :: forall e. Color -> Color -> Aff e Unit
 almostEqual expected actual =
   if almostEqual' expected actual then success
-  else failure $ "\n    expected: " <> show expected <>
-                 "\n    got:      " <> show actual
-
- where
-   abs n = if n < 0 then 0 - n else n
-   aE n1 n2 = abs (n1 - n2) <= 1
-   almostEqual' col1 col2 =
-     aE c1.r c2.r &&
-     aE c1.g c2.g &&
-     aE c1.b c2.b
-
-     where
-       c1 = toRGBA col1
-       c2 = toRGBA col2
+  else failure $ "\n    expected: " <> show' expected <>
+                 "\n    got:      " <> show' actual
+  where
+    show' c = case toHSLA c of
+      {h, s, l, a} -> cssStringRGBA c <> " " <> cssStringHSLA c
+    abs n = if n < 0 then 0 - n else n
+    aE n1 n2 = abs (n1 - n2) <= 1
+    almostEqual' col1 col2 =
+      aE c1.r c2.r &&
+      aE c1.g c2.g &&
+      aE c1.b c2.b
+      where
+        c1 = toRGBA col1
+        c2 = toRGBA col2
 
 main :: forall e. Eff (console :: CONSOLE, testOutput :: TESTOUTPUT, avar :: AVAR | e) Unit
 main = runTest do
@@ -123,6 +124,27 @@ main = runTest do
       hue <- 0 .. 360
       pure $ xyzRoundtrip (toNumber hue) 0.2 0.8
 
+  test "hsv / toHSV (HSV -> HSL -> HSV, HSL -> HSV -> HSL)" do
+    let
+      hsvRoundtrip h' s' l_v' a' = do
+        almostEqual colorIn1 colorOut1
+        almostEqual colorIn2 colorOut2
+        where
+          colorIn1 = hsla h' s' l_v' a'
+          colorIn2 = hsva h' s' l_v' a'
+          colorOut1 = case toHSVA colorIn1 of { h, s, v, a } -> hsva h s v a
+          colorOut2 = case toHSVA colorIn2 of { h, s, v, a } -> hsva h s v a
+    sequence_ do
+      hue <- 0 .. 3
+      saturation <- 0 .. 5
+      lightness <- 0 .. 5
+      [ hsvRoundtrip 90.0 (toNumber saturation / 5.0) 1.0 1.0
+      , hsvRoundtrip 90.0 1.0 (toNumber lightness / 5.0) 1.0
+      , hsvRoundtrip 90.0 (toNumber saturation / 5.0) 0.0 1.0
+      , hsvRoundtrip 90.0 0.0 (toNumber lightness / 5.0) 1.0
+      , hsvRoundtrip (toNumber (hue * 90)) (toNumber saturation / 5.0) (toNumber lightness / 5.0)  1.0
+      ]
+
   test "lab / toLab (Lab -> HSL -> Lab)" do
     let labRoundtrip h' s' l' =
           case toLab col of