
<<ViewerConstraintsImpl.mesa>>
    <<Copyright © 1986 by Xerox Corporation.  All rights reserved.>>
    <<Eric Nickell, October 17, 1986 4:07:33 pm PDT>>
    <<>>
    DIRECTORY
        ViewerConstraints, ViewerConstraintsPrivate,
        Process USING [Detach],
        RefTab USING [Create, Fetch, Ref, Store],
        ViewerEvents USING [EventProc, RegisterEventProc],
        ViewerOps USING [AddProp, EstablishViewerPosition, FetchProp, PaintViewer];


    ViewerConstraintsImpl: CEDAR MONITOR
    IMPORTS Process, RefTab, ViewerEvents, ViewerOps
    EXPORTS ViewerConstraints
    ~ BEGIN
    OPEN ViewerConstraints, ViewerConstraintsPrivate;

        ConstraintClass: PUBLIC TYPE ~ ViewerConstraintsPrivate.ConstraintClass;
        ConstraintClassRep: PUBLIC TYPE ~ ViewerConstraintsPrivate.ConstraintClassRep;
        Constraint: PUBLIC TYPE ~ ViewerConstraintsPrivate.Constraint;
        ConstraintRep: PUBLIC TYPE ~ ViewerConstraintsPrivate.ConstraintRep;

        Error: PUBLIC ERROR [type: ErrorType, reason: ROPE] ~ CODE;

        CreateConstraintClass: PUBLIC PROC [enforce: EnforceProc, nFrom, nTo: NAT, classData: REF _ NIL] RETURNS [class: ConstraintClass] ~ 
        {
            IF nTo=0 THEN ERROR Error[invalidConstraintClass, "Must have output edges being constrained."];
            class _ NEW[ConstraintClassRep _ [
                nFrom: nFrom,
                nTo: nTo,
                enforce: enforce,
                classData: classData
                ]];
            };
        constraintProp: ARRAY EdgeType OF ATOM ~ [$LeftAffectsConstraints, $RightAffectsConstraints, $TopAffectsConstraints, 
        $BottomAffectsConstraints];
        edgeControlledByProp: ARRAY EdgeType OF ATOM ~ [$LeftControlledBy, $RightControlledBy, $TopControlledBy, $BottomControlledBy];
        EstablishConstraint: PUBLIC PROC [class: ConstraintClass, fetch: InitProc, instanceData: REF _ NIL] RETURNS [constraint: 
        Constraint] ~ {
            ancestor: Viewer;
            c: Constraint ~ NEW[ConstraintRep _ [
                class: class,
                from: NEW[ValuesRep[class.nFrom]],
                to: NEW[ValuesRep[class.nTo]],
                eFrom: NEW[EdgeSequenceRep[class.nFrom]],
                eTo: NEW[EdgeSequenceRep[class.nTo]],
                instanceData: instanceData
                ]];
            FOR i: NAT IN [0..class.nTo) DO
                c.eTo[i] _ fetch[i: i, from: FALSE];
                IF i=0 THEN ancestor _ Ancestor[c.eTo[0].v];
                IF Ancestor[c.eTo[i].v]#ancestor THEN ERROR Error[invalidConstraint, "All edges must belong to viewers with a common ancestor."];
                ViewerOps.AddProp[viewer: c.eTo[i].v, prop: edgeControlledByProp[c.eTo[i].et], val: c];
                ENDLOOP;
            FOR i: NAT IN [0..class.nFrom) DO
                constraintList: LIST OF Constraint;
                c.eFrom[i] _ fetch[i: i, from: TRUE];
                IF Ancestor[c.eFrom[i].v]#ancestor THEN ERROR Error[invalidConstraint, "All edges must belong to viewers with a common ancestor."];
                constraintList _ CONS[c, NARROW[ViewerOps.FetchProp[viewer: c.eFrom[i].v, prop: constraintProp[c.eFrom[i].et]]]];
                ViewerOps.AddProp[viewer: c.eFrom[i].v, prop: constraintProp[c.eFrom[i].et], val: constraintList];
                ENDLOOP;
            {
                cl: LIST OF Constraint _ NARROW[ViewerOps.FetchProp[viewer: ancestor, prop: $ConstraintSystem]];
                OrderConstraints[cl _ CONS[c, cl]];
                ViewerOps.AddProp[viewer: ancestor, prop: $ConstraintSystem, val: cl];
                };
            RETURN [c];
            };
        BreakConstraint: PUBLIC PROC [constraint: Constraint] ~ {
            ancestor: Viewer ~ Ancestor[constraint.eTo[0].v];
            cl: LIST OF Constraint ~ NARROW[ViewerOps.FetchProp[viewer: ancestor, prop: $ConstraintSystem]];
            SELECT TRUE FROM
                cl=NIL => ERROR;
                cl.first=constraint => ViewerOps.AddProp[viewer: ancestor, prop: $ConstraintSystem, val: cl.rest];
                ENDCASE => FOR each: LIST OF Constraint _ cl, each.rest UNTIL each.rest=NIL DO
                    IF each.rest.first=constraint THEN each.rest _ each.rest.rest;
                    ENDLOOP;
            FOR k: NAT IN [0..constraint.eTo.n) DO
                ViewerOps.AddProp[viewer: constraint.eTo[k].v, prop: edgeControlledByProp[constraint.eTo[k].et], val: NIL];    --It's safe to 
                simply remove the property from the propList, since it could only have been controlled by one constraint anyhow.
                ENDLOOP;
            FOR k: NAT IN [0..constraint.eFrom.n) DO
                cl: LIST OF Constraint _ NARROW[ViewerOps.FetchProp[viewer: constraint.eTo[k].v, prop: constraintProp[constraint.eTo[k].et]]];
                SELECT TRUE FROM
                    cl=NIL => {};
                    cl.first=constraint => ViewerOps.AddProp[viewer: constraint.eTo[k].v, prop: constraintProp[constraint.eTo[k].et], val: cl.rest];
                    ENDCASE => {    --Don't need to reset the property ... just eliminate the offending party from the list
                        FOR each: LIST OF Constraint _ cl, each.rest UNTIL each.rest=NIL DO
                            IF each.rest.first=constraint THEN each.rest _ each.rest.rest;
                            ENDLOOP;
                        };
                ENDLOOP;
            };
        BreakConstraintsToEdge: PUBLIC PROC [e: Edge] ~ {
            c: Constraint ~ NARROW[ViewerOps.FetchProp[viewer: e.v, prop: edgeControlledByProp[e.et]]];
            cl: LIST OF Constraint ~ NARROW[ViewerOps.FetchProp[viewer: e.v, prop: constraintProp[e.et]]];
            IF c#NIL THEN BreakConstraint[c];
            FOR each: LIST OF Constraint _ cl, each.rest UNTIL each=NIL DO
                BreakConstraint[each.first];
                ENDLOOP;
            };
        Suspect: PUBLIC PROC [e: Edge] ~ {
            constraintList: LIST OF Constraint _ NARROW[ViewerOps.FetchProp[viewer: e.v, prop: constraintProp[e.et]]];
            FOR each: LIST OF Constraint _ constraintList, each.rest UNTIL each=NIL DO
                each.first.check _ TRUE;
                ENDLOOP;
            {    --Note that we need to paint the edge's viewer's parent
                ancestor: Viewer ~ Ancestor[e.v];
                parent: Viewer ~ IF e.v.parent=NIL THEN e.v ELSE e.v.parent;
                toPaint: RefTab.Ref _ NARROW[ViewerOps.FetchProp[viewer: ancestor, prop: $ConstraintToPaint]];
                IF toPaint=NIL THEN ViewerOps.AddProp[viewer: ancestor, prop: $ConstraintToPaint, val: toPaint _ RefTab.Create[]];
                [] _ RefTab.Store[x: toPaint, key: parent, val: NIL];
                };
            };
        WhatNeedsPainting: PUBLIC PROC [v: Viewer, clear: BOOL _ TRUE] RETURNS [l: LIST OF Viewer _ NIL] ~ {
            Check: PROC [viewer: Viewer] ~ {
                IF RefTab.Fetch[toPaint, viewer].found THEN l _ CONS[viewer, l]
                ELSE FOR each: Viewer _ viewer.child, each.sibling UNTIL each=NIL DO
                    Check[each];
                    ENDLOOP;
                };
            ancestor: Viewer ~ Ancestor[v];
            toPaint: RefTab.Ref ~ NARROW[ViewerOps.FetchProp[viewer: ancestor, prop: $ConstraintToPaint]];
            IF toPaint=NIL THEN RETURN[NIL];
            Check[ancestor];
            };
        PaintConstraintSystem: PUBLIC ENTRY PROC [v: Viewer, fork: BOOL _ TRUE] ~ {
            ENABLE UNWIND => {};
            IF fork THEN TRUSTED {
                Process.Detach[FORK PaintConstraintSystem[v, FALSE]];
                }
            ELSE {
                EnforceConstraintSystem[v];
                FOR each: LIST OF Viewer _ WhatNeedsPainting[v], each.rest UNTIL each=NIL DO
                    ViewerOps.PaintViewer[viewer: each.first, hint: all];
                    ENDLOOP;
                };
            };
        EnforceConstraintSystem: PUBLIC PROC [v: Viewer] ~ {
            cl: LIST OF Constraint ~ NARROW[ViewerOps.FetchProp[viewer: Ancestor[v], prop: $ConstraintSystem]];
            EnforceConstraints[cl];
            };
