<<>>
<<SchemeTendrilsImpl.mesa>>
    <<Copyright Ó 1988, 1991 by Xerox Corporation.  All rights reserved.>>
    <<Michael Plass, March 10, 1992 11:12 am PST>>
    <<Last changed by Pavel on September 1, 1988 6:12:33 pm PDT>>
<<>>
    DIRECTORY
        Atom USING [GetPName, MakeAtom],
        ColorDisplayManager USING [GetContext],
        FS USING [Error, ExpandName],
        Imager USING [Context, Error, GetProp, PutProp],
        ImagerBackdoor USING [GetT, TransformPoint],
        ImagerTransformation USING [Factor],
        ImagerViewer USING [ClientDataFromViewer, Erase, EraseProc, FancyCreate, GetViewer, Reset],
        IO USING [GetInfo],
        Process USING [EnableAborts],
        Rope USING [ROPE],
        Scheme USING [Any, Complain, Cons, DefinePrimitive, Environment, false, Fixnum, Flonum, LookupVariableValue, MakeFixnum, NumberRep, 
        Port, Primitive, ProperList, RegisterInit, Reverse, RopeFromString, Symbol, ThePort, TheString, true, undefined, 
        unspecified],
        StructuredStreams USING [Begin, Bp, ChangeMargin, Create, End, IsAnSS],
        TiogaAccess USING [Create, Reset, WriteFile, Writer],
        ScreenCoordsTypes USING [TIPScreenCoords, TIPScreenCoordsRec],
        UnparserBuffer USING [BreakCondition, Handle, NewInittedHandle],
        Vector2 USING [VEC],
        ViewerClasses USING [DestroyProc, NotifyProc, Viewer],
        ViewerOps USING [OpenIcon],
        ViewerPrivate USING [CreateContext];

    SchemeTendrilsImpl: CEDAR MONITOR LOCKS queue USING queue: InputQueue
    IMPORTS Atom, ColorDisplayManager, FS, Scheme, Imager, ImagerBackdoor, ImagerTransformation, ImagerViewer, IO, Process, 
    StructuredStreams, TiogaAccess, UnparserBuffer, ViewerOps, ViewerPrivate
    ~ BEGIN OPEN Scheme;
<<Generally Useful Types and Procedures>>
    ROPE: TYPE ~ Rope.ROPE;

    RopeFromSymbol: PROC [Symbol] RETURNS [ROPE] ~ Atom.GetPName;

    PrimitiveProc: TYPE ~ PROC [self: Primitive, a, b, c: Any, rest: ProperList] RETURNS [result: Any Ź NIL];

