SchemeInterpressImpl.mesa
Copyright Ó 1988, 1991 by Xerox Corporation. All rights reserved.
Michael Plass, December 2, 1991 1:24 pm PST
DIRECTORY
Atom USING [MakeAtom],
BasicTime USING [Now],
Convert USING [RopeFromTime],
Imager USING [Context, Error, Font],
ImagerBox USING [Rectangle],
ImagerColor USING [Color, ColorOperator, NewColorOperatorGrayLinear],
ImagerInterpress USING [Close, Create, DeclareColor, DeclareColorOperator, DeclareFont, DeclarePixelArray, DoPage, Ref],
ImagerInterpressBackdoor USING [CreateFragmentFromStream, PushColorOperator, PushInt, PushPixelArray, PushVector, StreamFromRef, VectorProc],
ImagerPixelArray USING [PixelArray],
ImagerTransformation USING [InverseTransformRectangle],
InterpressInterpreter USING [Close, DoPage, LogProc, Master, Open],
IO USING [GetInt, PutF, RIS, STREAM],
IPMaster USING [PutInt, PutOp, PutRational],
Prop USING [PropList, Put],
RasterEncodingStandardIO USING [Read, RES, RESRep, Write],
Real USING [Round],
Rope USING [Concat, ROPE],
Scheme USING [Any, Apply, Car, Cdr, Complain, Cons, DefinePrimitive, Environment, false, Flonum, KCheck, ListLength, MakeFixnum, Number, NumberRep, Primitive, ProperList, RegisterInit, RopeFromString, String, StringFromRope, Symbol, ThePort, TheREAL, TheString, true, undefined, unspecified],
SchemeSys USING [GetPort],
Vector2 USING [VEC],
XeroxCompress USING [CompressPixelArray];
SchemeInterpressImpl: CEDAR PROGRAM
IMPORTS Atom, BasicTime, Convert, Imager, ImagerColor, ImagerInterpress, ImagerInterpressBackdoor, ImagerTransformation, InterpressInterpreter, IO, IPMaster, Prop, RasterEncodingStandardIO, Real, Rope, Scheme, SchemeSys, XeroxCompress
~ BEGIN OPEN Scheme;
ROPE: TYPE ~ Rope.ROPE;
PrimitiveProc: TYPE ~ PROC [self: Primitive, a, b, c: Any, rest: ProperList] RETURNS [result: Any ¬ NIL];
InterpressOp: TYPE ~ {openinterpressoutput, declareinterpressvalue, writeinterpresspage, closeinterpressoutput, interpressoutputpred, openinterpressinput, interpressinputpagecount, interpressinputpred, interpretinterpresspage, closeinterpressinput, xeroxcompresspixelarray, writerasterencodingstandardfile, writerestrictedres, readrasterencodingstandardfile};
E: PROC [op: InterpressOp] RETURNS [REF InterpressOp] ~ {
RETURN [NEW [InterpressOp ¬ op]]
};
TheContext: PROC [a: Any] RETURNS [Imager.Context] ~ {
WITH a SELECT FROM
ctx: Imager.Context => RETURN [ctx];
ENDCASE => Complain[a, "not an Imager Context"];
};
TheImagerInterpressRef: PROC [a: Any] RETURNS [ImagerInterpress.Ref] ~ {
WITH a SELECT FROM
ref: REF ImagerInterpress.Ref => RETURN [ref­];
ENDCASE => Complain[a, "not an Interpress output handle"];
};
TheInterpressMaster: PROC [a: Any] RETURNS [InterpressInterpreter.Master] ~ {
WITH a SELECT FROM
master: InterpressInterpreter.Master => RETURN [master];
ENDCASE => Complain[a, "not an Interpress input handle"];
};
ThePixelArray: PROC [a: Any] RETURNS [ImagerPixelArray.PixelArray] ~ {
WITH a SELECT FROM
pa: ImagerPixelArray.PixelArray => RETURN [pa];
ENDCASE => Complain[a, "not a PixelArray"];
};
TheBOOL: PROC [a: Any] RETURNS [BOOL] ~ {
SELECT a FROM
false, NIL => RETURN [FALSE];
ENDCASE => RETURN [TRUE];
};
TheColorOperator: PROC [a: Any] RETURNS [ImagerColor.ColorOperator] ~ {
WITH a SELECT FROM
pa: ImagerColor.ColorOperator => RETURN [pa];
ENDCASE => Complain[a, "not a ColorOperator"];
};
TheSymbol: PROC [a: Any] RETURNS [Symbol] ~ {
WITH a SELECT FROM
s: Symbol => RETURN [s];
ENDCASE => Complain[a, "not a Symbol"];
};
InterpressPrim: PrimitiveProc ~ {
Log: InterpressInterpreter.LogProc = {
[class: INT, code: ATOM, explanation: ROPE]
WITH SchemeSys.GetPort[param: Scheme.undefined, in: FALSE] SELECT FROM
stream: IO.STREAM => {
IO.PutF[stream: stream, format: "%l *** Interpress: %g%l\n", v1: [rope["sb"]], v2: [rope[explanation]], v3: [rope["SB"]]];
};
ENDCASE => ERROR Complain[$InterpressError, explanation];
};
Inner: PROC RETURNS [result: Any ¬ unspecified] ~ {
refOp: REF InterpressOp ~ NARROW[self.data];
SELECT refOp­ FROM
$openinterpressoutput => {
result ¬ NEW[ImagerInterpress.Ref ¬ ImagerInterpress.Create[fileName: RopeFromString[TheString[a]]]];
};
$declareinterpressvalue => {
interpress: ImagerInterpress.Ref ~ TheImagerInterpressRef[a];
WITH b SELECT FROM
font: Imager.Font => { ImagerInterpress.DeclareFont[interpress, font] };
color: ImagerColor.Color => { ImagerInterpress.DeclareColor[interpress, color] };
pixelArray: ImagerPixelArray.PixelArray => { ImagerInterpress.DeclarePixelArray[interpress, pixelArray] };
colorOperator: ImagerColor.ColorOperator => { ImagerInterpress.DeclareColorOperator[interpress, colorOperator] };
ENDCASE => NULL;
};
$writeinterpresspage => {
Action: PROC [context: Imager.Context] ~ {
result ¬ Apply[b, Cons[context, NIL]];
};
ImagerInterpress.DoPage[self: TheImagerInterpressRef[a], action: Action, scale: 1.0];
};
$closeinterpressoutput => {
ImagerInterpress.Close[self: TheImagerInterpressRef[a]];
};
$interpressoutputpred => {
WITH a SELECT FROM
ref: REF ImagerInterpress.Ref => RETURN [true];
ENDCASE => RETURN [false];
};
$openinterpressinput => {
result ¬ InterpressInterpreter.Open[fileName: RopeFromString[TheString[a]], log: Log];
};
$interpressinputpagecount => {
result ¬ MakeFixnum[TheInterpressMaster[a].pages];
};
$interpressinputpred => {
WITH a SELECT FROM
master: InterpressInterpreter.Master => RETURN [true];
ENDCASE => RETURN [false];
};
$interpretinterpresspage => {
InterpressInterpreter.DoPage[master: TheInterpressMaster[a], page: KCheck[b], context: TheContext[c], log: Log];
};
$closeinterpressinput => {
InterpressInterpreter.Close[master: TheInterpressMaster[a]]
};
$xeroxcompresspixelarray => {
result ¬ XeroxCompress.CompressPixelArray[ThePixelArray[a]];
};
$writerasterencodingstandardfile => {
fileName: ROPE ~ RopeFromString[TheString[a]];
res: RasterEncodingStandardIO.RES ~ RESFromList[b];
RasterEncodingStandardIO.Write[fileName, res];
};
$writerestrictedres => {
stream: IO.STREAM ~ ThePort[a];
pa: ImagerPixelArray.PixelArray ~ ThePixelArray[b];
resolution: INT ~ KCheck[c];
maskImage: BOOL ~ TheBOOL[Car[rest]];
nameAttribute: ROPE ~ IF Cdr[rest] = NIL THEN NIL ELSE RopeFromString[TheString[Car[Cdr[rest]]]];
WriteRestrictedRES[stream: stream, pa: pa, res: resolution, maskImage: maskImage, nameAttribute: nameAttribute];
};
$readrasterencodingstandardfile => {
fileName: ROPE ~ RopeFromString[TheString[a]];
res: RasterEncodingStandardIO.RES ~ RasterEncodingStandardIO.Read[fileName];
result ¬ ListFromRES[res];
};
ENDCASE => ERROR;
};
result ¬ Inner[ ! Imager.Error => { ERROR Complain[$ImagerError, error.explanation] }];
};
KeyW: TYPE ~ { header, imageScale, xDimension, yDimension, maskImage, colorImage, colorOperator, imageProperties };
keyw: REF ARRAY KeyW OF Symbol ~ NEW [ARRAY KeyW OF Symbol ¬ [
header: Atom.MakeAtom["header"],
imageScale: Atom.MakeAtom["image-scale"],
xDimension: Atom.MakeAtom["x-dimension"],
yDimension: Atom.MakeAtom["y-dimension"],
maskImage: Atom.MakeAtom["mask-image"],
colorImage: Atom.MakeAtom["color-image"],
colorOperator: Atom.MakeAtom["color-operator"],
imageProperties: Atom.MakeAtom["image-properties"]
]];
RESFromList: PROC [list: Any] RETURNS [RasterEncodingStandardIO.RES] ~ {
res: RasterEncodingStandardIO.RES ~ NEW[RasterEncodingStandardIO.RESRep];
n: INT ~ ListLength[list]; -- to make sure it is a proper list
FOR tail: Any ¬ list, Cdr[tail] UNTIL tail = NIL DO
first: Any ~ Car[tail];
k: INT ~ ListLength[first];
key: ATOM ~ TheSymbol[Car[first]];
val: Any;
IF k # 2 THEN Complain[first, "wrong number of elements"];
val ¬ Car[Cdr[first]];
SELECT key FROM
keyw[header] => { res.header ¬ RopeFromString[TheString[val]] };
keyw[imageScale] => { res.imageScale ¬ VECFromList[val] };
keyw[xDimension] => { res.xDimension ¬ KCheck[val] };
keyw[yDimension] => { res.yDimension ¬ KCheck[val] };
keyw[maskImage] => { res.maskImage ¬ ThePixelArray[val] };
keyw[colorImage] => { res.colorImage ¬ ThePixelArray[val] };
keyw[colorOperator] => { res.colorOperator ¬ TheColorOperator[val] };
keyw[imageProperties] => { res.imageProperties ¬ PropListFromList[val] };
ENDCASE => Complain[first, "unknown property"];
ENDLOOP;
RETURN [res]
};
resHeader: ROPE ¬ "Interpress/Xerox/2.1/RasterEncoding/1.0 ";
WriteRestrictedRES: PROC [stream: IO.STREAM, pa: ImagerPixelArray.PixelArray, res: INT, maskImage: BOOL, nameAttribute: ROPE] ~ {
ip: ImagerInterpress.Ref ~ ImagerInterpressBackdoor.CreateFragmentFromStream[stream, resHeader];
PushRESImage[nameAttribute, ip, pa, res, maskImage];
ImagerInterpress.Close[ip];
};
resSignature: INT = 13086;
validResolutions: ROPE ¬ "72 75 150 200 300 600 1200";
PushRESImage: PROC [nameAttribute: Rope.ROPE, ip: ImagerInterpress.Ref, pa: ImagerPixelArray.PixelArray, res: INT, maskImage: BOOL] ~ {
PushScaleVector: PROC ~ {
the scale vector must conform to several limitations imposed by ancient implementations
stream: IO.STREAM ¬ ImagerInterpressBackdoor.StreamFromRef[ip];
valid: IO.STREAM ¬ IO.RIS[Rope.Concat[validResolutions, " -1"]];
FOR i: INT ¬ IO.GetInt[stream: valid], IO.GetInt[stream: valid] UNTIL i < 0 DO
IF res = i THEN EXIT;
REPEAT FINISHED => Complain[MakeFixnum[res], Rope.Concat["Restricted RES bitmap resolution must be one of: ", validResolutions]]
ENDLOOP;
IPMaster.PutRational[stream, 254, res*10000];
IPMaster.PutOp[stream, dup];
IPMaster.PutInt[stream, 2];
IPMaster.PutOp[stream, makevec];
};
attributeVector: ImagerInterpressBackdoor.VectorProc ~ {
IF nameAttribute # NIL THEN {
putIdentifier[$name];
putString[nameAttribute];
};
putIdentifier[$creationTime];
putString[Convert.RopeFromTime[from: BasicTime.Now[], end: seconds]];
};
box: ImagerBox.Rectangle ~ ImagerTransformation.InverseTransformRectangle[m: pa.m, r: [0, 0, pa.sSize, pa.fSize]];
PushScaleVector[];
ImagerInterpressBackdoor.PushInt[ip, Real.Round[box.w]];
ImagerInterpressBackdoor.PushInt[ip, Real.Round[box.h]];
IF maskImage
THEN {
ImagerInterpressBackdoor.PushPixelArray[ip, pa]; -- mask image
ImagerInterpressBackdoor.PushInt[ip, 0]; -- no color image
ImagerInterpressBackdoor.PushInt[ip, 0]; -- no color operator
}
ELSE {
ImagerInterpressBackdoor.PushInt[ip, 0]; -- no mask image
ImagerInterpressBackdoor.PushPixelArray[ip, pa];
ImagerInterpressBackdoor.PushColorOperator[ip, ImagerColor.NewColorOperatorGrayLinear[sWhite: 0, sBlack: 1]]; -- bitmap values
};
ImagerInterpressBackdoor.PushVector[ip, attributeVector];
ImagerInterpressBackdoor.PushInt[ip, resSignature];
};
VECFromList: PROC [list: Any] RETURNS [Vector2.VEC] ~ {
IF ListLength[list] # 2 THEN Complain[list, "wrong number of elements"];
RETURN [[x: TheREAL[Car[list]], y: TheREAL[Car[Cdr[list]]]]]
};
ListFromRES: PROC [res: RasterEncodingStandardIO.RES] RETURNS [list: ProperList ¬ NIL] ~ {
Put: PROC [key: KeyW, val: Any] ~ {
list ¬ Cons[Cons[keyw[key], Cons[val, NIL]], list];
};
IF res.imageProperties # NIL THEN Put[imageProperties, ListFromPropList[res.imageProperties]];
IF res.colorOperator # NIL THEN Put[colorOperator, res.colorOperator];
IF res.colorImage # NIL THEN Put[colorImage, res.colorImage];
IF res.maskImage # NIL THEN Put[maskImage, res.maskImage];
IF res.yDimension # -1 THEN Put[yDimension, MakeFixnum[res.yDimension]];
IF res.xDimension # -1 THEN Put[xDimension, MakeFixnum[res.xDimension]];
Put[imageScale, Cons[Flo[res.imageScale.x], Cons[Flo[res.imageScale.y], NIL]]];
Put[header, StringFromRope[res.header]];
};
ListFromPropList: PROC [props: Prop.PropList] RETURNS [ProperList] ~ {
RETURN [IF props = NIL THEN NIL ELSE Cons[AnyFromREF[props.first.key], Cons[AnyFromREF[props.first.val], ListFromPropList[props.rest]]]]
};
PropListFromList: PROC [list: Any] RETURNS [Prop.PropList] ~ {
IF list = NIL THEN RETURN [NIL];
IF Cdr[list] = NIL THEN Complain[list, "odd element in property list"];
RETURN [Prop.Put[
propList: PropListFromList[Cdr[Cdr[list]]],
key: REFFromAny[Car[list]],
val: REFFromAny[Car[Cdr[list]]]
]]
};
Flo: PROC [real: REAL] RETURNS [Flonum] ~ {
RETURN [NEW[NumberRep.flonum ¬ [FALSE, flonum[real]]]]
};
AnyFromREF: PROC [ref: REF] RETURNS [Any] ~ {
WITH ref SELECT FROM
r: REF REAL => RETURN [Flo[r­]];
r: ROPE => RETURN [StringFromRope[r]];
lora: LIST OF REF => RETURN [Cons[AnyFromREF[lora.first], AnyFromREF[lora.rest]]];
props: Prop.PropList => RETURN [ListFromPropList[props]];
ENDCASE => RETURN [ref];
};
REFFromAny: PROC [any: Any] RETURNS [REF] ~ {
WITH any SELECT FROM
r: Number => RETURN [NEW[REAL ¬ TheREAL[r]]];
s: String => RETURN [RopeFromString[s]];
pair: ProperList => {
lora: LIST OF REF ~ NARROW[REFFromAny[pair.cdr]];
RETURN [CONS[pair.car, lora]]
};
ENDCASE => RETURN [any];
};
RegisterInterpress: PROC [env: Environment] ~ {
DefinePrimitive[name: "open-interpress-output", nArgs: 1, optional: 0, dotted: FALSE, proc: InterpressPrim, env: env, data: E[openinterpressoutput], doc: "(file-name) Open an Interpress output handle"];
DefinePrimitive[name: "declare-interpress-value", nArgs: 2, optional: 0, dotted: FALSE, proc: InterpressPrim, env: env, data: E[declareinterpressvalue], doc: "(interpress-output-handle object) Declares a value (font, pixel-array, color, color-operator, etc.) that is likely to be used multiple times, so that it need be placed into the interpress master only once."];
DefinePrimitive[name: "write-interpress-page", nArgs: 2, optional: 0, dotted: FALSE, proc: InterpressPrim, env: env, data: E[writeinterpresspage], doc: "(interpress-output-handle page-action) write an interpress page"];
DefinePrimitive[name: "close-interpress-output", nArgs: 1, optional: 0, dotted: FALSE, proc: InterpressPrim, env: env, data: E[closeinterpressoutput], doc: "(interpress-output-handle) close an Interpress output handle"];
DefinePrimitive[name: "interpress-output?", nArgs: 1, optional: 0, dotted: FALSE, proc: InterpressPrim, env: env, data: E[interpressoutputpred], doc: "test for an Interpress output handle"];
DefinePrimitive[name: "open-interpress-input", nArgs: 1, optional: 0, dotted: FALSE, proc: InterpressPrim, env: env, data: E[openinterpressinput], doc: "(file-name) Open an Interpress input handle"];
DefinePrimitive[name: "interpress-input-page-count", nArgs: 1, optional: 0, dotted: FALSE, proc: InterpressPrim, env: env, data: E[interpressinputpagecount], doc: "(interpress-input-handle) Returns the number of pages in the interpress master"];
DefinePrimitive[name: "interpress-input?", nArgs: 1, optional: 0, dotted: FALSE, proc: InterpressPrim, env: env, data: E[interpressinputpred], doc: "test for an Interpress input handle"];
DefinePrimitive[name: "interpret-interpress-page", nArgs: 3, optional: 0, dotted: FALSE, proc: InterpressPrim, env: env, data: E[interpretinterpresspage], doc: "(interpress-input-handle page-number imager-context) Interpret an Interpress page into a context"];
DefinePrimitive[name: "close-interpress-input", nArgs: 1, optional: 0, dotted: FALSE, proc: InterpressPrim, env: env, data: E[closeinterpressinput], doc: "(interpress-input-handle) close an Interpress input handle"];
DefinePrimitive[name: "xerox-compress-pixel-array", nArgs: 1, optional: 0, dotted: FALSE, proc: InterpressPrim, env: env, data: E[xeroxcompresspixelarray], doc: "(pixel-array) make a xerox/compressed pixel-array from a one-bit-per-pixel pixel-array"];
DefinePrimitive[name: "write-raster-encoding-standard-file", nArgs: 2, optional: 0, dotted: FALSE, proc: InterpressPrim, env: env, data: E[writerasterencodingstandardfile], doc: "(filename res-description) Creates a Xerox Raster Encoding Standard file; `((header ,...) (image-scale (,... ,...)) (x-dimension ,...) (y-dimension ,...) (mask-image ,...) (color-image ,...) (color-operator ,...) (image-properties ,...))"];
DefinePrimitive[name: "write-restricted-res", nArgs: 5, optional: 1, dotted: FALSE, proc: InterpressPrim, env: env, data: E[writerestrictedres], doc: "(output-port pixel-array resolution as-mask? [ name-string ]) Creates a Xerox Restricted Raster Encoding Standard file"];
DefinePrimitive[name: "read-raster-encoding-standard-file", nArgs: 1, optional: 0, dotted: FALSE, proc: InterpressPrim, env: env, data: E[readrasterencodingstandardfile], doc: "(filename) Reads a Xerox Raster Encoding Standard file"];
};
RegisterInit[RegisterInterpress];
END.