DIRECTORY
Basics USING [BITSHIFT],
ImagerColorPrivate USING [HSL],
IO USING [Close, EndOfStream, GetTokenRope, RIS, STREAM],
Rope USING [Concat, Length, ROPE],
SymTab USING [Create, Fetch, Insert, Ref];

ImagerColorNamesImpl: CEDAR PROGRAM
IMPORTS Basics, IO, Rope, SymTab
EXPORTS ImagerColorPrivate
~ BEGIN OPEN ImagerColorPrivate;

ROPE: TYPE ~ Rope.ROPE;

UndefinedName: PUBLIC SIGNAL = CODE;
BadGrammar: PUBLIC SIGNAL = CODE;

Word: TYPE ~ {
black, gray, white, -- achromatic "hue"
red, orange, brown, yellow, green, cyan, blue, purple, magenta, -- hue
weak, moderate, strong, vivid, -- saturation
dark, medium, light, -- lightness
very -- general-purpose adverb
};
Achromatic: TYPE ~ Word[black..white];
Hue: TYPE ~ Word[red..magenta];
Saturation: TYPE ~ Word[weak..vivid];
Lightness: TYPE ~ Word[dark..light];

NameArray: TYPE ~ ARRAY Word OF ARRAY BOOL OF ROPE;

names: REF NameArray ~ NEW[NameArray _ [
black: ["black", NIL],
gray: ["gray", "grayish"],
white: ["white", NIL],
red: ["red", "reddish"],
orange: ["orange", "orangish"],
brown: ["brown", "brownish"],
yellow: ["yellow", "yellowish"],
green: ["green", "greenish"],
cyan: ["cyan", "cyanish"],
blue: ["blue", "bluish"],
purple: ["purple", "purplish"],
magenta: ["magenta", "magentaish"],
weak: ["weak", "weakish"],
moderate: ["moderate", NIL],
strong: ["strong", "strongish"],
vivid: ["vivid", NIL],
dark: ["dark", "darkish"],
medium: ["medium", NIL],
light: ["light", "lightish"],
very: ["very", NIL]
]];

HSLArray: TYPE ~ ARRAY Word[black..light] OF HSL;

hslFromWord: REF HSLArray ~ NEW[HSLArray _ [
black: [0, 0, 0.0],
gray: [0, 0, 0.4],
white: [0, 0, 1.0],
red: [0.0, 0.6, 0.4],
orange: [0.04, 0.6, 0.4],
brown: [0.08, 0.6, 0.2],
yellow: [0.1667, 0.6, 0.4],
green: [0.3333, 0.6, 0.4],
cyan: [0.4999, 0.6, 0.4],
blue: [0.6666, 0.6, 0.4],
purple: [0.73, 0.6, 0.4],
magenta: [0.8333, 0.6, 0.4],
weak: [0, 0.3, 0],
moderate: [0, 0.6, 0],
strong: [0, 0.8, 0],
vivid: [0, 1.0, 0],
dark: [0, 0, 0.2],
medium: [0, 0, 0.4],
light: [0, 0, 0.7]
]];

defaultSaturation: Word ~ moderate;
defaultLightness: Word ~ medium;
averageSaturation: REAL ~ hslFromWord[moderate].s;
averageLightness: REAL ~ hslFromWord[medium].l;

vocabulary: SymTab.Ref ~ BuildVocabulary[];

Val: TYPE ~ REF Token;
Token: TYPE ~ RECORD[word: Word, ish: BOOL];

BuildVocabulary: PROC RETURNS[SymTab.Ref] ~ {
vocabulary: SymTab.Ref ~ SymTab.Create[mod: 41, case: FALSE];
Insert: PROC[key: ROPE, word: Word, ish: BOOL] ~ {
val: Val ~ NEW[Token _ [word: word, ish: ish]];
inserted: BOOL ~ SymTab.Insert[x: vocabulary, key: key, val: val];
IF NOT inserted THEN ERROR;
};
FOR ish: BOOL IN BOOL DO
FOR word: Word IN Word DO
key: ROPE ~ names[word][ish];
IF key#NIL THEN Insert[key: key, word: word, ish: ish];
ENDLOOP;
ENDLOOP;
Insert[key: "Grey", word: gray, ish: FALSE];
Insert[key: "Greyish", word: gray, ish: TRUE];
Insert[key: "Violet", word: purple, ish: FALSE];
Insert[key: "Bright", word: vivid, ish: FALSE];
RETURN[vocabulary];
};

