A Haskell program I wrote as a CGI for a website I did some time ago.

Colors.hs

module Main where

import Char
import Data.List
import Text.JSON

import System ( getArgs )

data RGBColor = RGB Double Double Double deriving (Show, Eq)
data XYZColor = XYZ Double Double Double deriving (Show, Eq)
data LABColor = LAB Double Double Double deriving (Show, Eq)
data PolarColor = Polar Double Double Double  deriving (Show, Eq)

class Color a where
  toRGB   :: a -> RGBColor
  toXYZ   :: a -> XYZColor 
  toLAB   :: a -> LABColor  
  toPolar :: a -> PolarColor

instance Color XYZColor where
  toRGB (XYZ x y z) = RGB (3.240479*x - 1.537150*y - 0.498535*z)
                           (-0.969256*x + 1.875992*y + 0.041556*z)
                            (0.055648*x - 0.204043*y + 1.057311*z)
  toLAB (XYZ x y z) = LAB (116.0*y' - 16.0) (500.0*(x'-y')) (200.0*(y'-z'))
        where x'' = x/wpX
              y'' = y/wpY
              z'' = z/wpZ
              XYZ wpX wpY wpZ = xyzWhitePoint
              f v = if v > labE 
                        then exp (log (v) / 3.0)
                        else (labK * v + 16.0) / 116.0
              x' = f x''
              y' = f y''
              z' = f z''

  toXYZ = id

  toPolar = toPolar . toLAB

instance Color RGBColor where
  toXYZ (RGB r g b) = XYZ (0.412453*r + 0.357580*g + 0.180423*b)
                            (0.212671*r + 0.715160*g + 0.072169*b)
                            (0.019334*r + 0.119193*g + 0.950227*b)
  toRGB = id
  toPolar = toPolar . toXYZ 
  toLAB = toLAB . toXYZ

  
                

instance Color LABColor where
  toXYZ (LAB l a b) = XYZ (x * wpX) (y * wpY) (z * wpZ)
        where y = if l > labK * labE
                        then exp (log ((l + 16.0)/116.0) * 3.0)
                        else l / labK
              y' = if y > labE 
                        then (l+16.0)/116.0 
                        else (labK * y + 16.0)/116.0
              x' = a/500.0 + y'
              z' = y' - b/200.0
              clip v = if (v*v*v > labE) then v*v*v else (116.0*v-16.0)/labK
              x = clip x'
              z = clip z'
              XYZ wpX wpY wpZ = xyzWhitePoint
  toPolar (LAB l a b) = if l > 0 then Polar l h c else Polar l 0 0
        where   h = huemod ((atan2 b a) / pi * 3)
                c = sqrt (a*a + b*b) / l                                                        
  toLAB = id
  toRGB = toRGB . toXYZ  
                                             
instance Color PolarColor where              
  toLAB (Polar l h c) = LAB l a b
        where a = cos (h/3*pi) * c * l
              b = sin (h/3*pi) * c * l
  toRGB = toRGB . toLAB
  toXYZ = toXYZ . toLAB
  toPolar = id              


fhex s = fx (reverse s)
  where fx [] = 0
        fx (c:t) = (hd c) + 16 * fx t
        hd c    | c `elem` ['0'..'9'] = (ord c) - (ord '0')
                | c `elem` ['a'..'f'] = (ord c) - (ord 'a') + 10 
                | c `elem` ['A'..'F'] = (ord c) - (ord 'A') + 10
                | otherwise = 0
                
fromhex ('#' : hex) = fromhex hex
fromhex hex = RGB r g b
        where   [r,g,b] = map mf [rs,gs,bs]
                mf = ungamma . (/sc) . fromInteger . toInteger . fhex
                l = div (length hex) 3
                sc = 16^l-1
                (rs,h1) = splitAt l hex
                (gs,bs) = splitAt l h1

huemod h | (h >= 6) = huemod (h - 6)
         | (h <  0) = huemod (h + 6)
         | otherwise  = h
          
xyzWhitePoint = toXYZ (RGB 1 1 1)

labE = 216.0/24389.0
labK = 24389.0/27.0

gamma :: Double -> Double
gamma c = if c <= 0.0031308 
                then 12.92 * c 
                else (1+a)*(exp (e * log c)) - a
        where e = (1/2.4)
              a = 0.055 
              
ungamma c = if c <= 0.04045 
                then c / 12.92 
                else exp (2.4 * log ((c+a)/(1+a)))
        where a = 0.055                              

s255 = (min 255) . (max 0) . round . (*255) . gamma

hexify v = [hexdigit (rem (div v 16) 16), hexdigit (rem v 16)]
        where hexdigit d = "0123456789ABCDEF" !! d 

--edgedistance :: (Color a) => a -> Double
--outofgamut   :: (Color a) => Double -> a -> Bool
--hex          :: (Color a) => a -> String

edgedistance c = foldr max 0 [ -r, r-1, -g, g-1, -b, b-1 ]
        where (RGB r g b) = toRGB c
        
outofgamut prec c = edgedistance c > prec

hex c = foldl (++) "#" (map sx [r,g,b])
        where sx = hexify . s255
              (RGB r g b) = toRGB c
              
safehex c | outofgamut 0.00001 c = Nothing
          | otherwise            = Just (hex c)

rotatehue rot clr = Polar l (huemod (h+rot)) c
        where (Polar l h c) = toPolar clr  

dim factor clr = Polar (l*factor) h c
        where (Polar l h c) = toPolar clr
        
saturate factor clr = Polar l h (c*factor)
        where (Polar l h c) = toPolar clr  

applymod lm1 lm2 hm cm clr = Polar ((100-l)*lm1 + l*lm2) (h+hm) (c*cm)
        where (Polar l h c) = toPolar clr

dandc f x1 x2 diff = if (abs (x2 - x1) > diff)
                        then if f(x) then dandc f x1 x diff
                                     else dandc f x x2 diff 
                        else x1 
        where x = (x2+x1)/2

dandc' f x1 x2 diff = if (abs (x2 - x1) > diff)
                        then if f(x) then [(x1,x,x2)] ++ (dandc' f x1 x diff)
                                     else [(x1,x,x2)] ++ (dandc' f x x2 diff) 
                        else ([(x1,x,x2)]) 
        where x = (x2+x1)/2

satcheck clr = (\x -> outofgamut 0 (Polar l h x))
        where (Polar l h c) = toPolar clr 

lumcheck clr = (\x -> outofgamut 0 (Polar x h c))
        where (Polar l h c) = toPolar clr 

maxsat clr = Polar l h maxs
        where   (Polar l h c) = toPolar clr
                maxs = dandc (satcheck clr) 0 8 0.001
                
maxlum clr = Polar maxl h c
        where   (Polar l h c) = toPolar clr
                maxl = dandc (lumcheck clr) 0 125 0.01
        
rgbmax clr = foldr1 max [r,g,b]
        where (RGB r g b) = toRGB clr

rgbmin clr = foldr1 min [r,g,b]
        where (RGB r g b) = toRGB clr

mincheck clr = f 
        where f x = not (x2 > 0.1/255)
                where   x2 = rgbmax t
                        x1 = rgbmin t
                        t = maxsat (Polar x h c)
                        (Polar l h c) = toPolar clr     
                                
maxcheck clr = f 
        where f x = not (x1 > 1 - (0.1/255))
                where   x2 = rgbmax t
                        x1 = rgbmin t
                        t = maxsat (Polar x h c)
                        (Polar l h c) = toPolar clr     

minmax clr = maxsat (Polar maxl h c)
        where maxl = dandc (mincheck clr) 125 0 0.001
              (Polar l h c) = toPolar clr

sRGB r g b = RGB (ungamma r) (ungamma g) (ungamma b)

huedata = [     ("red",         sRGB 1.00 0.00 0.00),
                ("coral",       sRGB 1.00 0.25 0.00),
                ("orange",      sRGB 1.00 0.50 0.00),
                ("tangerine",   sRGB 1.00 0.75 0.00),
                ("yellow",      sRGB 1.00 1.00 0.00),
                ("peridot",     sRGB 0.75 1.00 0.00),
                ("green",       sRGB 0.00 1.00 0.00),
                ("mint",        sRGB 0.00 1.00 0.75),
                ("cyan",        sRGB 0.00 1.00 1.00),
                ("sky",         sRGB 0.00 0.75 1.00),
                ("azure",       sRGB 0.00 0.50 1.00),
                ("blue",        sRGB 0.00 0.00 1.00),
                ("royal",       sRGB 0.25 0.00 1.00),
                ("violet",      sRGB 0.50 0.00 1.00),
                ("plum",        sRGB 0.75 0.00 1.00),
                ("magenta",     sRGB 1.00 0.00 1.00),
                ("berry",       sRGB 1.00 0.00 0.75),
                ("pink",        sRGB 1.00 0.00 0.50),
                ("cherry",      sRGB 1.00 0.00 0.25),
                ("white",       sRGB 1.00 1.00 1.00),
                ("black",       sRGB 0.00 0.00 0.00),
                ("gray",        sRGB 0.50 0.50 0.50)
        ]
        
huediff' h1 h2 = foldr1 min [ abs(h1-h2), abs(h1-h2+6), abs(h1-h2-6) ]

huediff clr1 clr2 = huediff' h1 h2
        where   (Polar l1 h1 c1) = toPolar clr1
                (Polar l2 h2 c2) = toPolar clr2 
                                              
lumdiff clr1 clr2 = sqrt ((l1-l2)^2)
        where   (Polar l1 h1 c1) = toPolar clr1
                (Polar l2 h2 c2) = toPolar clr2 

colorname clr = best
        where   (Polar l h c) = toPolar clr
                (best,_) = minimumBy cmp 
                        [ (n,distance clr cc) | (n,cc) <- huedata ]  
                cmp (_,v1) (_,v2) = compare v1 v2

blend p clr1 clr2 = LAB (l1*p + l2*q) (a1*p + a2*q) (b1*p + b2*q)
        where   (LAB l1 a1 b1) = toLAB clr1
                (LAB l2 a2 b2) = toLAB clr2
                q = 1.0 - p

distance clr1 clr2 = sumsq [ l1-l2, a1-a2, b1-b2 ]
        where   (LAB l1 a1 b1) = toLAB clr1
                (LAB l2 a2 b2) = toLAB clr2
                sumsq = foldr1 (+) . (map (\x -> x*x)) 

sdistance s clr1 clr2 = sumsq [ l1-l2, s*(a1-a2), s*(b1-b2) ]
        where   (LAB l1 a1 b1) = toLAB clr1
                (LAB l2 a2 b2) = toLAB clr2
                sumsq = foldr1 (+) . (map (\x -> x*x)) 

allcolors = [ sRGB (r/255.0) (g/255.0) (b/255.0) | 
                r<-[0..255], g<-[0..255], b<-[0..255] ]
                
gamutedge = (nub . concat) ( [ map (toPolar . ($x)) [ry,yg,gc,cb,bm,mr] | x <- [0..255] ] )
        where ry x = sRGB 1 (x/255.0) 0
              yg x = sRGB (1-x/255.0) 1 0
              gc x = sRGB 0 1 (x/255.0)
              cb x = sRGB 0 (1-x/255.0) 1
              bm x = sRGB (x/255.0) 0 1
              mr x = sRGB 1 0 (1-x/255.0)
              
fastset n = [ toPolar (sRGB (r/n) (g/n) (b/n)) |
                        r<-[0..n], g<-[0..n], b<-[0..n] ]                               

lum clr = l where (Polar l h c) = toPolar clr
sat clr = c where (Polar l h c) = toPolar clr
hue clr = h where (Polar l h c) = toPolar clr

huegt h1 h2 = (huemod (h1 - h2) < 3)
huelt h1 h2 = (huemod (h2 - h1) < 3)

hleft clr1 clr2 = huelt h1 h2
        where (Polar l1 h1 c1) = toPolar clr1
              (Polar l2 h2 c2) = toPolar clr2  

hright clr1 clr2 = huegt h1 h2
        where (Polar l1 h1 c1) = toPolar clr1
              (Polar l2 h2 c2) = toPolar clr2  

pure clr = if (c > 0.00001) then best else LAB 100 0 0
        where (_,cl1) = minimumBy cf (filter ((hleft clr)  . snd) sset)
              (_,cl2) = minimumBy cf (filter ((hright clr) . snd) sset)
              h1 = hue cl1
              h2 = hue cl2
              best = if (cl1 == cl2) then toLAB cl1 
                else blend ((h2-h)/(h2-h1)) cl1 cl2
              sset = [ ((huediff clr c),c) | c <- gamutedge ]
              cf (d1,_) (d2,_) = compare d1 d2
              (Polar l h c) = toPolar clr

maxcontrast clr = best
        where (_,best) = maximumBy cf sset
              sset = [ ((lumdiff clr c),c) | c <- black:white:gamutedge ]
              black = Polar 0 0 0
              white = Polar 100 0 0
              cf (d1,_) (d2,_) = compare d1 d2
              (Polar l h c) = toPolar clr
                            
purelist = sortBy cmp [ (lum c, hue c) | c <- gamutedge ]
        where cmp (_, h1) (_, h2) = compare h1 h2

main::IO()
main = do 
          args <- getArgs
          let c = fromhex (head args)
          putStrLn (output c)

output cc = (encode . JSObject . toJSObject) 
                [("color", JSString (toJSString (hex cc))),
                    ("name", JSString (toJSString (colorname cc))),
                    ("info", (colorinfo)),
                    ("maintable", (tr (genmaintable cc))),
                    ("huetable", (tr (genhuetable cc))),
                    ("sattable", (tr (gensattable cc))),
                    ("lumtable", (tr (genlumtable cc)))
                   ]
        where tr :: (Color t) => [[t]] -> JSValue
              tr = JSArray . (map (JSArray . map (f . safehex)))
              f Nothing  = JSNull
              f (Just x) = JSString (toJSString x)
              colorinfo = JSObject (toJSObject [ (t,JSRational True (toRational v)) 
                        | (t,v) <- [("lum",l),("hue",h),("sat",c)] ])
              (Polar l h c) = toPolar cc


maintablecols :: (Color t) => [t -> LABColor]
maintablecols = map (\x -> x ) 
                [ blend 0.5 white,
                  blend 0.4 white,
                  blend 0.3 white,
                  blend 0.2 white,
                  blend 0.1 white,
                  toLAB,
                  blend 0.1 black,
                  blend 0.2 black,
                  blend 0.3 black,
                  blend 0.4 black,
                  blend 0.5 black,
                  pure,
                  blend 0.5 (gray 75) . pure ]
        where   white = LAB 1 0 0
                black = LAB 0 0 0
                gray l = LAB l 0 0                  

maintablerows = id : [ rotatehue (x*0.5) | x <- [1..11] ]

--maintablegen = f (f maintablecols) maintablerows
--        where f a b = zipWith ($) a (repeat b)
        
pushIn a b = zipWith ($) a (repeat b)           
  
genmaintable = map (pushIn maintablecols) . (pushIn maintablerows) . toPolar

genhuetable c = [ row1, row2 ]
        where   row1 = [ (maxsat (rotatehue (0.03*i) c)) | i <- [-8..8] ]
                row2 = [ (maxsat (rotatehue (3+0.03*i) c)) | i <- [-8..8] ]

gensattable c = [ row1, row2 ]
        where   row1 = [ (saturate (0.10+i*0.075) c) | i <- [0..15] ]
                row2 = map (maxlum) row1
                
genlumtable c = [ row1, row2 ]
        where   row1 = [ dim (0.10+i*0.075) c | i <- [0..15] ]
                row2 = map maxsat row1