
    <<PS4Impl.mesa>>
        <<Copyright Ó 1986 by Xerox Corporation.  All rights reserved.>>
        <<Doug Wyatt, October 30, 1986 4:30:06 pm PST>>

    <<PostScript implementation: graphics state.>>
    <<>>
    DIRECTORY
        PS,
        RealFns;

    PS4Impl: CEDAR PROGRAM
    IMPORTS PS, RealFns
    ~ BEGIN OPEN PS;
<<Graphics state operators>>
HSBColor: TYPE ~ RECORD [hue, sat, brt: REAL];
RGBColor: TYPE ~ RECORD [red, green, blue: REAL];

ColorFromGray: PROC [gray: REAL] RETURNS [Color] ~ {
RETURN [NIL];
};

ColorFromHSB: PROC [hsb: HSBColor] RETURNS [Color] ~ {
RETURN [NIL];
};

ColorFromRGB: PROC [rgb: RGBColor] RETURNS [Color] ~ {
RETURN [NIL];
};

GrayFromColor: PROC [color: Color] RETURNS [REAL] ~ {
RETURN [0];
};

HSBFromColor: PROC [color: Color] RETURNS [HSBColor] ~ {
RETURN [[0,0,0]];
};

RGBFromColor: PROC [color: Color] RETURNS [RGBColor] ~ {
RETURN [[0,0,0]];
};

    Pgsave: PROC [self: Root] ~ {
    new: GState ~ NEW [GStateRep _ self.graphics^];
    new.rest _ self.graphics;
    self.graphics _ new;
        };

    Pgrestore: PROC [self: Root] ~ {
        IF self.graphics.rest#NIL THEN self.graphics _ self.graphics.rest;
        };

    Pgrestoreall: PROC [self: Root] ~ {
        WHILE self.graphics.rest#NIL DO self.graphics _ self.graphics.rest ENDLOOP;
        };

    Pinitgraphics: PROC [self: Root] ~ {
        <<******** fix this ********>>
        <<InitGraphics[self.graphics];>>
        };

    Psetlinewidth: PROC [self: Root] ~ {
        self.graphics.lineWidth _ PopReal[self.ostack];
        };

    Pcurrentlinewidth: PROC [self: Root] ~ {
        PushReal[self.ostack, self.graphics.lineWidth];
        };

    Psetlinecap: PROC [self: Root] ~ {
        int: INT ~ PopInt[self.ostack];
        IF int IN[0..2] THEN self.graphics.lineCap _ VAL[CARDINAL[int]]
        ELSE ERROR Error[rangecheck];
        };

    Pcurrentlinecap: PROC [self: Root] ~ {
        PushInt[self.ostack, ORD[self.graphics.lineCap]];
        };

    Psetlinejoin: PROC [self: Root] ~ {
        int: INT ~ PopInt[self.ostack];
        IF int IN[0..2] THEN self.graphics.lineJoin _ VAL[CARDINAL[int]]
        ELSE ERROR Error[rangecheck];
        };

    Pcurrentlinejoin: PROC [self: Root] ~ {
        PushInt[self.ostack, ORD[self.graphics.lineJoin]];
        };

    Psetmiterlimit: PROC [self: Root] ~ {
        self.graphics.miterLimit _ PopReal[self.ostack];
        };

    Pcurrentmiterlimit: PROC [self: Root] ~ {
        PushReal[self.ostack, self.graphics.miterLimit];
        };

    Psetdash: PROC [self: Root] ~ {
        offset: REAL ~ PopReal[self.ostack];
        array: Array ~ PopArray[self.ostack];
        self.graphics.dashArray _ array;
        self.graphics.dashOffset _ offset;
        };

    Pcurrentdash: PROC [self: Root] ~ {
        PushArray[self.ostack, self.graphics.dashArray];
        PushReal[self.ostack, self.graphics.dashOffset];
        };

    Psetflat: PROC [self: Root] ~ {
        self.graphics.flatness _ PopReal[self.ostack];
        };

    Pcurrentflat: PROC [self: Root] ~ {
        PushReal[self.ostack, self.graphics.flatness];
        };

    Psetgray: PROC [self: Root] ~ {
        gray: REAL ~ PopReal[self.ostack];
        self.graphics.color _ ColorFromGray[gray];
        };

    Pcurrentgray: PROC [self: Root] ~ {
        PushReal[self.ostack, GrayFromColor[self.graphics.color]];
        };

    Psethsbcolor: PROC [self: Root] ~ {
        hsb: HSBColor;
        hsb.brt _ PopReal[self.ostack];
        hsb.sat _ PopReal[self.ostack];
        hsb.hue _ PopReal[self.ostack];
        self.graphics.color _ ColorFromHSB[hsb];
        };

    Pcurrenthsbcolor: PROC [self: Root] ~ {
        hsb: HSBColor ~ HSBFromColor[self.graphics.color];
        PushReal[self.ostack, hsb.hue];
        PushReal[self.ostack, hsb.sat];
        PushReal[self.ostack, hsb.brt];
        };

    Psetrgbcolor: PROC [self: Root] ~ {
        rgb: RGBColor;
        rgb.blue _ PopReal[self.ostack];
        rgb.green _ PopReal[self.ostack];
        rgb.red _ PopReal[self.ostack];
        self.graphics.color _ ColorFromRGB[rgb];
        };

    Pcurrentrgbcolor: PROC [self: Root] ~ {
        rgb: RGBColor ~ RGBFromColor[self.graphics.color];
        PushReal[self.ostack, rgb.red];
        PushReal[self.ostack, rgb.green];
        PushReal[self.ostack, rgb.blue];
        };

    Psetscreen: PROC [self: Root] ~ {
        proc: Array ~ PopArray[self.ostack];
        angle: REAL ~ PopReal[self.ostack];
        frequency: REAL ~ PopReal[self.ostack];
        self.graphics.screenFrequency _ frequency;
        self.graphics.screenAngle _ angle;
        self.graphics.screenProc _ proc;
        };

    Pcurrentscreen: PROC [self: Root] ~ {
        PushReal[self.ostack, self.graphics.screenFrequency];
        PushReal[self.ostack, self.graphics.screenAngle];
        PushArray[self.ostack, self.graphics.screenProc];
        };

    Psettransfer: PROC [self: Root] ~ {
        proc: Array ~ PopArray[self.ostack];
        self.graphics.transfer _ proc;
        };

    Pcurrenttransfer: PROC [self: Root] ~ {
        PushArray[self.ostack, self.graphics.transfer];
        };

