{-# OPTIONS_GHC -fno-warn-type-defaults #-}
-- remove the two benign defaults

-- | A simple color module for handling RGB and HSV representations of colors.
module Data.Color (
  -- * Datatypes
    RGB(..)
  , HSV(..)
  , rgbToHex
  , hsvToHex

  -- ** Predefined colors
  , red
  , green
  , blue
  
  -- ** Conversions
  , rgbToGray
  , hsvToGray
  , rgbToHSV
  , hsvToRGB

  -- * Color Palettes
  , colorGroups
  , lightColorGroups

) where

{- IDEA: Provide color datastructure together with nice and usable color
 -       palettes for reporting various data
 -}

import Numeric (showHex)

-- import Text.XHtml.Strict
-- import Text.XHtml.Table

data RGB a = RGB {
    rgbR :: !a
  , rgbG :: !a
  , rgbB :: !a
  }
  deriving( Eq, Ord )

instance Show a => Show (RGB a) where
  show (RGB r g b) = "RGB("++show r++", "++show g++", "++show b++")"

instance Functor RGB where
  fmap f (RGB r g b) = RGB (f r) (f g) (f b)

red, green, blue :: Fractional t => RGB t
red   = RGB 1.0 0.0 0.0
green = RGB 0.0 1.0 0.0
blue  = RGB 0.0 0.0 1.0

data HSV a = HSV {
    hsvH :: !a
  , hsvS :: !a
  , hsvV :: !a
  }
  deriving( Eq, Ord )

instance Show a => Show (HSV a) where
  show (HSV h s v) = "HSV("++show h++", "++show s++", "++show v++")"

instance Functor HSV where
  fmap f (HSV h s v) = HSV (f h) (f s) (f v)


------------------------------------------------------------------------------
-- Colorspace conversion
------------------------------------------------------------------------------

-- | RGB to HSV conversion.
-- Pre: 0 <= r,g,b <= 1
-- (Source: http://de.wikipedia.org/wiki/HSV-Farbraum)
rgbToHSV :: (Fractional t, Ord t) => RGB t -> HSV t
rgbToHSV (RGB r g b) = HSV h' s v
  where
  ub = max r (max g b)
  lb = min r (min g b)

  h  | ub == lb  = 0
     | ub == r   = 60 * (    (g-b)/(ub-lb))
     | ub == g   = 60 * (2 + (b-r)/(ub-lb))
     | otherwise = 60 * (4 + (r-g)/(ub-lb))

  h' | h < 0 = h + 360 
     | otherwise = h

  s  | ub == 0   = 0
     | otherwise = (ub-lb)/ub

  v  = ub

-- | HSV to RGB conversion.
-- Pre: 0 <= h <= 360 and 0 <= s,v <= 1
-- (Source: http://de.wikipedia.org/wiki/HSV-Farbraum)
hsvToRGB :: RealFrac t => HSV t -> RGB t
hsvToRGB (HSV h s v) = case hIdx of
  0 -> RGB v t p
  1 -> RGB q v p
  2 -> RGB p v t
  3 -> RGB p q v
  4 -> RGB t p v
  5 -> RGB v p q
  _ -> error "hsvToRGB: hue outside of range [0..360]"
  where
  hIdx = floor (h / 60)
  f    = h/60 - fromIntegral (hIdx::Int)
  p    = v*(1-s)
  q    = v*(1-s*f)
  t    = v*(1-s*(1-f))

hsvToGray :: Num t => HSV t -> HSV t
hsvToGray (HSV h _ v) = HSV h 0 v

rgbToGray :: Ord t => RGB t -> t
rgbToGray (RGB r g b) = max r (max g b)

------------------------------------------------------------------------------
-- String output
------------------------------------------------------------------------------

-- | Hexadecimal representation of an RGB value
rgbToHex :: RealFrac t => RGB t -> String
rgbToHex (RGB r g b) = ('#':) . showHex' r . showHex' g . showHex' b $ ""
  where showHex' f
	  | i <= 15   = ('0':) . showHex i
	  | otherwise = showHex i
	  where 
          i :: Int
          i = max 0 (min 255 (floor (256 * f)))

-- | Hexadecimal representation of an HSV value; i.e., of its corresponding RGB
-- value.
hsvToHex :: RealFrac t => HSV t -> [Char]
hsvToHex = rgbToHex . hsvToRGB


------------------------------------------------------------------------------
-- HSV Color Palettes
------------------------------------------------------------------------------

data ColorParams t = ColorParams {
    cpScale   :: !t
  , cpZeroHue :: !t
  , cpVBottom :: !t
  , cpVRange  :: !t
  , cpSBottom :: !t
  , cpSRange  :: !t
  }
  deriving( Eq, Ord, Show )

-- | From a list of group sizes build a function assigning every element a
-- unique color, nicely distributed such that they are well differentiated both
-- using color and monochrome displays.
genColorGroups :: RealFrac t => 
                  ColorParams t 
               -> [Int]                -- ^ List of group sizes.
               -> [((Int,Int),(HSV t))]
genColorGroups (ColorParams { 
	      cpScale = scale 
	    , cpZeroHue = zeroHue 
	    , cpVBottom = vBot, cpVRange = vRan
	    , cpSBottom = sBot, cpSRange = sRan
	    }) groups = 
  do
    (groupIdx, groupSize) <- zip [0.. ] groups
    elemIdx <- [0..groupSize - 1]
    let h = toShiftedGroupHue groupIdx (fromIntegral elemIdx / fromIntegral groupSize)
        v = vBot + vRan * toGroupHue groupIdx (fromIntegral elemIdx / fromIntegral groupSize)
        s = sBot + sRan * toGroupHue groupIdx (fromIntegral elemIdx / fromIntegral groupSize)
        color = HSV (360*h) s v 
    return ((groupIdx, elemIdx), color)
  where
    nGroups :: Int
    nGroups = length groups

    toGroupHue g h = (
      fromIntegral g    + -- base position
      0.5 * (1 - scale) + -- left margin
            (h * scale)   -- position in margin
      ) / (fromIntegral nGroups)
   
    toShiftedGroupHue g h =
      snd . properFraction $ toGroupHue g h + 1 + 
      (zeroHue/360) - toGroupHue 0 0.5


-- | A good default style for the 'genColorGroups' color palette function. The
-- parameter shifts the hue for the first group.
colorGroupStyle :: Double -> ColorParams Double
colorGroupStyle zeroHue = ColorParams {
    cpScale   = 0.6
  , cpZeroHue = zeroHue
  , cpVBottom = 0.75, cpVRange = 0.2
  , cpSBottom = 0.4,  cpSRange = 0.00
  }

-- | Build color groups according to the list of group sizes using the default
-- 'colorGroupStyle' for the function 'genColorGroups'.
colorGroups :: Double -> [Int] -> [((Int, Int), HSV Double)]
colorGroups zeroHue = genColorGroups (colorGroupStyle zeroHue)


-- | A good light color style for the @genColorGroups@ color palette
-- function. The parameter shifts the hue for the first group.
lightColorGroupStyle :: Double -> ColorParams Double
lightColorGroupStyle zeroHue = ColorParams {
    cpScale   = 0.6
  , cpZeroHue = zeroHue
  , cpVBottom = 0.8, cpVRange = 0.15
  , cpSBottom = 0.3,  cpSRange = 0.00
  }

-- | Build color groups according to the list of group sizes using the
-- default light 'lightColorGroupStyle' for the function
-- 'genColorGroups'.
lightColorGroups :: Double -> [Int] -> [((Int, Int), HSV Double)]
lightColorGroups zeroHue = genColorGroups (lightColorGroupStyle zeroHue)


------------------------------------------------------------------------------
-- Testing: Html Table with group colors
------------------------------------------------------------------------------

{-

colorTable :: Double -> (HSV Double -> HSV Double) -> [Int] -> Html
colorTable zeroHue conv groups = 
  table . toHtml . besides $ map col [0..length groups-1]
  where
  col i = aboves [cell $ (td ! [getStyle i j]) (stringToHtml (show (i,j)))
                 | j <- [0..(groups !! i) - 1] ]
  color = colorGroups zeroHue groups
  getStyle i j = thestyle ("background-color: "++ hsvToHex (conv $ color i j))

colorFile :: Double -> FilePath -> [Int] -> IO ()
colorFile zeroHue outF groups = do
  let html = colorTable zeroHue id        groups +++
             colorTable zeroHue hsvToGray groups
  writeFile outF $ prettyHtml html

-}