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