~
BEGIN
PrimitiveProc:
TYPE ~
PROC [self: Scheme.Primitive, a, b, c: Any, rest: Scheme.ProperList]
RETURNS [result: Any ←
NIL];
BitsFor:
PROC [i: ImagerSample.Sample]
RETURNS [
NAT] ~ {
RETURN [SELECT TRUE FROM i < 2 => 1, i < 4 => 2, i < 16 => 4, i < 256 => 8 ENDCASE => 16]
};
MakeBrickPrim: PrimitiveProc ~ {
brickPattern: Any ~ a;
maxSample: ImagerSample.Sample ~ Scheme.KCheck[b, ImagerSample.Sample.LAST];
phase: NAT ~ Scheme.KCheck[c, NAT.LAST];
sSize: INT ~ Scheme.VectorLength[brickPattern];
fSize: INT ~ Scheme.VectorLength[Scheme.VectorRef[brickPattern, 0]];
sampleMap: ImagerSample.RasterSampleMap ~ ImagerSample.NewSampleMap[box: [max: [sSize, fSize]], bitsPerSample: BitsFor[maxSample]];
halftoneProperties: PrintColor.HalftoneProperties ~ LIST[[type: $custom, toner: black, brick: [maxSample: maxSample, sampleMap: sampleMap, phase: phase]]];
ImagerSample.Clear[sampleMap];
FOR s:
INT
IN [0..sSize)
DO
v: Any ~ Scheme.VectorRef[brickPattern, s];
IF Scheme.VectorLength[v] # fSize THEN Scheme.Complain[brickPattern, "is not a vector of equi-length vectors"];
FOR f:
INT
IN [0..fSize)
DO
value: ImagerSample.Sample ~ Scheme.KCheck[Scheme.VectorRef[v, f], ImagerSample.Sample.LAST];
ImagerSample.Put[map: sampleMap, index: [s, f], value: value];
ENDLOOP;
ENDLOOP;
RETURN [halftoneProperties]
};
MakeDotScreenBrickPrim: PrimitiveProc ~ {
Scheme.Complain[$MakeDotScreenBrickPrim, "not yet implemented"];
};
PrinterContextPrim: PrimitiveProc ~ {
sSize: INT ~ Scheme.KCheck[a, NAT.LAST];
fSize: INT ~ Scheme.KCheck[b, NAT.LAST];
bitmap: ImagerSample.SampleMap ~ ImagerSample.NewSampleMap[box: [max: [s: sSize, f: fSize]]];
logicalDevice: PrintColor.LogicalDevice ← 0;
halftoneProperties: PrintColor.HalftoneProperties ~
WITH c
SELECT
FROM
p: PrintColor.HalftoneProperties => p,
ENDCASE => Scheme.Complain[c, "is not a PrintColor.HalftoneProperties"];
context: Imager.Context ~ ImagerPrintContext.Create[deviceSpaceSize: [s: sSize, f: fSize], scanMode: [slow: down, fast: right], surfaceUnitsPerInch: [300, 300], logicalDevice: logicalDevice, halftoneProperties: halftoneProperties, interpolate: TRUE];
ImagerSample.Clear[bitmap];
ImagerPrintContext.SetBitmap[context, bitmap];
Imager.PutProp[context: context, key: $Bitmap, val: bitmap];
};
ClearPagePrim: PrimitiveProc ~ {
context: Imager.Context ~
WITH a
SELECT
FROM
ctx: Imager.Context => ctx,
ENDCASE => Scheme.Complain[a, "is not an Imager.Context"];
Action:
PROC ~ {
Imager.SetGray[context, 0];
Imager.MaskRectangle[context, ImagerBackdoor.GetBounds[context]];
};
};
WritePrinterAISPrim: PrimitiveProc ~ {
filename: Rope.ROPE ~ Scheme.RopeFromString[Scheme.TheString[a]];
context: Imager.Context ~ TheImagerContext[b];
bitmap: ImagerSample.SampleMap ~
WITH Imager.GetProp[context: context, key: $Bitmap]
SELECT
FROM
s: ImagerSample.SampleMap => s,
ENDCASE => Scheme.Complain[b, "is not a printer bitmap context"];
ERROR;
};
OpenInterpressPrim: PrimitiveProc ~ {
filename: Rope.ROPE ~ Scheme.RopeFromString[Scheme.TheString[a]];
ref: Interpress.Master ~ Interpress.Open[fileName: filename, log: Log];
RETURN [ref]
};
TheInterpressMaster:
PROC [a: Any]
RETURNS [Interpress.Master] ~ {
RETURN [
WITH a
SELECT
FROM
master: Interpress.Master => master,
ENDCASE => Scheme.Complain[a, "is not a handle on an Interpress master"]]
};
TheImagerContext:
PROC [a: Any]
RETURNS [Imager.Context] ~ {
RETURN [
WITH a
SELECT
FROM
context: Imager.Context => context,
ENDCASE => Scheme.Complain[a, "is not an imager context"]]
};
InterpressPagesPrim: PrimitiveProc ~ {
ref: Interpress.Master ~ TheInterpressMaster[a];
RETURN [Scheme.MakeFixnum[ref.pages]]
};
DoInterpressPagePrim: PrimitiveProc ~ {
master: Interpress.Master ~ TheInterpressMaster[a];
page: INT ~ Scheme.KCheck[b];
context: Imager.Context ~ TheImagerContext[c];
Interpress.DoPage[master: master, page: page, context: context, log: Log];
};
Log: Interpress.LogProc = {
[class: INT, code: ATOM, explanation: ROPE]
msg: Scheme.String ~ Scheme.StringFromRope[Rope.Cat["\nInterpress error: ", explanation, " "]];
stream: IO.STREAM ~ Scheme.ThePort[Scheme.undefined];
IO.PutRope[stream, "\nInterpress error: "];
IO.PutRope[stream, explanation];
IO.PutRope[stream, " "];
};
Init:
PROC [env: Scheme.Environment] ~ {
Scheme.DefinePrimitive[name: "make-brick", nArgs: 3, dotted: FALSE, proc: MakeBrickPrim, doc: "(brick max-sample phase) Create a brick with explicit thresholds", env: env];
Scheme.DefinePrimitive[name: "make-dot-screen-brick", nArgs: 7, dotted: FALSE, proc: MakeDotScreenBrickPrim, doc: "(pixels-per-dot degrees [ shape allowedRelativeError minLevels maxSample pixelToDevice ]) Create a brick from a dot screen", env: env];
Scheme.DefinePrimitive[name: "printer-context", nArgs: 3, dotted: FALSE, proc: PrinterContextPrim, doc: "(s-size f-size brick) Create a printer bitmap context", env: env];
Scheme.DefinePrimitive[name: "clear-page", nArgs: 1, dotted: FALSE, proc: ClearPagePrim, doc: "(context) Clear the page to white", env: env];
Scheme.DefinePrimitive[name: "write-printer-ais", nArgs: 2, dotted: FALSE, proc: WritePrinterAISPrim, doc: "(file-name source-context) write a binary AIS file", env: env];
Scheme.DefinePrimitive[name: "open-interpress", nArgs: 1, dotted: FALSE, proc: OpenInterpressPrim, doc: "(file-name) Open a handle on an Interpress master", env: env];
Scheme.DefinePrimitive[name: "interpress-pages", nArgs: 1, dotted: FALSE, proc: InterpressPagesPrim, doc: "(interpress-handle) Returns number of pages in an Interpress master", env: env];
Scheme.DefinePrimitive[name: "do-interpress-page", nArgs: 3, dotted: FALSE, proc: DoInterpressPagePrim, doc: "(interpress-handle page context) write a binary AIS file", env: env];
Scheme.DefinePrimitive[name: Rope.ROPE, nArgs: NAT, dotted: BOOL, proc: PrimProc, doc: Rope.ROPE, env: Environment, data: REF ← NIL, optional: NAT ← 0];
};
Scheme.RegisterInit[5, Init];