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.