DIRECTORY
NamedColors,
ImagerColor USING [HSL],
Basics USING [BITSHIFT],
IO  USING [STREAM, RIS, GetTokenRope, EndOfStream],
Rope  USING [ROPE, Length, Equal, Concat ];

NamedColorsImpl: CEDAR PROGRAM
IMPORTS Basics, IO, Rope  
EXPORTS NamedColors
~ BEGIN OPEN NamedColors;

ROPE: TYPE ~ Rope.ROPE;

UndefinedName: PUBLIC SIGNAL ~ CODE;
BadGrammar: PUBLIC SIGNAL ~ CODE;
undefined: REAL ~ -1;  --for undefined color values
entryKind: TYPE ~ { color, saturation, lightness };
colorRecord: TYPE ~ RECORD [
name: ROPE,
hue, saturation, lightness: REAL,
type: entryKind
];

colorMapping: ARRAY ColorType OF colorRecord _ [
black: ["Black",  undefined, 0.0, 0.0, color],
white: ["White",  undefined, 0.0, 1.0, color],
gray: ["Gray",  undefined, 0.0, 0.4, color],
grey: ["Grey",  undefined, 0.0, 0.4, color],
red: ["Red",  0.0, .6, 0.4, color],
orange: ["Orange",  0.04, .6, 0.4, color],
brown: ["Brown",  0.08, .6, 0.2, color],
yellow: ["Yellow",  0.1667, .6, 0.4, color],
green: ["Green",  0.3333, .6, 0.4, color],
cyan: ["Cyan", 0.4999, .6, 0.4, color],
blue: ["Blue",  0.6666, .6, 0.4, color],
purple: ["Purple",  0.73, .6, 0.4, color],
magenta: ["Magenta", 0.8333, .6, 0.4, color],

achromatic: ["Achromatic",  undefined, 0.0, undefined, saturation],
weak: ["Weak",  undefined, 0.3, undefined, saturation],
moderate: ["Moderate",  undefined, 0.6, undefined, saturation],
strong: ["Strong",  undefined, 0.8, undefined, saturation],
vivid: ["Vivid", undefined, 1.0, undefined, saturation],
bright: ["Bright",  undefined, 1.0, undefined, saturation],

dark: ["Dark",  undefined, undefined, 0.2 , lightness],
medium: ["Medium", undefined, undefined, 0.4 , lightness],
light: ["Light",  undefined, undefined, 0.7 , lightness]
];

ishCount: NAT = 15;
ishList: ARRAY [0..ishCount) OF ROPE _ [
"Grayish", "Greyish", "Reddish", "Orangish", "Brownish", "Yellowish", "Greenish", "Cyanish",
"Bluish", "Purplish", "Magentaish", "Weakish", "Strongish", "Darkish", "Lightish" 
];
deIshList: ARRAY [0..ishCount) OF ROPE _ [
"Gray", "Grey", "Red", "Orange", "Brown", "Yellow", "Green", "Cyan",
"Blue", "Purple", "Magenta", "Weak", "Strong", "Dark", "Light" 
];

