1 --                            -*- Mode: Haskell -*- 
    2 -- Copyright 1994 by Peter Thiemann
    3 -- Color.hs --- string converter for colors
    4 -- Author          : Peter Thiemann
    5 -- Created On      : Thu Dec  2 16:58:33 1993
    6 -- Last Modified By: Peter Thiemann
    7 -- Last Modified On: Fri Dec  3 14:13:34 1993
    8 -- Update Count    : 3
    9 -- Status          : Unknown, Use with caution!
   10 -- 
   11 -- $Locker:  $
   12 -- $Log: Color.hs,v $
   13 -- Revision 1.3  1999/01/18 19:38:46  sof
   14 -- Misc (backward compatible) changes to make srcs acceptable
   15 -- to a Haskell 98 compiler.
   16 --
   17 -- Revision 1.2  1996/07/25 21:23:51  partain
   18 -- Bulk of final changes for 2.01
   19 --
   20 -- Revision 1.1  1996/01/08 20:02:35  partain
   21 -- Initial revision
   22 --
   23 -- Revision 1.1  1994/03/15  15:34:53  thiemann
   24 -- Initial revision
   25 --
   26 -- 
   27 
   28 module Color where
   29 -- (Color (..), lookupColor, showsColor, prepareColors)
   30 
   31 import Char -- 1.3
   32 import List ((\\)) -- 1.3
   33 
   34 type Color = (Int, Int, Int)
   35 
   36 noColor :: Color
   37 noColor = (-1, -1, -1)
   38 
   39 {-
   40 readColor :: String -> Color
   41 readColor =  readColor1 . map toLower
   42 
   43 readColor1 :: String -> Color
   44 readColor1 ('b':'l':'a':_) = 0
   45 readColor1 ('b':'l':'u':_) = 1
   46 readColor1 ('g':_)         = 2
   47 readColor1 ('c':_)         = 3
   48 readColor1 ('r':_)         = 4
   49 readColor1 ('m':_)         = 5
   50 readColor1 ('y':_)         = 6
   51 readColor1 ('w':_)         = 7
   52 readColor1 _          = -1
   53 -}
   54 
   55 lookupColor :: String -> [(String, (a, b, c))] -> (a, b, c)
   56 lookupColor colorName colorTable =
   57         head [(r,g,b) | (c,(r,g,b)) <- colorTable, c == map toLower colorName]
   58 
   59 showsColor :: Color -> ShowS
   60 showsColor    (r,g,b) =  showString " (" . shows r . showChar ',' .
   61                                            shows g . showChar ',' .
   62                                            shows b . showChar ')'
   63 
   64 prepareColors rgbFile colors = 
   65         decodeColors (map (map toLower) colors) (fallBackRgb++parsedRgbFile) []
   66   where parsedRgbFile =  (map parseLine (lines rgbFile))
   67 
   68 decodeColors [] parsedRgbFile decoded = decoded
   69 decodeColors clrs [] decoded = [(name,(128,128,128)) | name <- clrs ]++decoded
   70 decodeColors clrs ((r,g,b,name):parsedRgbFile) decoded
   71         = decodeColors (clrs \\ found) parsedRgbFile (foundDecoded++decoded)
   72         where found = [ c | c <- clrs, name == c ]
   73               foundDecoded = [ (c,(r,g,b)) | c <- found ]
   74 
   75 parseLine str = let (r,restr):_ = reads{-was:readDec-} (skipWhite str)
   76                     (g,restg):_ = reads{-was:readDec-} (skipWhite restr)
   77                     (b,restb):_ = reads{-was:readDec-} (skipWhite restg)
   78                     name = skipWhite restb
   79                 in  (r,g,b,name)
   80   where skipWhite = dropWhile isSpace
   81 
   82 fallBackRgb :: [(Int,Int,Int,String)]
   83 fallBackRgb  = [
   84         (  0,  0,  0,"black"),
   85         (  0,  0,255,"blue"),
   86         (  0,255,  0,"green"),
   87         (  0,255,255,"cyan"),
   88         (255,  0,  0,"red"),
   89         (255,  0,255,"magenta"),
   90         (255,255,  0,"yellow"),
   91         (255,255,255,"white")]
   92 
   93 showsPsColor (r,g,b) =  showChar ' ' . shows r .
   94                         showChar ' ' . shows g .
   95                         showChar ' ' . shows b .
   96                         showString " scol"
   97 
   98 showsFigColor (r,g,b) = showChar ' ' . shows (minPosition 0 (-1,32768*32768)
   99         [ (x-r)*(x-r) + (y-g)*(y-g) + (z-b)*(z-b) | (x,y,z,_) <- fallBackRgb ])
  100 
  101 --
  102 -- find position of minimal element in list
  103 --
  104 minPosition i (pos,min) []       = pos
  105 minPosition i (pos,min) (x:rest) | x < min   = minPosition (i+1) (i,x)     rest
  106                                  | otherwise = minPosition (i+1) (pos,min) rest