<<Coordinate system and matrix operators>>
    TransformationFromMatrix: PROC [matrix: Array] RETURNS [t: Transformation] ~ {
        IF matrix.length#6 THEN ERROR Error[typecheck];
        RETURN [[
            a: RealFromAny[ArrayGet[matrix, 0]],
            b: RealFromAny[ArrayGet[matrix, 1]],
            c: RealFromAny[ArrayGet[matrix, 2]],
            d: RealFromAny[ArrayGet[matrix, 3]],
            tx: RealFromAny[ArrayGet[matrix, 4]],
            ty: RealFromAny[ArrayGet[matrix, 5]]
            ]];
        };

    TransformationToMatrix: PROC [t: Transformation, matrix: Array] ~ {
        IF matrix.length#6 THEN ERROR Error[typecheck];
        ArrayPut[matrix, 0, AnyFromReal[t.a]];
        ArrayPut[matrix, 1, AnyFromReal[t.b]];
        ArrayPut[matrix, 2, AnyFromReal[t.c]];
        ArrayPut[matrix, 3, AnyFromReal[t.d]];
        ArrayPut[matrix, 4, AnyFromReal[t.tx]];
        ArrayPut[matrix, 5, AnyFromReal[t.ty]];
        };

    Identity: PROC RETURNS [Transformation] ~ {
        RETURN [[1, 0, 0, 1, 0, 0]];
        };

    Translate: PROC [t: VEC] RETURNS [Transformation] ~ {
        RETURN [[1, 0, 0, 1, t.x, t.y]];
        };

    Scale: PROC [s: VEC] RETURNS [Transformation] ~ {
        RETURN [[s.x, 0, 0, s.y, 0, 0]];
        };

    Rotate: PROC [angle: REAL] RETURNS [Transformation] ~ {
        cos: REAL ~ RealFns.CosDeg[angle];
        sin: REAL ~ RealFns.SinDeg[angle];
        RETURN [[cos, sin, -sin, cos, 0, 0]];
        };

    Concat: PROC [m1, m2: Transformation] RETURNS [Transformation] ~ {
        RETURN [[
            a: m1.a*m2.a+m1.b*m2.c,
            b: m1.a*m2.b+m1.b*m2.d,
            c: m1.c*m2.a+m1.d*m2.c,
            d: m1.c*m2.b+m1.d*m2.d,
            tx: m1.tx*m2.a+m1.ty*m2.c+m2.tx,
            ty: m1.tx*m2.b+m1.ty*m2.d+m2.ty
            ]];
        };

    Transform: PROC [p: VEC, m: Transformation] RETURNS [VEC] ~ {
        RETURN [[
            x: m.a*p.x+m.c*p.y+m.tx,
            y: m.b*p.x+m.d*p.y+m.ty
            ]];
        };

    DTransform: PROC [d: VEC, m: Transformation] RETURNS [VEC] ~ {
        RETURN [[
            x: m.a*d.x+m.c*d.y,
            y: m.b*d.x+m.d*d.y
            ]];
        };

    ITransform: PROC [p: VEC, m: Transformation] RETURNS [VEC] ~ {
        RETURN [Transform[p, Invert[m]]];
        };

    IDTransform: PROC [d: VEC, m: Transformation] RETURNS [VEC] ~ {
        RETURN [DTransform[d, Invert[m]]];
        };

    Invert: PROC [m: Transformation] RETURNS [Transformation] ~ {
        det: REAL ~ m.a*m.d - m.b*m.c;
        RETURN [[
            a: m.d/det,
            b: -m.b/det,
            c: -m.c/det,
            d: m.a/det,
            tx: (m.c*m.ty - m.d*m.tx)/det,
            ty: (m.b*m.tx - m.a*m.ty)/det
            ]];
        };


    Pmatrix: PROC [self: Root] ~ {
        matrix: Array ~ ArrayNew[6];
        TransformationToMatrix[Identity[], matrix];
        PushArray[self.ostack, matrix];
        };

    Pinitmatrix: PROC [self: Root] ~ {
        };

    Pidentmatrix: PROC [self: Root] ~ {
        matrix: Array ~ PopArray[self.ostack];
        TransformationToMatrix[Identity[], matrix];
        PushArray[self.ostack, matrix];
        };

    Pdefaultmatrix: PROC [self: Root] ~ {
        matrix: Array ~ PopArray[self.ostack];
        <<******** fix this ********>>
        PushArray[self.ostack, matrix];
        };

    Pcurrentmatrix: PROC [self: Root] ~ {
        matrix: Array ~ PopArray[self.ostack];
        TransformationToMatrix[self.graphics.CTM, matrix];
        PushArray[self.ostack, matrix];
        };

    Psetmatrix: PROC [self: Root] ~ {
        matrix: Array ~ PopArray[self.ostack];
        self.graphics.CTM _ TransformationFromMatrix[matrix];
        };

    Ptranslate: PROC [self: Root] ~ {
        IF TopType[self.ostack]=array THEN {
            matrix: Array ~ PopArray[self.ostack];
            t: VEC ~ PopVec[self.ostack];
            TransformationToMatrix[Translate[t], matrix];
            PushArray[self.ostack, matrix];
            }
        ELSE {
            t: VEC ~ PopVec[self.ostack];
            self.graphics.CTM _ Concat[Translate[t], self.graphics.CTM];
            };
        };

    Pscale: PROC [self: Root] ~ {
        IF TopType[self.ostack]=array THEN {
            matrix: Array ~ PopArray[self.ostack];
            s: VEC ~ PopVec[self.ostack];
            TransformationToMatrix[Scale[s], matrix];
            PushArray[self.ostack, matrix];
            }
        ELSE {
            s: VEC ~ PopVec[self.ostack];
            self.graphics.CTM _ Concat[Scale[s], self.graphics.CTM];
            };
        };

    Protate: PROC [self: Root] ~ {
        IF TopType[self.ostack]=array THEN {
            matrix: Array ~ PopArray[self.ostack];
            angle: REAL ~ PopReal[self.ostack];
            TransformationToMatrix[Rotate[angle], matrix];
            PushArray[self.ostack, matrix];
            }
        ELSE {
            angle: REAL ~ PopReal[self.ostack];
            self.graphics.CTM _ Concat[Rotate[angle], self.graphics.CTM];
            };
        };

    Pconcat: PROC [self: Root] ~ {
        matrix: Array ~ PopArray[self.ostack];
        self.graphics.CTM _ Concat[TransformationFromMatrix[matrix], self.graphics.CTM];
        };

    Pconcatmatrix: PROC [self: Root] ~ {
        matrix3: Array ~ PopArray[self.ostack];
        matrix2: Array ~ PopArray[self.ostack];
        matrix1: Array ~ PopArray[self.ostack];
        TransformationToMatrix[Concat[TransformationFromMatrix[matrix1], TransformationFromMatrix[matrix2]], matrix3];
        PushArray[self.ostack, matrix3];
        };

    Ptransform: PROC [self: Root] ~ {
        IF TopType[self.ostack]=array THEN {
            matrix: Array ~ PopArray[self.ostack];
            p: VEC ~ PopVec[self.ostack];
            PushVec[self.ostack, Transform[p, TransformationFromMatrix[matrix]]];
            }
        ELSE {
            p: VEC ~ PopVec[self.ostack];
            PushVec[self.ostack, Transform[p, self.graphics.CTM]];
            };
        };

    Pdtransform: PROC [self: Root] ~ {
        IF TopType[self.ostack]=array THEN {
            matrix: Array ~ PopArray[self.ostack];
            d: VEC ~ PopVec[self.ostack];
            PushVec[self.ostack, DTransform[d, TransformationFromMatrix[matrix]]];
            }
        ELSE {
            d: VEC ~ PopVec[self.ostack];
            PushVec[self.ostack, DTransform[d, self.graphics.CTM]];
            };
        };

    Pitransform: PROC [self: Root] ~ {
        IF TopType[self.ostack]=array THEN {
            matrix: Array ~ PopArray[self.ostack];
            p: VEC ~ PopVec[self.ostack];
            PushVec[self.ostack, ITransform[p, TransformationFromMatrix[matrix]]];
            }
        ELSE {
            p: VEC ~ PopVec[self.ostack];
            PushVec[self.ostack, ITransform[p, self.graphics.CTM]];
            };
        };

    Pidtransform: PROC [self: Root] ~ {
        IF TopType[self.ostack]=array THEN {
            matrix: Array ~ PopArray[self.ostack];
            d: VEC ~ PopVec[self.ostack];
            PushVec[self.ostack, IDTransform[d, TransformationFromMatrix[matrix]]];
            }
        ELSE {
            d: VEC ~ PopVec[self.ostack];
            PushVec[self.ostack, IDTransform[d, self.graphics.CTM]];
            };
        };

    Pinvertmatrix: PROC [self: Root] ~ {
        matrix2: Array ~ PopArray[self.ostack];
        matrix1: Array ~ PopArray[self.ostack];
        TransformationToMatrix[Invert[TransformationFromMatrix[matrix1]], matrix2];
        PushArray[self.ostack, matrix2];
        };