RopeToHSL: PUBLIC PROCEDURE[rope: ROPE] RETURNS[clr: ImagerColor.HSL] = {
color: colorRecord;
found: BOOLEAN _ FALSE;
lastEntryKind: entryKind _ color;
ish: BOOLEAN _ FALSE;
token: ROPE;
lastToken: ROPE;
tokenList: LIST OF ROPE _ NIL;
firstSaturation, firstLightness, secondHue: BOOLEAN _ TRUE;
saturationFactor, lightnessFactor, hueFactor: REAL _ 1.0;
hueMin, hueMid, hueMax, hueUpper, hueLower: REAL;
Done: SIGNAL = CODE;
stream: IO.STREAM _ IO.RIS[rope];

FindColor: PROC[r: ROPE] RETURNS [colorRecord, BOOLEAN] = {
FOR i: ColorType IN ColorType DO
IF Rope.Equal[r,colorMapping[i].name,FALSE] THEN RETURN[colorMapping[i], TRUE];
ENDLOOP;
RETURN[colorMapping[black], FALSE];
};
DeIsh: PROC[r: ROPE] RETURNS [rOut: ROPE, ish: BOOLEAN] = {
rOut _ r;
ish _ FALSE;
FOR i: NAT IN [0..ishCount) DO
IF Rope.Equal[r, ishList[i], FALSE] THEN {
ish _ TRUE;
rOut _ deIshList[i]
};
ENDLOOP;
};
ApplyFactor: PROC[ weight, tableEntry, average, value: REAL, ish, first: BOOLEAN] RETURNS[newValue, newWeight: REAL] ~ {
IF first THEN {
IF ish 
THEN newValue _ average + .6666 * (tableEntry - value)
ELSE newValue _ tableEntry;  
newWeight _ weight;
}
ELSE {
newWeight _ IF ish THEN weight * .3333 ELSE weight * .5;  -- weaken weight if ishy
newValue _ value + newWeight * (tableEntry - average);
newValue _ MIN[1.0, MAX[0.0, newValue]];
};
};
NextToken: PROC = {
DO
token _ NIL;
[token: token, charsSkipped: ] _ IO.GetTokenRope[stream ! IO.EndOfStream => CONTINUE];
IF token=NIL THEN SIGNAL Done;
IF Rope.Length[token] > 2 THEN EXIT;
ENDLOOP;
};

DO
NextToken[! Done => EXIT]; -- pick up tokens and stack them
tokenList _ CONS[token, tokenList];
ENDLOOP;

clr.H _ clr.S _ clr.L _ undefined;

WHILE tokenList # NIL DO -- now pop tokens back off stack so color comes first
[token, ish] _ DeIsh[tokenList.first]; -- catch mumbleish, strip ish
IF Rope.Equal[token, "Very", FALSE] THEN token _ lastToken;
[color, found] _ FindColor[token];
IF found 
THEN {
SELECT color.type FROM
color => { -- picking up color name
IF clr.S = undefined AND clr.L = undefined 
THEN {   -- reading first color
clr.H _ color.hue;    clr.S _ color.saturation;    clr.L _ color.lightness;
IF clr.H # undefined THEN {   -- other hues must be in same third of color wheel
hueMid _ hueLower _ hueUpper _ clr.H;    
hueMin _ clr.H - .3334;    
hueMax _ clr.H + .3334;
};  
}
ELSE { -- not first color
IF color.hue # undefined AND clr.H # undefined THEN {
factor: REAL _ IF ish THEN .3333 ELSE .5;
IF color.hue > hueMax THEN color.hue _ color.hue - 1. -- get continuum
ELSE IF color.hue < hueMin THEN color.hue _ color.hue + 1.;
IF NOT (hueMin <= color.hue AND hueMax >= color.hue) 
THEN SIGNAL BadGrammar -- hue not in range
ELSE IF secondHue THEN { -- in range and possibly second hue
IF color.hue < hueMid  -- reset admissable range
THEN { 
hueMin _ hueLower _ color.hue;  
hueMax _ hueUpper _ hueMid;  secondHue _ FALSE;  }
ELSE  {
hueMax _ hueUpper _ color.hue;  
hueMin _ hueLower _ hueMid;  secondHue _ FALSE;  };
};
IF clr.H < color.hue THEN {
hueLower _ clr.H;
clr.H _ clr.H + factor * (hueUpper - clr.H);
};
IF clr.H > color.hue THEN {
hueUpper _ clr.H;
clr.H _ clr.H + factor * (hueLower - clr.H);
};
}
ELSE IF color.hue # undefined THEN { -- mixing with grey, 1st hue
hueMid _ hueLower _ hueUpper _ clr.H;    
hueMin _ clr.H - .3333;    
hueMax _ clr.H + .6667;  
};
IF clr.S # color.saturation THEN clr.S _ (clr.S + color.saturation) / 2.0;
IF clr.L # color.lightness THEN clr.L _ (clr.L + color.lightness) / 2.0;
};
};
saturation => { -- achromatic, weak, moderate, strong vivid
IF clr.S = undefined THEN SIGNAL BadGrammar; -- must not have read a color yet
[clr.S, saturationFactor] _ ApplyFactor[ saturationFactor, color.saturation,
 colorMapping[moderate].saturation, clr.S, 
 ish, firstSaturation];
firstSaturation _ FALSE;
};
lightness => { -- dark, medium, light
IF clr.L = undefined THEN SIGNAL BadGrammar; -- must not have read a color yet
[clr.L, lightnessFactor] _ ApplyFactor[ lightnessFactor, color.lightness,
  colorMapping[medium].lightness, clr.L, 
  ish, firstLightness];
firstLightness _ FALSE;
};
ENDCASE;
}
ELSE SIGNAL UndefinedName; -- not found
lastToken _ token;
tokenList _ tokenList.rest;
ENDLOOP;
IF clr.S = undefined OR clr.L = undefined THEN SIGNAL BadGrammar;
IF clr.H = undefined THEN clr.S _ 0.0;    -- kill saturated greys (from "bright white", etc.)
IF clr.H # undefined THEN IF clr.H < 0.0 THEN clr.H _ clr.H + 1. ELSE IF clr.H > 1.0 THEN clr.H _ clr.H - 1.;
RETURN [clr];
};

