~
BEGIN
ROPE: TYPE ~ Rope.ROPE;
MapData: TYPE ~ ColorizeViewPointBackdoor.MapData;
SampledColorIPFragments: TYPE ~ ColorizeViewPointBackdoor.SampledColorIPFragments;
SampledColorTransformSet: TYPE ~ ColorizeViewPointSweep.SampledColorTransformSet;
nullTransformSet: SampledColorTransformSet ~ ColorizeViewPointSweep.nullTransformSet;
PixelArrayStats:
TYPE ~
RECORD [
rectFrag: ROPE ← NIL,
ts: SampledColorTransformSet ← nullTransformSet --sampled color transform data
];
NumRec:
TYPE ~
RECORD [
nums:
SELECT type: *
FROM
int => [i: ARRAY [0..1] OF INT],
real => [r: ARRAY [0..1] OF REAL],
ENDCASE
];
Colors:
TYPE ~
RECORD [
foreground, background: REF ← NIL --hold the ip fragments defining the colors
];
nilColors: Colors ~ [];
AbnormalBitmap: ERROR ~ CODE; --only used internally
ColorizeBitmaps: ColorizeViewPointBackdoor.Colorization ~ {
--prev. version used Xerox Map color operator, which only allows constant colors. This uses MaskPixel, which allows for sampledcolors and makesampledblacks; it creates a mask out of the pixelarray and presses the current color thru. For the background color, set the background color and do a maskrectangle; for the foreground (1 bits), set the foreground color and maskpixel.
[ip: ROPE, palette: Profiles.Profile, checkSystemSetting: ColorizeViewPoint.CheckSystemSettingProc, mapData: MapData] RETURNS [newIP: ROPE]
EachBitmap: IPScan.ScanProc ~ {
[min: INT, max: INT, op: IPMaster.Op ← nil, seq: IPScan.Seq ← nil, num: INTEGER ← 0, punt: BOOL ← FALSE] (min points to the first token in the set, max points AFTER the last)
ENABLE AbnormalBitmap => {
--apparently not from Free-Hand; flush and go on
newIP ← newIP.Cat[ip.Substr[flushedTo, max]];
flushedTo ← max;
GOTO Ignore;
};
SELECT op
FROM
maskpixel
--used by Free-Hand Drawing-- =>
IF ~punt
AND ip.Substr[min-4, 4].Equal["\240x\240j"
--
DOSAVESIMPLEBODY {--]
THEN {
colorFrags: Colors;
paStats: PixelArrayStats;
colorFrags ← IF overrideColors#nilColors THEN overrideColors ELSE GetColorIPFrags[palette, mapData, Rope.Concat["Bitmap", Convert.RopeFromInt[(count ← count+1)]], defaultColors]; --override always wins if it's not nil
IF colorFrags.foreground=NIL AND colorFrags.background=NIL THEN --no color change for this bitmap--RETURN;
paStats ← GetPAStats[ip.Substr[min, max-min]];
newIP ← Rope.Concat[newIP, ip.Substr[flushedTo, min-flushedTo]];--to beginning of the p.a., within the DOSAVESIMPLEBODY
IF colorFrags.background#
NIL
THEN
WITH colorFrags.background
SELECT
FROM
ipFrag: ROPE --constant color-- => newIP ← Rope.Cat[newIP, ipFrag, paStats.rectFrag]; --insert color, then maskrectangle
ipFrag: REF SampledColorIPFragments --sweep color; must construct sweep-- => newIP ← Rope.Cat[newIP, ipFrag.beforeTransform, ColorizeViewPointSweep.ConstructSweepTransform[ts: paStats.ts, sc: ipFrag], ipFrag.afterTransform, paStats.rectFrag]; --insert sweep color, then maskrect
ENDCASE => ERROR; --system error
IF colorFrags.foreground#
NIL
THEN
WITH colorFrags.foreground
SELECT
FROM
ipFrag: ROPE --constant color-- => newIP ← Rope.Concat[newIP, ipFrag]; --insert color so maskpixel uses that as it's color
ipFrag: REF SampledColorIPFragments --sweep color; must construct sweep-- => newIP ← Rope.Cat[newIP, ipFrag.beforeTransform, ColorizeViewPointSweep.ConstructSweepTransform[ts: paStats.ts, sc: ipFrag], ipFrag.afterTransform];
ENDCASE => ERROR; --system error
flushedTo ← min; --flushed up to the p.a., with 2 colors inserted
};
ENDCASE => ERROR; --system error!
EXITS Ignore => RETURN;
};
flushedTo, count: INT ← 0;
overrideColors: Colors ← GetColorIPFrags[palette, mapData, "BitmapALL"]; --"BitmapALL" overrides all other commands. This allows, eg, BW mapping to work on all bitmaps, without having to provide a new definition for each bitmap
defaultColors: Colors ← IF overrideColors=nilColors THEN GetColorIPFrags[palette, mapData, "Bitmap"] ELSE nilColors; --"Bitmap" in the palette specifies the default colors; if any bitmap has no definition, the default colors apply
IPScan.ScanRope[ip: ip, ops: LIST[maskpixel], action: EachBitmap];
newIP ← newIP.Concat[ip.Substr[flushedTo]];
};
GetPAStats:
PROC [paFrag:
ROPE]
RETURNS [paStats: PixelArrayStats] ~ {
paEnd, transEnd, scaleEnd, pixelsW, pixelsH: INT ← 0;
scaleW, scaleH: REAL;
translateFrag, scale2Frag: ROPE;
IF (paEnd ← paFrag.Find["\241\302" --MAKEPIXELARRAY--]+2)=1--(-1+2)-- THEN ERROR AbnormalBitmap;
IF (transEnd ← paFrag.Find["\240\242\240\250" --TRANSLATE CONCATT--]+2)=1--(-1+2)-- THEN ERROR AbnormalBitmap;
IF (scaleEnd ← paFrag.Find["\240\246\240\250" --SCALE2 CONCATT--]+2)=1--(-1+2)-- THEN ERROR AbnormalBitmap;
translateFrag ← paFrag.Substr[paEnd, transEnd-paEnd];
scale2Frag ← paFrag.Substr[transEnd+2--after CONCATT--, scaleEnd-(transEnd+2)];
WITH tmp: GetNums[translateFrag]
SELECT
FROM
int => {paStats.ts.offset.x ← tmp.i[0]; paStats.ts.offset.y ← tmp.i[1]}; --auto convert to Real
real => {paStats.ts.offset.x ← tmp.r[0]; paStats.ts.offset.y ← tmp.r[1]};
ENDCASE => ERROR; --system error
WITH tmp: GetNums[scale2Frag]
SELECT
FROM
real => {scaleW ← tmp.r[0]; scaleH ← tmp.r[1]};
int => {scaleW ← tmp.i[0]; scaleH ← tmp.i[1]}; --auto convert to Real
ENDCASE => ERROR; --system error
WITH tmp: GetNums[paFrag]
SELECT
FROM
int => {pixelsH ← tmp.i[0]; pixelsW ← tmp.i[1]}; --h comes before w in pixel array spec
real => ERROR AbnormalBitmap; --can't have Real pixel array size descriptors
ENDCASE => ERROR; --system error
paStats.ts.width.x ← pixelsW*scaleW;
paStats.ts.height.y ← pixelsH*scaleH;
paStats.rectFrag ← MakeRectangle[ColorizeViewPointBackdoor.AltRound[paStats.ts.offset.x], ColorizeViewPointBackdoor.AltRound[paStats.ts.offset.y], ColorizeViewPointBackdoor.AltRound[paStats.ts.width.x], ColorizeViewPointBackdoor.AltRound[paStats.ts.height.y]];
};
GetNums:
PROC [frag:
ROPE]
RETURNS [NumRec] ~ {
--finds 2 nums at beginning of frag
start: INT ← 0;
tmpI: int NumRec;
tmpR: real NumRec;
returnInt, returnReal: BOOL ← FALSE;
FOR j:
NAT
IN [0..1]
DO
--find x, then find y
SELECT frag.Fetch[start]
FROM
<= '\177
--using 2 byte short number encoding, biased by 4000-- => {
tmpI.i[j] ← IPMaster.IntFromSequenceData[text: Rope.ToRefText[frag], start: start, len: 2]-4000;
start ← start+2;
returnInt ← TRUE;
};
'\302
--using multi-byte seqInteger encoding, # bytes found in next byte-- => {
bytes: NAT ← ORD[frag.Fetch[start+1]]; --#bytes which follow
IF bytes>4 THEN ERROR AbnormalBitmap; --would overflow INT boundaries
tmpI.i[j] ← IPMaster.IntFromSequenceData[text: Rope.ToRefText[frag], start: start+2, len: bytes];
start ← start+2+bytes;
returnInt ← TRUE;
};
'\304 --
seqRational encoding, # bytes found in next byte (divide evenly between x and y (return REALs)-- => {
numer, denom: REAL ← 0.0;
bytes: NAT ← ORD[frag.Fetch[start+1]]; --#bytes which follow
IF bytes>8 OR (bytes MOD 2)#0 THEN ERROR AbnormalBitmap; -->8 overflows INT; must be even # of bytes
numer ← IPMaster.RealFromSequenceData[text: Rope.ToRefText[frag], start: start+2, len: bytes/2];
denom ← IPMaster.RealFromSequenceData[text: Rope.ToRefText[frag], start: start+2+(bytes/2), len: bytes/2];
tmpR.r[j] ← numer/denom;
start ← start+2+bytes;
returnReal ← TRUE;
};
ENDCASE => ERROR AbnormalBitmap; --apparently not a VP Free-Hand bitmap
ENDLOOP;
IF returnInt AND returnReal THEN ERROR AbnormalBitmap; --can't have one real and one int num
RETURN [IF returnInt THEN tmpI ELSE tmpR];
};
MakeRectangle:
PROC [x, y, w, h:
INT]
RETURNS [rect:
ROPE] ~ {
fragStream: IO.STREAM ~ IO.ROS[];
IPMaster.PutInt[stream: fragStream, n: x];
IPMaster.PutInt[stream: fragStream, n: y];
IPMaster.PutInt[stream: fragStream, n: w];
IPMaster.PutInt[stream: fragStream, n: h];
IPMaster.PutOp[stream: fragStream, op: maskrectangle];
rect ← IO.RopeFromROS[self: fragStream];
};
BadColorDef: ERROR [explanation: ROPE] ~ CODE;
GetColorIPFrags:
PROC [palette: Profiles.Profile, mapData: MapData, key:
ROPE, defaultColors: Colors ← nilColors]
RETURNS [colorFrags: Colors] ~ {
--look up "key (ie, "Bitmap", "Bitmap<count>", etc.); returns ipFrags for the foreground and the background colors
ParseBitmapColors:
PROC [list:
LIST
OF
ROPE, palette: Profiles.Profile]
RETURNS [colorFrags: Colors] ~ {
AddToEnd:
PROC [list:
LIST
OF
ROPE, add:
ROPE]
RETURNS [
LIST
OF
ROPE] ~ {
IF list=NIL THEN RETURN [LIST[add]] ELSE RETURN [CONS[list.first, AddToEnd[list.rest, add]]]};
color: LIST OF ROPE ← NIL;
colCnt: INT ← 1;
amperFound: BOOL ← FALSE;
FOR each:
LIST
OF
ROPE ← list, each.rest
UNTIL each=
NIL
DO
SELECT each.first.Fetch
FROM
'& => {
amperFound ← TRUE;
IF (colCnt ← colCnt+1)>2 THEN ERROR BadColorDef[explanation: "More than 2 colors found."];
IF color=NIL THEN ERROR BadColorDef[explanation: "First color (foreground) not found."];
colorFrags.foreground ← ColorizeViewPointBackdoor.IPFragmentForColorSetting[color, palette];
color ← NIL;
};
ENDCASE => color ← AddToEnd[color, each.first];
ENDLOOP;
IF color=NIL AND amperFound THEN ERROR BadColorDef[explanation: "Second color (background) not found."];
IF amperFound THEN colorFrags.background ← ColorizeViewPointBackdoor.IPFragmentForColorSetting[color, palette]
ELSE colorFrags.foreground ← ColorizeViewPointBackdoor.IPFragmentForColorSetting[color, palette];
};
levelsExceeded: BOOL;
toks: LIST OF ROPE ← NIL;
prefixes: LIST OF ROPE ~ Profiles.ListOfTokens[profile: palette, key: "BitmapPalette", default: NIL]; --can have a separate palette just for Bitmaps
[toks, levelsExceeded] ← ColorizeViewPointBackdoor.GetRecursiveValue[key: key, palette: palette, subpaletteList: ColorizeViewPointBackdoor.SubpaletteSearchList[prefixesIn: prefixes, profile: palette], mapData: mapData];
SELECT
TRUE
FROM
toks=NIL => RETURN [defaultColors];
levelsExceeded => {
SIGNAL ColorizeViewPoint.Warning[class: $MalformedPaletteEntry, explanation: IO.PutFR[format: "%g is part of a recursive color definition beyond allowable levels; ignoring it.", v1: [rope[key]]]];
RETURN [defaultColors];
};
ENDCASE => {
colorFrags ← ParseBitmapColors[toks, palette !
BadColorDef => {
SIGNAL ColorizeViewPoint.Warning[class: $MalformedPaletteEntry, explanation: Rope.Cat[IO.PutFR[format: "Problem with custom color entry \"%g\":\n", v1: [rope[key]]], explanation, ".\nUsing default values for that bitmap."]];
colorFrags ← defaultColors;
CONTINUE};
];
RETURN;
};
};
ColorizeViewPointBackdoor.InstallNewColorization[colorization: ColorizeBitmaps, setting: [key: "ColorizeBitmaps", description: "Colors bitmaps from the ViewPoint Free-Hand Drawing or Art & Photo programs according to custom commands \"BitmapN: blackReplace & whiteReplace\", where N is the bitmap # in the order laid down. \"Bitmap: blackReplace & whiteReplace\" gives default coloring for bitmaps; \"BitmapALL: bR & wR\" overrides all other bitmap coloring commands", default: TRUE]];