TokenListFromName: PROC[name: ROPE] RETURNS[list: LIST OF Token _ NIL] ~ {
stream: IO.STREAM ~ IO.RIS[name];
DO key: ROPE; val: REF; found: BOOL;
[token: key] _ IO.GetTokenRope[stream ! IO.EndOfStream => EXIT];
IF Rope.Length[key]<2 THEN LOOP;
[found: found, val: val] _ SymTab.Fetch[x: vocabulary, key: key];
IF found THEN list _ CONS[NARROW[val, Val]^, list]
ELSE ERROR UndefinedName;
ENDLOOP;
IO.Close[stream];
};

WeightedValue: TYPE ~ RECORD[val, ave, weight: REAL, first: BOOL];

Adjust: PROC[w: WeightedValue, new: REAL, ish: BOOL] RETURNS[WeightedValue] ~ {
IF w.first THEN {
IF ish THEN w.val _ w.ave+.6666*(new-w.val) ELSE w.val _ new;
w.first _ FALSE;
}
ELSE {
w.weight _ w.weight*(IF ish THEN 0.3333 ELSE 0.5); -- weaken weight if ishy
w.val _ w.val+w.weight*(new-w.ave);
IF w.val<0 THEN w.val _ 0 ELSE IF w.val>1 THEN w.val _ 1;
};
RETURN[w];
};

HSLFromName: PUBLIC PROC[name: ROPE] RETURNS[HSL] ~ {
tokenList: LIST OF Token ~ TokenListFromName[name]; -- rightmost token is first in list
prev: Token;
h, hueMin, hueMid, hueMax, hueUpper, hueLower: REAL;
s: WeightedValue _ [val: 0, ave: averageSaturation, weight: 1, first: TRUE];
l: WeightedValue _ [val: 0, ave: averageLightness, weight: 1, first: TRUE];
hDefined: BOOL _ FALSE;
secondHue: BOOL _ TRUE;
IF tokenList=NIL THEN ERROR BadGrammar; -- empty name
FOR list: LIST OF Token _ tokenList, list.rest UNTIL list=NIL DO
token: Token _ list.first;
IF list=tokenList THEN { -- rightmost token
[h, s.val, l.val] _ hslFromWord[token.word];
IF token.ish THEN ERROR BadGrammar; -- name can't end with -ish
SELECT token.word FROM
IN Achromatic => NULL;
IN Hue => { -- other hues must be in same third of color wheel
hueMid _ hueLower _ hueUpper _ h;    
hueMin _ h - 0.3334;    
hueMax _ h + 0.3334;
hDefined _ TRUE;
};
ENDCASE => ERROR BadGrammar; -- final word must name a color
}
ELSE { -- a modifier
mh, ms, ml: REAL _ 0; -- h, s, l of modifier
IF token.word=very THEN token _ prev;
[mh, ms, ml] _ hslFromWord[token.word];
SELECT token.word FROM
IN Hue => {
IF ms#0 AND hDefined THEN { -- modify hue
factor: REAL ~ IF token.ish THEN 0.3333 ELSE 0.5;
IF mh>hueMax THEN mh _ mh-1 -- get continuum
ELSE IF mh<hueMin THEN mh _ mh+1;
IF mh IN[hueMin..hueMax] THEN {
IF secondHue THEN { -- reset admissable range
IF mh<hueMid THEN {
hueMin _ hueLower _ mh;  
hueMax _ hueUpper _ hueMid;
}
ELSE {
hueMax _ hueUpper _ mh;  
hueMin _ hueLower _ hueMid;
};
secondHue _ FALSE;
};
IF h < mh THEN {
hueLower _ h;
h _ h + factor * (hueUpper - h);
};
IF h > mh THEN {
hueUpper _ h;
h _ h + factor * (hueLower - h);
};
}
ELSE ERROR BadGrammar; -- new hue too distant from original hue
}
ELSE IF ms#0 THEN { -- mixing with gray, 1st hue
h _ mh;
hueMid _ hueLower _ hueUpper _ h;    
hueMin _ h - 0.3333;    
hueMax _ h + 0.6667;  
};
IF ms#s.val THEN s.val _ (s.val+ms)/2; -- interpolate saturation
IF ml#l.val THEN l.val _ (l.val+ml)/2; -- interpolate lightness
};
IN Saturation => s _ Adjust[s, ms, token.ish];
IN Lightness => l _ Adjust[l, ml, token.ish];
ENDCASE => ERROR;
};
prev _ token;
ENDLOOP;
IF NOT hDefined THEN s.val _ 0;
IF h<0 THEN h _ h+1 ELSE IF h>1 THEN h _ h-1;
RETURN[[h, s.val, l.val]];
};