HSLToRope: PUBLIC PROCEDURE [clr: ImagerColor.HSL, level: NAT _ 3] RETURNS [rope: ROPE] = {
insignificant: REAL ~ 1.0 / Basics.BITSHIFT[1, level+1];
GetIshName: PROC[name: ROPE] RETURNS[nameish: ROPE _ NIL] ~ {
FOR i: NAT IN [0..ishCount) DO
IF Rope.Equal[name, deIshList[i]] THEN nameish _ ishList[i];
ENDLOOP;
IF nameish = NIL THEN nameish _ Rope.Concat[name, "ish"];
};
BuildTokenList: PROC[tokenList: LIST OF ROPE,
lowName, highName: ROPE, value: REAL,   level: NAT]
RETURNS[LIST OF ROPE] ~ {
ConsWithVery: PROC[name, lastName: ROPE, tokenList: LIST OF ROPE]
RETURNS[LIST OF ROPE, ROPE] ~ {
IF Rope.Equal[name, lastName, FALSE]
THEN tokenList _ CONS["Very", tokenList]
ELSE tokenList _ CONS[name, tokenList];
RETURN[tokenList, name];
};

name, lastName: ROPE _ NIL;
number: REAL _ value;
ishy: BOOLEAN _ FALSE;
approximation, adjustment: REAL _ 0.5;
IF (number >= 1.0 - insignificant) OR (number <= insignificant) THEN RETURN[tokenList];
FOR i: NAT IN [0..level-1) DO
IF ABS[number - approximation] <= insignificant THEN EXIT;
IF ABS[ABS[number - approximation] - adjustment/3.0] 
< ABS[ABS[number - approximation] - adjustment/2.0] 
THEN {  adjustment _ adjustment / 3.;    ishy _ TRUE;  }
ELSE  {  adjustment _ adjustment / 2.;    ishy _ FALSE;  };
IF number < approximation 
THEN {  
name _ IF ishy THEN GetIshName[lowName] ELSE lowName;
approximation _ approximation - adjustment;  
}
ELSE  { 
name _ IF ishy THEN GetIshName[highName] ELSE highName;
approximation _ approximation + adjustment;  
};
[tokenList, lastName] _ ConsWithVery[name, lastName, tokenList]; 
ENDLOOP;
RETURN[tokenList];
};

tokenList: LIST OF ROPE _ NIL;
leastUpper, greatestLower: ColorType _ black;
huePlaceInInterval: REAL;

IF clr.L <= insignificant THEN tokenList _ CONS["Black", tokenList]  
ELSE  IF clr.L >= (1.0 - insignificant) THEN tokenList _ CONS["White", tokenList] 
ELSE {
IF (clr.H < undefined/2.0) OR (clr.S < insignificant) THEN -- Achromatic
{  tokenList _ CONS["Grey", tokenList];    clr.S _ 0.0;  }  
ELSE { -- get bounding hues
leastUpperHue: REAL _ 1.5;
greatestLowerHue: REAL _ -.5;
FOR i: ColorType IN ColorType DO
hue: REAL _ colorMapping[i].hue; 
IF hue # undefined THEN {
IF (Rope.Equal[colorMapping[i].name, "Brown", FALSE]) AND (clr.L > .35) THEN LOOP;
IF clr.H - hue > .6667 THEN hue _ hue + 1.0  -- ensure continuum
ELSE IF hue - clr.H > .6667 THEN hue _ hue - 1.0;
IF clr.H < hue 
THEN {  IF (leastUpperHue - clr.H) > (hue - clr.H) 
THEN {  leastUpper _ i;   leastUpperHue _ hue;  };  } 
ELSE IF (clr.H - greatestLowerHue) > (clr.H - hue) 
THEN {  greatestLower _ i;   greatestLowerHue _ hue;  }; 
};
ENDLOOP;
huePlaceInInterval _ (clr.H - greatestLowerHue) / (leastUpperHue - greatestLowerHue);
IF huePlaceInInterval < .5  -- get leading color names
THEN -- closer to lesser valued hue
IF (huePlaceInInterval <= insignificant) 
THEN tokenList _ CONS[colorMapping[greatestLower].name, tokenList] -- lower
ELSE IF (huePlaceInInterval >= .2916667) AND (huePlaceInInterval <= .5-insignificant)
THEN { -- upperish lower
tokenList _ CONS[GetIshName[colorMapping[leastUpper].name],
 CONS[colorMapping[greatestLower].name, tokenList]];
huePlaceInInterval _ huePlaceInInterval + .1666667;
}
ELSE tokenList _ CONS[colorMapping[leastUpper].name, -- upper lower
 CONS[colorMapping[greatestLower].name, tokenList]]
ELSE -- closer to greater valued hue
IF (huePlaceInInterval >= (1.0 - insignificant))
THEN tokenList _ CONS[colorMapping[leastUpper].name, tokenList] -- upper
ELSE IF (huePlaceInInterval <= .7083333) AND (huePlaceInInterval >= .5+insignificant)
THEN { -- lowerish upper
tokenList _ CONS[GetIshName[colorMapping[greatestLower].name],
 CONS[colorMapping[leastUpper].name, tokenList]];
huePlaceInInterval _ huePlaceInInterval - .1666667;
}
ELSE   tokenList _ CONS[colorMapping[greatestLower].name, -- lower upper
 CONS[colorMapping[leastUpper].name, tokenList]];
tokenList _ BuildTokenList[
tokenList,
colorMapping[greatestLower].name,    
colorMapping[leastUpper].name,
huePlaceInInterval,
level - 1
];
};
IF clr.S >= (1.0 - insignificant) THEN tokenList _ CONS["Vivid", tokenList]
ELSE {
IF Rope.Equal[colorMapping[greatestLower].name, "Brown", FALSE] 
THEN  clr.S _ 2 * (1.0 - huePlaceInInterval) * clr.S -- correct for Brown'clr.S darkness
ELSE IF Rope.Equal[colorMapping[leastUpper].name, "Brown", FALSE] 
THEN  clr.S _ 2 * huePlaceInInterval * clr.S;
tokenList _ BuildTokenList[tokenList, "Weak", "Strong", clr.S, level];
};
tokenList _ BuildTokenList[tokenList, "Dark", "Light", clr.L, level];
};

