Copyright (C) 1994, Digital Equipment Corp.Created by stolfi on Wed Apr 19 01:48:27 1989
MODULEColorName EXPORTSColorName ,ColorNameF ; IMPORT Color, ISOChar, Text, TextF, TextList, TextListSort, TextIntTbl, TextRefTbl; FROM ColorNameTable IMPORT Basic; TYPE FrEntry = RECORD name: TEXT; val: REAL END; (* Entry of fraction table *) CONST Fraction = ARRAY OF FrEntry{ (* Fraction prefixes: *) (* Note: if A is a prefix of B, then A must come after B. *) (* Also the last prefix must be "" *) FrEntry {name := "VeryVeryVery", val := 15.0 / 16.0}, FrEntry {name := "VeryVerySlightly", val := 1.0 / 16.0 }, FrEntry {name := "VeryVery", val := 7.0 / 8.0 }, FrEntry {name := "VerySlightly", val := 1.0 / 8.0 }, FrEntry {name := "Very", val := 3.0 / 4.0 }, FrEntry {name := "Slightly", val := 1.0 / 4.0 }, FrEntry {name := "Somewhat", val := 3.0 / 8.0 }, FrEntry {name := "Quite", val := 5.0 / 8.0 }, FrEntry {name := "Rather", val := 1.0 / 2.0 }, FrEntry {name := "", val := 1.0 / 3.0 } }; PROCEDUREIsPrefix (a, b: TEXT; VAR (*OUT*) rest: TEXT): BOOLEAN = (* If /a/ is a prefix of /b/ (ignoring case), return TRUE and put rest of /b/ in /rest/. Else return false and leave /rest/alone. *) BEGIN <* ASSERT a # NIL *> <* ASSERT b # NIL *> WITH aa = a^, bb = b^ DO IF NUMBER (aa) <= 1 THEN rest := b; RETURN TRUE ELSIF NUMBER (bb) < NUMBER (aa) THEN RETURN FALSE ELSE FOR i := 0 TO LAST (aa) - 1 DO IF ISOChar.Lower [aa [i]] # ISOChar.Lower [bb [i]] THEN RETURN FALSE END END; rest := Text.FromChars ( SUBARRAY (bb, NUMBER (aa) - 1, NUMBER (bb) - NUMBER (aa))); RETURN TRUE END END END IsPrefix; PROCEDURENormalizeName (a: TEXT): TEXT = (* Deletes all whitespace in /a/ and converts to lower case *) VAR b := NEW (REF ARRAY OF CHAR, Text.Length (a)); j := 0; BEGIN IF NUMBER (b^) > 0 THEN FOR i := 0 TO LAST (a^) - 1 DO IF NOT a [i] IN ISOChar.Spaces THEN b [j] := ISOChar.Lower [a [i]]; INC (j) END END END; RETURN Text.FromChars (SUBARRAY (b^, 0, j)) END NormalizeName; PROCEDUREToRGB (name: TEXT): Color.T RAISES {NotFound} = VAR value : REFANY; rgb : Color.T; rgbRef: REF Color.T; PROCEDURE fail (<* UNUSED *> name: TEXT): Color.T RAISES {NotFound} = BEGIN RAISE NotFound END fail; BEGIN LOCK nameCache DO IF nameCache.table.get (name, value) THEN RETURN NARROW (value, REF Color.T)^ END END; WITH normalized = NormalizeName (name) DO rgb := LowerCaseToRGB (normalized, fail) END; LOCK nameCache DO rgbRef := NEW (REF Color.T); rgbRef^ := rgb; EVAL nameCache.table.put (name, rgbRef); END; RETURN rgb END ToRGB; PROCEDURELowerCaseToRGB (name: TEXT; p: NotInTable): Color.T RAISES {NotFound} = VAR f : CARDINAL; index : INTEGER; y, frac : REAL; rgb : Color.T; hsv : Color.HSV; bare, rest: TEXT; BEGIN (* Strips fraction modifier: *) f := 0; WHILE NOT IsPrefix (Fraction [f].name, name, rest) DO INC (f) END; frac := Fraction [f].val; bare := rest; (* Strips color modifier: *) IF IsPrefix ("dark", bare, rest) OR IsPrefix ("dim", bare, rest) THEN rgb := LowerCaseToRGB (rest, p); RETURN Mix (Color.Black, frac, rgb, 1.0 - frac) ELSIF IsPrefix ("pale", bare, rest) OR IsPrefix ("light", bare, rest) THEN rgb := LowerCaseToRGB (rest, p); RETURN Mix (Color.White, frac, rgb, 1.0 - frac) ELSIF IsPrefix ("medium", bare, rest) THEN (* There must be no fraction modifier: *) IF NOT Text.Equal (bare, name) THEN RAISE NotFound END; frac := 0.25; rgb := LowerCaseToRGB (rest, p); RETURN Mix (Color.Black, frac, rgb, 1.0 - frac) ELSIF IsPrefix ("reddish", bare, rest) THEN rgb := LowerCaseToRGB (rest, p); RETURN Mix (Color.Red, frac, rgb, 1.0 - frac) ELSIF IsPrefix ("greenish", bare, rest) THEN rgb := LowerCaseToRGB (rest, p); RETURN Mix (Color.Green, frac, rgb, 1.0 - frac) ELSIF IsPrefix ("bluish", bare, rest) THEN rgb := LowerCaseToRGB (rest, p); RETURN Mix (Color.Blue, frac, rgb, 1.0 - frac) ELSIF IsPrefix ("yellowish", bare, rest) THEN rgb := LowerCaseToRGB (rest, p); RETURN Mix (Color.Yellow, frac, rgb, 1.0 - frac) ELSIF IsPrefix ("drab", bare, rest) OR IsPrefix ("dull", bare, rest) OR IsPrefix ("weak", bare, rest) THEN rgb := LowerCaseToRGB (rest, p); y := Color.Brightness (rgb); RETURN Mix (Color.T {y, y, y}, frac, rgb, 1.0 - frac) ELSIF IsPrefix ("strong", bare, rest) OR IsPrefix ("vivid", bare, rest) OR IsPrefix ("bright", bare, rest) THEN rgb := LowerCaseToRGB (rest, p); hsv := Color.HSV {Color.ToHSV (rgb).h, 1.0, 1.0}; RETURN Mix (Color.FromHSV (hsv), frac, rgb, 1.0 - frac) ELSE (* No color modifier -- there must be no fraction modifier: *) IF NOT Text.Equal (bare, name) THEN RAISE NotFound END; IF NOT table.get (name, index) THEN RETURN p (name) ELSE RETURN Basic [index].rgb END END END LowerCaseToRGB; PROCEDUREMix (READONLY a : Color.T; alpha: REAL; READONLY b : Color.T; beta : REAL ): Color.T = BEGIN RETURN Color.T{r := alpha * a.r + beta * b.r, g := alpha * a.g + beta * b.g, b := alpha * a.b + beta * b.b} END Mix; PROCEDURENameList (): TextList.T = VAR list: TextList.T := NIL; BEGIN FOR i := FIRST (Basic) TO LAST (Basic) DO list := TextList.Cons (Basic [i].name, list); END; RETURN TextListSort.SortD (list) END NameList; PROCEDUREInit () = BEGIN nameCache := NEW (Cache, table := NEW (TextRefTbl.Default).init (16)); table := NEW (TextIntTbl.Default).init (NUMBER (Basic)); FOR i := 0 TO LAST (Basic) DO IF table.put (NormalizeName (Basic [i].name), i) THEN (* ignore duplicates (case-variants) *) END; END END Init; BEGIN Init (); <* ASSERT Text.Empty (Fraction [LAST (Fraction)].name) *> END ColorName.