~
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]];
brick: REF ImagerBitmapContext.Brick ~ NEW[ImagerBitmapContext.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 [brick]
};
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]]];
brick:
REF ImagerBitmapContext.Brick ~
WITH c
SELECT
FROM
p: REF ImagerBitmapContext.Brick => p,
ENDCASE => Scheme.Complain[c, "is not a REF ImagerBitmapContext.Brick"];
context: Imager.Context ~ ImagerBitmapContext.Create[deviceSpaceSize: [s: sSize, f: fSize], scanMode: [slow: down, fast: right], surfaceUnitsPerInch: [300, 300], pixelUnits: TRUE, fontCacheName: $PrinterBitmap];
ImagerSample.Clear[bitmap];
ImagerBitmapContext.SetBitmap[context, bitmap];
ImagerBitmapContext.SetBrick[context, brick^];
Imager.PutProp[context: context, key: $Bitmap, val: bitmap];
RETURN [context]
};
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]];
};
Imager.DoSave[context, Action];
RETURN [Scheme.unspecified]
};
Debug: SIGNAL ~ CODE;
DebugPrim: PrimitiveProc ~ {
SIGNAL Debug};
PixelArrayFromPrinterContextPrim: PrimitiveProc ~ {
context: Imager.Context ~ TheImagerContext[a];
bitmap: ImagerSample.SampleMap ~
WITH Imager.GetProp[context: context, key: $Bitmap]
SELECT
FROM
s: ImagerSample.SampleMap => s,
ENDCASE => Scheme.Complain[a, "is not a printer bitmap context"];
pa: ImagerPixelArray.PixelArray ~ ImagerPixelArray.FromPixelMap[pixelMap: ImagerPixel.MakePixelMap[bitmap], box: ImagerSample.GetBox[bitmap], scanMode: [slow: down, fast: right], immutable: FALSE];
RETURN [pa]
};
ThePixelArray:
PROC [a: Any]
RETURNS [ImagerPixelArray.PixelArray] ~ {
WITH a
SELECT
FROM
pa: ImagerPixelArray.PixelArray => RETURN [pa];
ENDCASE => Scheme.Complain[a, "is not a pixel-array"];
};
WriteAISPrim: PrimitiveProc ~ {
filename: Rope.ROPE ~ Scheme.RopeFromString[Scheme.TheString[a]];
pa: ImagerPixelArray.PixelArray ~ ThePixelArray[b];
binary: BOOL ~ NOT (c=Scheme.false OR c=NIL);
ConvertRasterObject.AISFromPixelArray[aisfile: filename, pixelArray: pa, sep: 0];
IF binary
THEN {
Scheme.Complain[a, "binary mode is not implemented"];
};
};
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: "debug", nArgs: 3, dotted: TRUE, proc: DebugPrim, doc: "Call the Cedar debugger", env: env, optional: 3];
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: "pixel-array-from-printer-context", nArgs: 1, dotted: FALSE, proc: PixelArrayFromPrinterContextPrim, doc: "(printer-context) get the printer-context bitmap as a pixel-array", env: env];
Scheme.DefinePrimitive[name: "write-ais", nArgs: 3, dotted: FALSE, proc: WriteAISPrim, doc: "(file-name pixel-array binary) write an 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];