WHILE tokenList # NIL DO
rope _ Rope.Concat[Rope.Concat[rope, tokenList.first], " "];
tokenList _ tokenList.rest;
ENDLOOP;
RETURN[rope];
};



END.
ξNamedColorsImpl.mesa
Copyright c 1984 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
Rick Beach, October 25, 1985 9:18:46 pm PDT
Rewritten by Crow: May 22, 1984 1:42:09 pm
Last Edited by Crow, September 25, 1985 5:30:22 pm PDT

move within established hue range and reset limits using previous hue
Fix deviant color wheel addresses
Build a name for "value" interpolated between "lowName" and "highName"
Build a binary string representing the successive approximation path to "value"
Special case extremes of lightness
Get hue
Get Saturation
Get Lightness
Κ&˜
code–

"Cedar" styleš
œ™Kšœ
Οm
œ1™<K–

"Cedar" styleš
œ2™2K™,K™/K™.K™+K™*K™6K™—š
Οk	˜	Kš
œ˜Kšœžœžœ˜Kšœžœžœ˜Kšžœ
žœžœ"˜3Kšœžœžœžœž
œž
œ˜+—K˜KšΠlnœžœ
ž˜Kšžœ	žœž˜Kšžœ˜šœžœ
žœ
˜K˜Kšžœžœžœ
˜K˜Kšœžœ
žœžœ
˜$Kšœžœ
žœžœ
˜!KšœžœΟc˜3Kšœžœ$˜3šœ
žœžœ˜Kšœžœ
˜Kšœž˜!Kš
œ˜K˜K˜—šœžœžœ˜0Kš
œ.˜.Kš
œ.˜.Kš
œ,˜,Kš
œ,˜,Kš
œ#˜#Kš
œ*˜*Kš
œ(˜(Kš
œ,˜,Kš
œ*˜*Kš
œ'˜'Kš
œ(˜(Kš
œ*˜*Kš
œ-˜-K˜Kš
œC˜CKš
œ7˜7Kš
œ?˜?Kš
œ;˜;Kš
œ8˜8Kš
œ;˜;K˜Kš
œ7˜7Kš
œ:˜:Kš
œ8˜8K˜—K˜Kšœ
žœ˜šœ	žœžœ
žœ˜(Kš
œ\˜\Kš
œR˜RK˜—šœžœžœ
žœ˜*Kš
œD˜DKš
œ?˜?K˜——K˜šΟn	œžœ
ž	œžœžœžœ˜IKš
œ˜Kšœžœžœ
˜Kš
œ!˜!Kšœžœžœ
˜Kšœžœ
˜Kšœžœ
˜Kš	œžœ
žœ
žœžœ
˜Kšœ,žœžœ
˜;Kšœ.žœ˜9Kšœ,žœ
˜1Kšœžœ
žœ
˜Kšœžœ
žœžœ˜!K˜š
‘	œžœžœžœžœ˜;šžœžœž˜ Kš
žœ#žœžœ
žœžœ˜OKšžœ
˜—Kšžœžœ˜#K˜—š‘œžœžœžœžœžœ˜;Kš
œ	˜	Kšœžœ
˜šžœžœ
žœž˜šžœžœž˜*Kšœžœ
˜Kš
œ˜K˜—Kšžœ
˜—Kš
œ˜—š‘œžœ&žœžœžœžœ˜xšžœžœ˜Kšžœ˜Kšžœ2˜6Kšžœ˜Kš
œ˜K˜
—šžœ˜Kšœžœžœžœ ˜RKš
œ6˜6Kšœžœžœ˜(K˜—K˜—š‘	œžœ˜š
ž˜Kšœžœ
˜Kšœ!žœžœžœ˜VKšžœžœ
žœ
žœ˜Kšžœžœ
žœ
˜$Kšžœ
˜—K˜—K˜š
ž˜Kšœžœ  ˜;Kšœžœ˜#Kšžœ
˜K˜—Kš
œ"˜"K˜šžœ
žœ
žœ
 5˜NKšœ' ˜DKšžœžœžœ˜;š
œ"˜"Kšžœ˜	šžœ˜šžœž˜šœ ˜#Kšžœžœ˜+šžœ ˜Kš
œK˜Kšžœžœ 2˜PKš
œ)˜)Kš
œ˜Kš
œ˜Kš
œ˜—Kš
œ
˜
—šžœ ˜šžœžœžœ˜5Kš	œžœžœžœžœ˜)šžœžœ ˜FKšžœ
žœžœ˜;—šžœ
žœžœ˜5Kšžœ ˜*šžœ
žœžœ $˜<Kšžœ ˜0šžœ˜Kš
œ ˜ Kšœ)žœ˜2—šžœ˜Kš
œ ˜ Kšœ)žœ˜3—K˜—K™E—šžœžœ˜Kš
œ˜Kš
œ,˜,K˜—šžœžœ˜Kš
œ˜Kš
œ,˜,K˜—K˜
—šžœ
žœžœ ˜AKš
œ)˜)Kš
œ˜Kš
œ˜Kš
œ˜—Kšžœžœ*˜JKšžœžœ)˜HKš
œ˜—Kš
œ˜—šœ +˜;Kšžœžœ
žœ
 !˜Nš
