
    <<SCTestImpl.mesa>>
        <<Copyright Ó 1988 by Xerox Corporation.  All rights reserved.>>
        <<Michael Plass, March 15, 1988 5:37:42 pm PST>>

    DIRECTORY IO, ImagerBackdoor, Interpress, Scheme, Imager, AIS, ImagerSample, PrintColor, ImagerBitmapContext, ImagerPrintContext, 
    Rope;

    SCTestImpl: CEDAR PROGRAM
    IMPORTS IO, ImagerBackdoor, Interpress, Scheme, Imager, AIS, ImagerSample, PrintColor, ImagerPrintContext, Rope
    ~ BEGIN

        Any: TYPE ~ Scheme.Any;

        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];

    END.