NameFromHSL: PUBLIC PROC[hsl: HSL, level: NAT _ 3] RETURNS[ROPE] = {
h: REAL ~ hsl.h;
s: REAL _ hsl.s;
l: REAL ~ hsl.l;
epsilon: REAL ~ 1.0 / Basics.BITSHIFT[1, level+1]; -- differences less than this are insignificant
list: LIST OF Token _ NIL;
Cons: PROC[word: Word, ish: BOOL _ FALSE] ~ { list _ CONS[[word, ish], list] };
ConsAdjustment: PROC[lower, upper: Word, value: REAL, level: NAT] ~ {
token, lastToken: Token;
approximation, adjustment: REAL _ 0.5;
IF (value >= 1.0 - epsilon) OR (value <= epsilon) THEN RETURN;
FOR i: NAT IN[0..level-1) DO
delta: REAL ~ ABS[value - approximation];
half: REAL ~ adjustment/2;
third: REAL ~ adjustment/3;
IF delta <= epsilon THEN EXIT;
token.ish _ ABS[ABS[delta] - third] < ABS[ABS[delta] - half];
IF token.ish THEN adjustment _ third ELSE adjustment _ half;
IF value < approximation 
THEN { token.word _ lower; approximation _ approximation - adjustment }
ELSE { token.word _ upper; approximation _ approximation + adjustment };
IF i>0 AND token=lastToken THEN Cons[very] ELSE Cons[token.word, token.ish];
lastToken _ token;
ENDLOOP;
};
IF l <= epsilon THEN Cons[black]
ELSE IF l >= (1-epsilon) THEN Cons[white]
ELSE {
upper, lower: Word _ black;
t: REAL _ 0; -- huePlaceInInterval
IF s <= epsilon THEN { Cons[gray]; s _ 0 } -- Achromatic
ELSE { -- get bounding hues
hUpper: REAL _ 1.5;
hLower: REAL _ -.5;
FOR name: Word IN Hue DO
hue: REAL _ hslFromWord[name].h;
IF name=brown AND (l > .35) THEN LOOP; -- don't consider brown if too light
IF h - hue > .6667 THEN hue _ hue + 1.0 -- ensure continuum
ELSE IF hue - h > .6667 THEN hue _ hue - 1.0;
IF h < hue 
THEN { IF (hUpper - h) > (hue - h) THEN { upper _ name; hUpper _ hue; }; } 
ELSE IF (h - hLower) > (h - hue) THEN { lower _ name; hLower _ hue; }; 
ENDLOOP;
t _ (h - hLower) / (hUpper - hLower); -- place in interval, IN[0..1]
IF t < .5 THEN { -- closer to lesser valued hue
Cons[lower];
IF (t <= epsilon) THEN NULL -- lower
ELSE IF t IN[0.2916667 .. 0.5-epsilon] THEN { -- upperish lower
Cons[upper, TRUE]; t _ t + .1666667 }
ELSE Cons[upper]; -- upper lower
}
ELSE { -- closer to greater valued hue
Cons[upper];
IF (t >= (1.0 - epsilon)) THEN NULL -- upper
ELSE IF t IN[0.5+epsilon .. 0.7083333] THEN { -- lowerish upper
Cons[lower, TRUE]; t _ t - .1666667 }
ELSE Cons[lower]; -- lower upper
};
ConsAdjustment[lower, upper, t, level-1];
};
IF s >= (1.0 - epsilon) THEN Cons[vivid]
ELSE {
IF lower=brown THEN s _ 2*(1-t)*s -- correct for brown's darkness
ELSE IF upper=brown THEN s _ 2*t*s;
ConsAdjustment[weak, strong, s, level];
};
ConsAdjustment[dark, light, l, level];
};
RETURN[RopeFromTokenList[list]];
};

RopeFromTokenList: PROC[list: LIST OF Token] RETURNS[ROPE] ~ {
rope: ROPE _ NIL;
FOR each: LIST OF Token _ list, each.rest UNTIL each=NIL DO
token: Token ~ each.first;
IF rope#NIL THEN rope _ Rope.Concat[rope, " "];
rope _ Rope.Concat[rope, names[token.word][token.ish]];
ENDLOOP;
RETURN[rope];
};