œL˜LKš
œ+˜+Kš
œ˜—Kšœžœ
˜Kš
œ˜—šœ ˜%Kšžœžœ
žœ
 !˜NKš
œI˜IKš
œ)˜)Kš
œ˜Kšœžœ
˜Kš
œ˜—Kšžœ
˜—K˜
—Kšžœ
žœ ˜'—Kš
œ˜K˜Kšžœ
˜—Kšžœžœžœ
žœ˜AKšžœžœ 3˜]K™!Kšžœžœ
žœ
žœžœ
žœ
žœ˜mKšžœ˜
K˜K˜—š‘	œžœ
ž	œžœ	žœžœžœ˜[Kšœžœžœ
˜8š‘
œžœžœžœ
žœžœ˜=šžœžœ
žœž˜Kšžœ žœ˜<Kšžœ
˜—Kšžœžœ
žœ$˜9Kš
œ˜—š‘œžœžœ
žœ
žœžœ	žœ
žœžœ
žœ
žœ
žœ˜{K™Fš‘œžœžœ
žœ
žœ
žœžœ
žœ
žœ
žœžœ˜ašžœžœ
˜$Kšžœ
žœ˜(Kšžœ
žœ˜'—Kšžœ˜K˜—K˜Kšœžœžœ
˜Kšœžœ	˜Kšœžœžœ
˜Kšœžœ˜&šžœ!žœžœ
žœ˜WKš
 O™O—šžœžœ
žœž˜Kšžœ
žœ*žœ
žœ
˜:š
žœ
žœ
žœ.žœ
žœ+˜jKšžœ,žœ˜8Kšžœ-žœ˜;—šžœ˜šžœ˜Kšœžœžœžœ	˜5Kš
œ-˜-Kš
œ
˜
—šžœ˜Kšœžœžœžœ
˜7Kš
œ-˜-Kš
œ˜——Kš
œA˜AKšžœ
˜—Kšžœ˜K˜—K˜Kš	œžœ
žœ
žœžœ
˜Kš
œ-˜-Kšœžœ
˜˜K™"—Kšžœžœ
žœ˜EKšžœžœ žœ
žœ˜Ršžœ˜K™šžœžœžœ
 
˜HKšœžœ' ˜<—šžœ ˜Kšœžœ˜Kšœžœ˜šžœžœž˜ Kšœžœ˜!šžœžœ˜Kš	žœ,žœžœžœ
ž˜RKšžœžœ ˜@Kšžœ
žœžœ˜1šžœ
˜šžœ
žœ)˜3Kšžœ2˜6—šžœ
žœ,˜3Kšžœ5˜9——K˜—Kšžœ
˜—Kš
œU˜Ušžœ ˜6šžœ
 ˜#šžœ'˜)Kšžœ
žœ. ˜K—šžœ
žœ!žœ)˜Ušžœ ˜šœžœ+˜;Kšœ
žœ/˜4—Kš
œ3˜3Kš
œ
˜
——šžœ
žœ  ˜CKšœ
žœ.˜3——šžœ
 ˜$šžœ.˜0Kšžœ
žœ+ ˜H—šžœ
žœ!žœ)˜Ušžœ Οi
˜šœžœ.˜>Kšœ
žœ,˜1—Kš
œ3˜3Kš
œ
˜
——šžœžœ# ˜HKšœ
žœ,˜1———š
œ˜K˜
Kš
œ%˜%Kš
œ˜Kš
œ˜K˜	K˜—K˜K™—Kšžœ žœžœ˜Kš
ž˜šžœ7žœ˜@Kšžœ1 #˜X—šžœ
žœ4žœ˜BKšžœ'˜-—Kš
œF˜FK˜Kš
œ
™
—Kš
œE˜EK˜K˜—šžœ
žœ
ž˜Kš
œ<˜<Kš
œ˜Kšžœ
˜—Kšžœ˜
K˜K˜K˜K˜—Kšžœ
˜—…—,=.