<<Path construction operators>>
    Pnewpath: PROC [self: Root] ~ {
        };

    Pcurrentpoint: PROC [self: Root] ~ {
        };

    Pmoveto: PROC [self: Root] ~ {
        };

    Prmoveto: PROC [self: Root] ~ {
        };

    Plineto: PROC [self: Root] ~ {
        };

    Prlineto: PROC [self: Root] ~ {
        };

    Parc: PROC [self: Root] ~ {
        };

    Parcn: PROC [self: Root] ~ {
        };

    Parcto: PROC [self: Root] ~ {
        };

    Pcurveto: PROC [self: Root] ~ {
        };

    Prcurveto: PROC [self: Root] ~ {
        };

    Pclosepath: PROC [self: Root] ~ {
        };

    Pflattenpath: PROC [self: Root] ~ {
        };

    Preversepath: PROC [self: Root] ~ {
        };

    Pstrokepath: PROC [self: Root] ~ {
        };

    Pcharpath: PROC [self: Root] ~ {
        };

    Pclippath: PROC [self: Root] ~ {
        };

    Ppathbbox: PROC [self: Root] ~ {
        };

    Ppathforall: PROC [self: Root] ~ {
        };

    Pinitclip: PROC [self: Root] ~ {
        };

    Pclip: PROC [self: Root] ~ {
        };

    Peoclip: PROC [self: Root] ~ {
        };