<<Utilities>>
    EnforceConstraints: PROC [cl: LIST OF Constraint] ~ {
        FOR each: LIST OF Constraint _ cl, each.rest UNTIL each=NIL DO
            c: Constraint ~ each.first;
            IF c.check THEN {
                ToChange: TYPE ~ RECORD [v: Viewer, vals: ARRAY EdgeType OF INTEGER];
                toChange: LIST OF ToChange _ NIL;
                oldToValues: Values ~ c.to;
                c.to _ NEW[ValuesRep[oldToValues.n]];
                FOR k: NAT IN [0..c.from.n) DO        --Set up the `from' values
                    v: Viewer ~ c.eFrom[k].v;
                    c.from[k] _ SELECT c.eFrom[k].et FROM
                        left => v.wx,
                        right => v.wx+v.ww,
                        top => v.wy,
                        bottom => v.wy+v.wh,
                        ENDCASE => ERROR;
                    ENDLOOP;
                FOR k: NAT IN [0..c.to.n) DO        --Set up the `to' values
                    v: Viewer ~ c.eTo[k].v;
                    c.to[k] _ SELECT c.eTo[k].et FROM
                        left => v.wx,
                        right => v.wx+v.ww,
                        top => v.wy,
                        bottom => v.wy+v.wh,
                        ENDCASE => ERROR;
                    ENDLOOP;
                c.class.enforce[c.from, c.to, c.class.classData, c.instanceData];    --Call the EnforceProc
                FOR k: NAT IN [0..c.to.n) DO        --Decode the `to' values
                    IF c.to[k]#oldToValues[k] THEN {
                        Set: PROC [e: Edge, val: INTEGER] ~ {
                            Find: PROC RETURNS [first: LIST OF ToChange] ~ {
                                FOR each: LIST OF ToChange _ toChange, each.rest UNTIL each=NIL DO
                                    IF each.first.v=e.v THEN RETURN [each];
                                    ENDLOOP;
                                RETURN [toChange _ CONS[[e.v, [left: e.v.wx, right: e.v.wx+e.v.ww, top: e.v.wy, bottom: e.v.wy+e.v.wh]], toChange]];
                                };
                            first: LIST OF ToChange ~ Find[];
                            first.first.vals[e.et] _ val;
                            };
                        e: Edge ~ c.eTo[k];
                        Suspect[e];
                        Set[e, c.to[k]]
                        };
                    ENDLOOP;
                FOR each: LIST OF ToChange _ toChange, each.rest UNTIL each=NIL DO
                    tc: ToChange ~ each.first;
                    ViewerOps.EstablishViewerPosition[viewer: tc.v, x: tc.vals[left], y: tc.vals[top], w: tc.vals[right]-tc.vals[left], h: 
                    tc.vals[bottom]-tc.vals[top] ];
                    ENDLOOP;
                c.check _ FALSE;
                };
            ENDLOOP;
        };
    EdgesControlled: TYPE ~ ARRAY EdgeType OF BOOL;
    OrderConstraints: PROC [c: LIST OF Constraint] ~ {
        dirty: RefTab.Ref ~ RefTab.Create[mod: 53];
        FOR each: LIST OF Constraint _ c, each.rest UNTIL each=NIL DO
            FOR k: NAT IN [0..each.first.eTo.n) DO
                flags: REF EdgesControlled _ NARROW[RefTab.Fetch[x: dirty, key: each.first.eTo[k].v].val];
                IF flags=NIL THEN {
                    flags _ NEW[EdgesControlled _ ALL[FALSE]];
                    [] _ RefTab.Store[x: dirty, key: each.first.eTo[k].v, val: flags];
                    };
                IF flags[each.first.eTo[k].et] THEN Error[constraintConflict, "More than one constraint controlling an edge."];
                flags[each.first.eTo[k].et] _ TRUE;
                ENDLOOP;
            ENDLOOP;

        {
            unsorted: LIST OF Constraint _ c;
            progressed: BOOL _ TRUE;
            UNTIL unsorted=NIL OR ~progressed DO
                progressed _ FALSE;
                FOR each: LIST OF Constraint _ unsorted, each.rest UNTIL each=NIL DO {
                    <<Check to see if this constraint has no dirty inputs>>
                    constraint: Constraint ~ each.first;
                    FOR k: NAT IN [0..constraint.eFrom.n) DO
                        flags: REF ARRAY EdgeType OF BOOL _ NARROW[RefTab.Fetch[x: dirty, key: constraint.eFrom[k].v].val];
                        IF flags=NIL THEN {
                            flags _ NEW[EdgesControlled _ ALL[FALSE]];
                            [] _ RefTab.Store[x: dirty, key: each.first.eTo[k].v, val: flags];
                            };
                        IF flags[constraint.eFrom[k].et] THEN GOTO ThisOneStillDirty;
                        ENDLOOP;
                    <<Here, we know that this constraint can be put in the sorted pile.>>
                    {
                        progressed _ TRUE;
                        FOR k: NAT IN [0..constraint.eTo.n) DO
                            flags: REF ARRAY EdgeType OF BOOL _ NARROW[RefTab.Fetch[x: dirty, key: constraint.eTo[k].v].val];
                            flags[constraint.eTo[k].et] _ FALSE;
                            ENDLOOP;
                        each.first _ unsorted.first;
                        unsorted.first _ constraint;
                        unsorted _ unsorted.rest;
                        };
                    EXITS ThisOneStillDirty => {};
                    } ENDLOOP;
                ENDLOOP;
            IF unsorted#NIL THEN Error[constraintConflict, "Constraints are circular."];
            };
        };
    Ancestor: PROC [v: Viewer] RETURNS [a: Viewer] ~ {
        a _ v;
        UNTIL a.parent=NIL DO a _ a.parent ENDLOOP;
        };
<<Watch for deleted Viewers>>
ViewerDeleted: ViewerEvents.EventProc = {
<<[viewer: ViewerClasses.Viewer, event: ViewerEvents.ViewerEvent, before: BOOL] RETURNS [abort: BOOL _ FALSE]>>
    FOR et: EdgeType IN EdgeType DO
        BreakConstraintsToEdge[[viewer, et]];
        ENDLOOP;
};
[] _ ViewerEvents.RegisterEventProc[proc: ViewerDeleted, event: destroy, before: FALSE];

    END.