<<The Scheme StructuredStreams and TiogaAccess Interfaces>>
    TheWriter: PROC [a: Any] RETURNS [TiogaAccess.Writer] ~ INLINE {
        WITH a SELECT FROM
            w: REF TiogaAccess.Writer => RETURN [w­];
            ENDCASE => Complain[a, "not a TiogaAccess Writer"];
        };

    TAPrim: PrimitiveProc ~ {
        op: ATOM ~ NARROW[self.data];
        result Ź unspecified;
        SELECT op FROM
            $make => result Ź NEW[TiogaAccess.Writer Ź TiogaAccess.Create[]];
            $test => result Ź IF ISTYPE[a, REF TiogaAccess.Writer] THEN true ELSE false;
            $writeFile => TiogaAccess.WriteFile[TheWriter[a], RopeFromString[TheString[b]]];
            $reset => TiogaAccess.Reset[TheWriter[a]];
            ENDCASE => ERROR;
        };

    RegisterTiogaAccess: PROC [env: Environment] ~ {
        DefinePrimitive[name: "make-writer", nArgs: 0, optional: 0, dotted: FALSE, proc: TAPrim, env: env, data: $make, doc: "create a 
        TiogaAccess Writer"];
        DefinePrimitive[name: "writer?", nArgs: 1, optional: 0, dotted: FALSE, proc: TAPrim, env: env, data: $test, doc: "is this a 
        TiogaAccess Writer?"];
        DefinePrimitive[name: "write-file-from-writer", nArgs: 2, optional: 0, dotted: FALSE, proc: TAPrim, env: env, data: $writeFile, 
        doc: "write the contents of the Writer a to the file named by the string b and reset the Writer to a clean state"];
        DefinePrimitive[name: "reset-writer", nArgs: 1, optional: 0, dotted: FALSE, proc: TAPrim, env: env, data: $reset, doc: "reset the 
        Writer a to a clean state"];
        <<DefinePrimitive[name: "name", nArgs: , optional: , dotted: TRUE|FALSE, proc: TAPrim, env: env, data: $, doc: 
        "string"];>>
        };

    TheINTEGER: PROC [a: Any] RETURNS [INTEGER] ~ INLINE {
        WITH a SELECT FROM
            n: Fixnum => RETURN [n­];
            ENDCASE => Complain[a, "not a short integer"];
        };

    lookLeftSymbol: Symbol ~ Atom.MakeAtom["look-left"];

    TheBreakCondition: PROC [a: Any] RETURNS [UnparserBuffer.BreakCondition] ~ INLINE {
        WITH a SELECT FROM
            sym: Symbol =>
                SELECT sym FROM
                    $width => RETURN [width];
                    lookLeftSymbol => RETURN [lookLeft];
                    $united => RETURN [united];
                    $always => RETURN [always];
                    ENDCASE => Complain[a, "not a break condition (width look-left united always)"];
            ENDCASE => Complain[a, "not a break condition (width look-left united always)"];
        };

    SSPrim: PrimitiveProc ~ {
        op: ATOM ~ NARROW[self.data];
        result Ź unspecified;
        SELECT op FROM
            $make => {
                h: UnparserBuffer.Handle;
                WITH a SELECT FROM
                    <<writer: REF TiogaAccess.Writer => {>>
                        <<nestWidth: INTEGER ~ IF b = undefined THEN 3 ELSE TheINTEGER[b];>>
                        <<h _ UnparserBuffer.NewInittedHandle[[output: [access[writer^, nestWidth]]]];>>
                        <<};>>
                    port: Port => {
                        IF IO.GetInfo[port].variety = input THEN
                            Complain[a, "not an output port"];
                        h Ź UnparserBuffer.NewInittedHandle[[output: [stream[port]]]];
                        };
                    ENDCASE => Complain[a, "not a port or TiogaAccess Writer"];
                result Ź StructuredStreams.Create[h];
                };
            $test => {
                result Ź
                    WITH a SELECT FROM
                        port: Port => IF StructuredStreams.IsAnSS[port] THEN true ELSE false
                        ENDCASE => false;
                };
            $begin => StructuredStreams.Begin[ThePort[a]];
            $end => StructuredStreams.End[ThePort[a]];
            $break => {
                port: Port ~ ThePort[a];
                bc: UnparserBuffer.BreakCondition ~ TheBreakCondition[b];
                offset: INTEGER ~ TheINTEGER[c];
                sep: ROPE ~ IF rest = NIL THEN NIL ELSE RopeFromString[TheString[rest.car]];
                StructuredStreams.Bp[port, bc, offset, sep];
                };
            $margin => StructuredStreams.ChangeMargin[ThePort[a], TheINTEGER[b]];
            ENDCASE => ERROR;
        };

    RegisterStructuredStreams: PROC [env: Environment] ~ {
        DefinePrimitive[name: "make-structured-port", nArgs: 2, optional: 1, dotted: FALSE, proc: SSPrim, env: env, data: $make, doc: 
        "create a structured port backed by the port or TiogaAccess Writer a; b is the nesting-width of the writer"];
        DefinePrimitive[name: "structured-port?", nArgs: 1, optional: 0, dotted: FALSE, proc: SSPrim, env: env, data: $test, doc: "is this 
        a structured port?"];
        DefinePrimitive[name: "begin-structure", nArgs: 1, optional: 0, dotted: FALSE, proc: SSPrim, env: env, data: $begin, doc: "output a 
        Begin marker on the (structured) port a"];
        DefinePrimitive[name: "end-structure", nArgs: 1, optional: 0, dotted: FALSE, proc: SSPrim, env: env, data: $end, doc: "output a End 
        marker on the (structured) port a"];
        DefinePrimitive[name: "breakpoint", nArgs: 4, optional: 1, dotted: FALSE, proc: SSPrim, env: env, data: $break, doc: "output a 
        breakpoint with type b, offset c and separator d on the (structured) port d"];
        DefinePrimitive[name: "change-margin", nArgs: 2, optional: 0, dotted: FALSE, proc: SSPrim, env: env, data: $margin, doc: "change 
        the line-length of the (structured) port a to b"];
        <<DefinePrimitive[name: "name", nArgs: , optional: , dotted: TRUE|FALSE, proc: SSPrim, env: env, data: $, doc: 
        "string"];>>
        };
<<The Scheme ImagerViewer Interface>>
    TheContext: PROC [a: Any] RETURNS [Imager.Context] ~ {
        WITH a SELECT FROM
            ctx: Imager.Context => RETURN [ctx];
            ENDCASE => Complain[a, "not an Imager Context"];
        };

    Flo: PROC [real: REAL] RETURNS [Flonum] ~ {
        RETURN [NEW[NumberRep.flonum Ź [FALSE, flonum[real]]]]
        };

    IVData: TYPE ~ REF IVDataRep;
    IVDataRep: TYPE ~ RECORD [op: ATOM, env: Environment];

    defaultContextName: Symbol ~ Atom.MakeAtom["*default-context*"];
    ImagerPrim: PrimitiveProc ~ {
        Inner: PROC RETURNS [result: Any Ź unspecified] ~ {
            iData: IVData ~ NARROW[self.data];
            DefaultContext: PROC RETURNS [Imager.Context] ~ INLINE {
                RETURN [TheContext[Scheme.LookupVariableValue[variable: defaultContextName, env: iData.env]]];
                };
            SELECT iData.op FROM
                $colorcontext => { result Ź ColorDisplayManager.GetContext[] };
                $viewercontext => {
                    result Ź MakeImagerViewerContext[RopeFromString[TheString[a]]];
                    };
                $openViewer => {
                    context: Imager.Context Ź IF a = undefined THEN DefaultContext[] ELSE TheContext[a];
                    viewer: ViewerClasses.Viewer ~ ImagerViewer.GetViewer[context];
                    ViewerOps.OpenIcon[viewer];
                    };
                $viewerOpenP => {
                    context: Imager.Context Ź IF a = undefined THEN DefaultContext[] ELSE TheContext[a];
                    viewer: ViewerClasses.Viewer ~ ImagerViewer.GetViewer[context];
                    result Ź IF viewer.iconic THEN false ELSE true;
                    };
                $resetViewer => {
                    context: Imager.Context Ź IF a = undefined THEN DefaultContext[] ELSE TheContext[a];
                    ImagerViewer.Reset[context];
                    };
                $eraseViewer => {
                    context: Imager.Context Ź IF a = undefined THEN DefaultContext[] ELSE TheContext[a];
                    ImagerViewer.Erase[context];
                    };
                $viewerread => {
                    context: Imager.Context Ź IF a = undefined THEN DefaultContext[] ELSE TheContext[a];
                    WITH Imager.GetProp[context: context, key: $SchemeViewerInput] SELECT FROM
                        queue: InputQueue => {
                            event: InputEvent ~ Dequeue[queue];
                            result Ź event.args;
                            IF event.button # NIL THEN
                                result Ź Cons[event.button, result];
                            IF event.action # $destroyed THEN {
                                point: Vector2.VEC;
                                IF event.action = $erased THEN {
                                    <<Only scale the coordinates; they're a height and width.>>
                                    scale: Vector2.VEC ~ ImagerTransformation.Factor[ImagerBackdoor.GetT[context]].s;
                                    point Ź [event.mx * scale.x, event.my * scale.y];
                                    }
                                ELSE
                                    point Ź ImagerBackdoor.TransformPoint[context: context, p: [event.mx, event.my], from: view, to: client];
                                result Ź Cons[Flo[point.y], result];
                                result Ź Cons[Flo[point.x], result];
                                };
                            result Ź Cons[event.action, result];
                            };
                        ENDCASE => { result Ź false };
                    };
                $viewerinputready => {
                    context: Imager.Context Ź IF a = undefined THEN DefaultContext[] ELSE TheContext[a];
                    WITH Imager.GetProp[context: context, key: $SchemeViewerInput] SELECT FROM
                        queue: InputQueue => {
                            result Ź IF InputAvailable[queue] THEN true ELSE false;
                            };
                        ENDCASE => { result Ź false };
                    };
                $bwdisplaycontext => {
                    result Ź ViewerPrivate.CreateContext[main];
                    };
                <<$displayscreentopixelmap => {>>
                    <<result _ ImagerPixel.MakePixelMap[ImagerSample.MapFromFrameBuffer[Terminal.GetBWFrameBuffer[InterminalBackdoor.terminal]]];>>
                    <<};>>
                ENDCASE => ERROR;
            };
        result Ź Inner[ !
            Imager.Error => { Complain[$ImagerError, error.explanation] };
            FS.Error  => { IF error.group = user THEN Complain[error.code, error.explanation] };
            ];
        };

    tipTableName: ROPE ~ FS.ExpandName["Scheme.tip"].fullFName;

    MakeImagerViewerContext: PROC [name: ROPE] RETURNS [Imager.Context] ~ {
        queue: InputQueue ~ MakeInputQueue[];
        context: Imager.Context ~ ImagerViewer.FancyCreate[
            info: [name: name],
            units: pixels,
            v: NIL,
            notify: InputNotify,
            destroy: InputDestroy,
            erase: InputErase,
            tipTable: tipTableName,
            clientData: queue];
        viewer: ViewerClasses.Viewer ~ ImagerViewer.GetViewer[context]; -- may want this someday
        Imager.PutProp[context: context, key: $SchemeViewerInput, val: queue];
        RETURN [context]
        };

    InputEvent: TYPE ~ RECORD [action: ATOM Ź NIL, button: ATOM Ź NIL, mx, my: INT Ź 0, args: Any Ź NIL];

    InputQueue: TYPE ~ REF InputQueueRep;
    InputQueueRep: TYPE ~ MONITORED RECORD [
        ready: CONDITION,
        count: CARD,
        head: LIST OF InputEvent,
        last: LIST OF InputEvent
        ];

    MakeInputQueue: PROC RETURNS [InputQueue] ~ {
        head: LIST OF InputEvent ~ LIST[[]];
        queue: InputQueue ~ NEW[InputQueueRep Ź [count: 0, head: head, last: head]];
        TRUSTED { Process.EnableAborts[@queue.ready] };
        RETURN [queue]
        };

    Enqueue: ENTRY PROC [queue: InputQueue, a: InputEvent] ~ {
        queue.last Ź queue.last.rest Ź LIST[a];
        IF queue.count = 0 THEN BROADCAST queue.ready;
        queue.count Ź queue.count + 1;
        };

    InputAvailable: ENTRY PROC [queue: InputQueue] RETURNS [BOOL] ~ {
        RETURN [queue.count # 0]
        };

    Dequeue: ENTRY PROC [queue: InputQueue] RETURNS [a: InputEvent] ~ {
        ENABLE UNWIND => NULL;
        t: LIST OF InputEvent Ź NIL;
        WHILE queue.count = 0 DO WAIT queue.ready ENDLOOP;
        t Ź queue.head;
        queue.head Ź t.rest;
        t.rest Ź NIL;
        a Ź queue.head.first;
        queue.count Ź queue.count - 1;
        };

    InputDestroy: ViewerClasses.DestroyProc = {
        <<[self: ViewerClasses.Viewer]>>
        InputNotify[self, CONS[$destroyed, NIL]];
        };

    InputErase: ImagerViewer.EraseProc = {
        <<[self: Imager.Context]>>
        viewer: ViewerClasses.Viewer ~ ImagerViewer.GetViewer[self];
        dimensions: ScreenCoordsTypes.TIPScreenCoords ~
        NEW[ScreenCoordsTypes.TIPScreenCoordsRec Ź [viewer.cw, viewer.ch, FALSE]];
        InputNotify[viewer, CONS[$erased, CONS[dimensions, NIL]]];
        };

    InputNotify: ViewerClasses.NotifyProc = {
        <<[self: ViewerClasses.Viewer, input: LIST OF REF ANY]>>
        queue: InputQueue ~ NARROW[ImagerViewer.ClientDataFromViewer[self]];
        mx: INT Ź 0;
        my: INT Ź 0;
        ctrlshift: INT Ź 0;
        includeCtrlShift: BOOL Ź FALSE;
        button: ATOM Ź NIL;
        Button: PROC [atom: ATOM] ~ { IF button = NIL THEN button Ź atom ELSE bogus Ź TRUE };
        action: ATOM Ź NIL;
        Action: PROC [atom: ATOM] ~ { IF action = NIL THEN action Ź atom ELSE bogus Ź TRUE };
        bogus: BOOL Ź FALSE;
        FOR tail: LIST OF REF Ź input, tail.rest UNTIL tail = NIL DO
            WITH tail.first SELECT FROM
                z: ScreenCoordsTypes.TIPScreenCoords => {
                    mx Ź z.mouseX;
                    my Ź z.mouseY;
                    };
                atom: ATOM => {
                    SELECT atom FROM
                        $Ctrl => { ctrlshift Ź ctrlshift + 2 };
                        $Shift => { ctrlshift Ź ctrlshift + 1 };
                        $Red => { Button[$left] };
                        $Yellow => { Button[$middle] };
                        $Blue => { Button[$right] };
                        $Track => {
                            Action[$mouseto];
                            includeCtrlShift Ź TRUE;
                            };
                        $Down => {
                            Action[$buttondown];
                            includeCtrlShift Ź TRUE;
                            };
                        $Up => {
                            Action[$buttonup];
                            includeCtrlShift Ź TRUE;
                            };
                        ENDCASE => { Action[atom] };
                    };
                ENDCASE => { bogus Ź TRUE };
            ENDLOOP;
        IF action = NIL THEN bogus Ź TRUE;
        IF bogus THEN 
            Enqueue[queue, [action: $bogus, args: Reverse[Reverse[input]]]]
        ELSE
            Enqueue[queue, [action: action, button: button, mx: mx, my: my,
            args: IF includeCtrlShift THEN Cons[MakeFixnum[ctrlshift], NIL] ELSE NIL]];
        };

    D: PROC [op: ATOM, env: Environment Ź NIL] RETURNS [IVData] ~ {
        RETURN [NEW [IVDataRep Ź [op, env]]]
        };

    RegisterImagerViewers: PROC [env: Environment] ~ {
        DefinePrimitive[name: "color-context", nArgs: 0, optional: 0, dotted: FALSE, proc: ImagerPrim, env: env, data: D[$colorcontext], 
        doc: "get an Imager context for the color display"];
        DefinePrimitive[name: "viewer-context", nArgs: 1, optional: 0, dotted: FALSE, proc: ImagerPrim, env: env, data: D[$viewercontext], 
        doc: "make an ImagerViewer named a"];
        DefinePrimitive[name: "open-viewer", nArgs: 1, optional: 1, dotted: FALSE, proc: ImagerPrim, env: env, data: D[$openViewer, env], 
        doc: "([context]) Open the viewer associated with this context"];
        DefinePrimitive[name: "viewer-open?", nArgs: 1, optional: 1, dotted: FALSE, proc: ImagerPrim, env: env, data: D[$viewerOpenP, env], 
        doc: "([context]) Is the viewer associated with this context open?"];
        DefinePrimitive[name: "reset-viewer", nArgs: 1, optional: 1, dotted: FALSE, proc: ImagerPrim, env: env, data: D[$resetViewer, env], 
        doc: "([context]) Reset this context to its inital state"];
        DefinePrimitive[name: "erase-viewer", nArgs: 1, optional: 1, dotted: FALSE, proc: ImagerPrim, env: env, data: D[$eraseViewer, env], 
        doc: "([context]) Clear the viewer associated with this context"];
        DefinePrimitive[name: "viewer-read", nArgs: 1, optional: 1, dotted: FALSE, proc: ImagerPrim, env: env, data: D[$viewerread, env], 
        doc: "([context]) get mouse input associated with an ImagerViewer"];
        DefinePrimitive[name: "viewer-input-ready?", nArgs: 1, optional: 1, dotted: FALSE, proc: ImagerPrim, env: env, data: 
        D[$viewerinputready, env], doc: "([context]) test to see if ImagerViewer mouse input is available"];
        DefinePrimitive[name: "bw-display-context", nArgs: 0, optional: 0, dotted: FALSE, proc: ImagerPrim, env: env, data: 
        D[$bwdisplaycontext, env], doc: "make an Imager context for the entire bw display (bypassing the window system)"];
        <<DefinePrimitive[name: "display-screen->pixelmap", nArgs: 1, optional: 1, dotted: FALSE, proc: ImagerPrim, doc: "Make a pixelmap 
        from the display screen of the machine", env: env, data: D[$displayscreentopixelmap, env]];>>
        };

<<SchemeTendrils Initialization>>
    RegisterInit[RegisterImagerViewers];
    RegisterInit[RegisterStructuredStreams];
    RegisterInit[RegisterTiogaAccess];

    END.