<<Registration>>
Register4: PROC [self: Root] ~ {
    Register[self, "gsave", Pgsave];
    Register[self, "grestore", Pgrestore];
    Register[self, "grestoreall", Pgrestoreall];
    Register[self, "initgraphics", Pinitgraphics];
    Register[self, "setlinewidth", Psetlinewidth];
    Register[self, "currentlinewidth", Pcurrentlinewidth];
    Register[self, "setlinecap", Psetlinecap];
    Register[self, "currentlinecap", Pcurrentlinecap];
    Register[self, "setlinejoin", Psetlinejoin];
    Register[self, "currentlinejoin", Pcurrentlinejoin];
    Register[self, "setmiterlimit", Psetmiterlimit];
    Register[self, "currentmiterlimit", Pcurrentmiterlimit];
    Register[self, "setdash", Psetdash];
    Register[self, "currentdash", Pcurrentdash];
    Register[self, "setflat", Psetflat];
    Register[self, "currentflat", Pcurrentflat];
    Register[self, "setgray", Psetgray];
    Register[self, "currentgray", Pcurrentgray];
    Register[self, "sethsbcolor", Psethsbcolor];
    Register[self, "currenthsbcolor", Pcurrenthsbcolor];
    Register[self, "setrgbcolor", Psetrgbcolor];
    Register[self, "currentrgbcolor", Pcurrentrgbcolor];
    Register[self, "setscreen", Psetscreen];
    Register[self, "currentscreen", Pcurrentscreen];
    Register[self, "settransfer", Psettransfer];
    Register[self, "currenttransfer", Pcurrenttransfer];

    Register[self, "matrix", Pmatrix];
    Register[self, "initmatrix", Pinitmatrix];
    Register[self, "identmatrix", Pidentmatrix];
    Register[self, "defaultmatrix", Pdefaultmatrix];
    Register[self, "currentmatrix", Pcurrentmatrix];
    Register[self, "setmatrix", Psetmatrix];
    Register[self, "translate", Ptranslate];
    Register[self, "scale", Pscale];
    Register[self, "rotate", Protate];
    Register[self, "concat", Pconcat];
    Register[self, "concatmatrix", Pconcatmatrix];
    Register[self, "transform", Ptransform];
    Register[self, "dtransform", Pdtransform];
    Register[self, "itransform", Pitransform];
    Register[self, "idtransform", Pidtransform];
    Register[self, "invertmatrix", Pinvertmatrix];

    Register[self, "newpath", Pnewpath];
    Register[self, "currentpoint", Pcurrentpoint];
    Register[self, "moveto", Pmoveto];
    Register[self, "rmoveto", Prmoveto];
    Register[self, "lineto", Plineto];
    Register[self, "rlineto", Prlineto];
    Register[self, "arc", Parc];
    Register[self, "arcn", Parcn];
    Register[self, "arcto", Parcto];
    Register[self, "curveto", Pcurveto];
    Register[self, "rcurveto", Prcurveto];
    Register[self, "closepath", Pclosepath];
    Register[self, "flattenpath", Pflattenpath];
    Register[self, "reversepath", Preversepath];
    Register[self, "strokepath", Pstrokepath];
    Register[self, "charpath", Pcharpath];
    Register[self, "clippath", Pclippath];
    Register[self, "pathbbox", Ppathbbox];
    Register[self, "pathforall", Ppathforall];
    Register[self, "initclip", Pinitclip];
    Register[self, "clip", Pclip];
    Register[self, "eoclip", Peoclip];
};

RegisterPrimitives[Register4];

END.