END.
ˆImagerColorNamesImpl.mesa
Copyright c 1984, 1985 by Xerox Corporation.  All rights reserved.
Written by Maureen Stone on June 23, 1983 11:48 am
Last Edited by: Beach, June 22, 1983 2:52 pm
Last Edited by: Stone, October 19, 1983 5:20 pm
Last Edited by: Pier, January 18, 1984 1:09 pm
Last Edited (Extensively) by: Crow, May 22, 1984 1:42:09 pm PDT
Last Edited (even more extensively) by: Doug Wyatt, March 7, 1985 5:46:38 pm PST
-- Achromatics: only s and l are significant
-- Hues: h, s, l are all significant
-- Saturations: only s is significant
-- Lightnesses: only l is significant
-- Enter standard words
-- Add a few synonyms
-- move within established hue range and reset limits using previous hue
Build a name for "value" interpolated between "lower" and "upper"
Build a binary string representing the successive approximation path to "value"
-- Get hue
-- Get Saturation
-- Get Lightness
Κ
~˜
code–

"Cedar" styleš
œ™Kšœ
Οm
œ7™BK–

"Cedar" styleš
œ2™2K™,K™/K™.K™?K™P—K˜š
Οk	˜	Kšœžœžœ˜Kšœžœžœ˜Kšžœ
žœ$žœžœ˜9Kšœžœžœ˜"Kšœžœ˜*—K˜KšΠblœžœ
ž˜#Kšžœ	žœ˜ Kšžœ˜Kšœžœ
žœ˜ K˜Kšžœžœžœ
˜K˜Kšœžœ
žœžœ
˜$Kšœžœ
žœžœ
˜!K˜šœžœ˜KšœΟc˜'Kšœ@ ˜FKšœ 
˜,Kšœ ˜!Kšœ ˜Kš
œ˜—Kšœžœ˜&Kšœžœ˜Kšœžœ˜%Kšœžœ˜$K˜Kšœžœžœžœ
žœ
žœ
žœ
žœ
˜3K˜šœžœ
žœ˜(Kšœžœ˜Kš
œ˜Kšœžœ˜Kš
œ˜Kš
œ˜Kš
œ˜Kš
œ ˜ Kš
œ˜Kš
œ˜Kš
œ˜Kš
œ˜Kš
œ#˜#Kš
œ˜Kšœžœ˜Kš
œ ˜ Kšœžœ˜Kš
œ˜Kšœžœ˜Kš
œ˜Kšœžœ
˜Kš
œ˜—K˜Kš	œ
žœžœžœ
žœ
˜1K˜šœ
žœžœ
˜,Kš
œ,™,Kš
œ˜Kš
œ˜Kš
œ˜Kš
œ$™$Kš
œ˜Kš
œ˜Kš
œ˜Kš
œ˜Kš
œ˜Kš
œ˜Kš
œ˜Kš
œ˜Kš
œ˜Kš
œ%™%Kš
œ˜Kš
œ˜Kš
œ˜Kš
œ˜Kš
œ%™%Kš
œ˜Kš
œ˜Kš
œ˜Kš
œ˜K˜—Kš
œ#˜#Kš
œ ˜ Kšœžœ˜2Kšœžœ˜/K˜Kš
œ+˜+K˜Kšœžœžœ˜Kšœžœžœžœ˜,K˜šΟnœžœ
žœ˜-Kšœ6žœ˜=š‘œžœžœžœ˜2Kšœžœ!˜/Kšœ
žœ4˜BKšžœ
žœ
žœ
žœ
˜K˜—Kš
œ™š	žœžœ
žœ
žœ
ž˜šžœžœž˜Kšœžœ˜Kšžœžœ
žœ(˜7Kšžœ
˜—Kšžœ
˜—Kš
œ™Kšœ%žœ˜,Kšœ(žœ˜.Kšœ)žœ˜0Kšœ(žœ˜/Kšžœ
˜K˜K˜—š‘œžœžœžœžœ
žœ	žœ˜JKš	œžœ
žœžœ
žœ˜!šžœžœžœ	žœ
˜$Kšœžœžœžœ˜@Kšžœžœ
žœ
˜ K˜AKšžœžœžœ
žœ˜2Kšžœ
žœ˜Kšžœ
˜—Kšžœ˜K˜K˜—Kš	œžœžœžœ	žœ˜BK˜š
‘œžœžœžœžœ˜Ošžœ	žœ˜Kšžœžœ!žœ
˜=Kšœ
žœ
˜K˜
—šžœ˜Kšœžœžœžœ ˜KKš
œ#˜#Kš
žœ	žœžœ
žœ	žœ˜9K˜—Kšžœ˜
K˜K˜—š‘œžœ
žœžœžœ
žœ˜5Kšœžœ
žœ" #˜WK˜Kšœ/žœ
˜4KšœFžœ˜LKšœEžœ˜KKšœ
žœžœ
˜Kšœžœžœ
˜Kš	žœžœ
žœ
žœ
 
˜5šžœžœ
žœžœžœ
ž˜@K˜šžœžœ ˜+Kš
œ,˜,Kšžœžœ
žœ
 ˜?šžœž˜Kšžœžœ
˜šžœ
 2˜>Kš
œ%˜%Kš
œ˜Kš
œ˜Kšœžœ
˜K˜—Kšžœžœ
 ˜<—K˜
—šžœ 
˜Kšœžœ ˜,Kšžœžœ˜%Kš
œ'˜'šžœž˜šžœ	˜šžœžœ
žœ 
˜)Kš	œžœžœžœžœ˜1Kšžœžœ ˜,Kšžœ
žœžœ˜!šžœžœžœ˜šžœžœ ˜-šžœžœ˜Kš
œ˜Kš
œ˜K˜
—šžœ˜Kš
œ˜Kš
œ˜K˜—Kšœžœ
˜K˜—K™Hšžœžœ˜Kš
œ
˜
Kš
œ ˜ K˜—šžœžœ˜Kš
œ
˜
Kš
œ ˜ K˜—K˜
—Kšžœ
žœ
 (˜?K˜
—šžœ
žœžœ ˜0K˜Kš
œ%˜%Kš
œ˜Kš
œ˜K˜—Kšžœ
žœ ˜@Kšžœ
žœ ˜?K˜—Kšžœ,˜.Kšžœ+˜-Kšžœžœ
˜—K˜—K˜
Kšžœ
˜—Kšžœ
žœ
žœ˜Kš
žœžœ	žœ
žœžœ	˜-Kšžœ˜K˜—K˜K˜š‘œžœ
žœžœ	žœžœ
žœ˜DKšœžœ	˜Kšœžœ	˜Kšœžœ	˜Kšœ	žœžœ /˜bKšœžœ
žœ	žœ
˜Kš
‘œžœžœžœ
žœ˜Oš‘œžœžœ	žœ˜EKš
œA™AKš
œ˜Kšœžœ˜&Kšžœžœžœ
žœ
˜>Kš
œO™Ošžœžœ
žœ
ž˜Kšœžœžœ˜)Kšœžœ˜Kšœžœ˜Kšžœžœ
žœ
˜Kš	œžœ
žœžœ
žœ˜=Kšžœžœžœ˜<šžœ˜KšžœC˜GKšžœD˜H—Kšžœžœžœžœ˜LKš
œ˜Kšžœ
˜—K˜—Kšžœžœ˜ Kšžœ
žœžœ˜)šžœ˜K˜Kšœžœ ˜"K™
Kšžœžœ 
˜8šžœ ˜Kšœžœ˜Kšœžœ˜šžœžœž˜Kšœžœ˜ Kš	žœžœžœ
žœ $˜KKšžœžœ ˜;Kšžœ
žœžœ˜-šžœ	˜Kšžœžœžœ$˜KKšžœ
žœžœ"˜G—Kšžœ
˜—Kšœ& ˜Dšžœžœ ˜/Kš
œ˜Kšžœžœ
žœ
 ˜$š	žœ
žœžœžœ ˜?Kšœžœ˜%—Kšžœ ˜ K˜
—šžœ ˜&Kš
œ˜Kšžœžœ
žœ
 ˜,š
žœ
žœžœžœ Οi
˜?Kšœžœ˜%—Kšž 
œ ˜ K˜—Kš
œ)˜)K˜—Kš
œ™Kšžœžœ˜(šžœ˜Kšžœ
žœ ˜AKšžœ
žœ
žœ˜#Kš
œ'˜'K˜—Kš
œ™Kš
œ&˜&K˜—Kšžœ˜ K˜K˜—š‘œžœžœ
žœžœ
žœ˜>Kšœžœžœ
˜šžœžœ
žœžœžœ
ž˜;Kš
œ˜Kšžœžœ
žœ˜/Kš
œ7˜7Kšžœ
˜—Kšžœ˜
K˜—K˜Kšžœ
˜—…—#\4b