BiRelShifting.Mesa
Last tweaked by Mike Spreitzer on December 14, 1987 1:14:10 pm PST
DIRECTORY Atom, BiRels, IntStuff, SetBasics, AbSets;
BiRelShifting:
CEDAR
PROGRAM
IMPORTS BiRels, IntStuff, SetBasics, AbSets
EXPORTS BiRels
=
BEGIN OPEN IntStuff, SetBasics, Sets:AbSets, Sets, BiRels;
ShiftClip: TYPE ~ REF ShiftClipPrivate;
ShiftClipPrivate:
TYPE ~
RECORD [
es: ARRAY Direction OF EINT,
cs: ARRAY Side OF IntInterval
];
Restrict:
PROC [sc: ShiftClip, sets: SetPair]
RETURNS [left: IntInterval] ~ {
RETURN [Intersect[
IF sets[left]#nilSet THEN sets[left].AsIntInterval ELSE [],
IF sets[right]#nilSet
THEN sets[right].AsIntInterval.Intersect[sc.cs[right]] .ShiftInterval[sc.es[rightToLeft]]
ELSE sc.cs[left]]]};
ShiftAndClip:
PUBLIC
PROC [br: IntRel, shift:
EINT ← zero, clip: IntInterval ← []]
RETURNS [IntRel] ~ {
IF shift = zero AND clip = [] THEN RETURN [br];
{good: BOOL ~ br.GoodImpl[$GetIntDom];
dom: IntInterval ~ IF good THEN br.GetIntDom ELSE [];
li: IntInterval ~ clip.ClipShiftInterval[shift.Neg];
ri: IntInterval ~ li.ShiftInterval[shift];
scr: BiRel ~ CreateShiftAndClipper[shift.Neg, li];
mbi: IntInterval ~ ri.MBI[dom];
RETURN Compose[scr, br,
IF NOT good THEN ALL[TRUE]
ELSE IF mbi=ri THEN IF mbi=dom THEN ALL[FALSE] ELSE [FALSE, TRUE]
ELSE IF mbi=dom THEN [TRUE, FALSE] ELSE ALL[TRUE]]}};
CreateShiftAndClipper:
PUBLIC
PROC [shift:
EINT ← zero, clip: IntInterval ← []]
RETURNS [ConstOneToOne] ~ {
e: EINT ~ shift;
ne: EINT ~ e.Neg;
cr: IntInterval ~ clip.ClipShiftInterval[e];
IF cr.Empty[] THEN RETURN [CreateEmptyBiRel[ALL[ints]]];
IF cr.min=cr.max THEN RETURN CreateSingleton[[[i[ne.AddI[cr.min].EI]], [i[cr.min]]], ALL[ints]];
{sc: ShiftClip ~
NEW [ShiftClipPrivate ← [
es: [e, ne],
cs: [left: cr.ShiftInterval[ne], right: cr]
]];
RETURN AsConst[[scClass, sc]]}};
scClass: BiRelClass ~ CreateClass[
cp: [
Primitive: SCPrimitive,
HasPair: SCHasPair,
Image: SCImage,
Apply: SCApply,
ScanRestriction: SCScanRestriction,
Get3: SCGet3,
RestrictionSize: SCRestrictionSize,
GetBounds: SCGetBounds,
SetOn: SCSetOn,
Spaces: SCSpaces,
IsDense: SCIsDense,
functional: ALL[TRUE],
mutability: constant],
dirable: ALL[TRUE]];
SCPrimitive:
PROC [br: BiRel, op:
ATOM, arg1, arg2:
REF
ANY ←
NIL]
RETURNS [PrimitiveAnswer] ~ {
SELECT op
FROM
$Image => {sc: ShiftClip ~
NARROW[br.data];
rs: RefSet ~ ToSet[arg1];
RETURN [IF (rs^.GoodImpl[$QuaIntInterval] AND rs^.QuaIntInterval[].found) THEN yes ELSE no]};
ENDCASE => RETURN [pass]};
SCHasPair:
PROC [br: BiRel, pair: Pair]
RETURNS [
BOOL] ~ {
sc: ShiftClip ~ NARROW[br.data];
WITH pair[left]
SELECT
FROM
x: IntValue =>
RETURN [x.i
IN [sc.cs[left].min .. sc.cs[left].max]
AND (
WITH pair[right]
SELECT
FROM
y: IntValue => sc.es[leftToRight].AddI[x.i]=IE[y.i],
ENDCASE => FALSE)];
ENDCASE => RETURN [FALSE]};
SCImage:
PROC [br: BiRel, set: Set, dir: Direction]
RETURNS [Set] ~ {
IF set.MutabilityOf[]#constant THEN GOTO GiveUp;
IF NOT set.GoodImpl[$QuaIntInterval] THEN GOTO GiveUp;
{sc: ShiftClip ~ NARROW[br.data];
qi: MaybeIntInterval ~ set.QuaIntInterval[];
IF NOT qi.found THEN GOTO GiveUp;
RETURN [IIAsSet[qi.it.ClipShiftInterval[sc.es[dir]]]]};
EXITS GiveUp => RETURN DefaultImage[br, set, dir]};
SCApply:
PROC [br: BiRel, v: Value, dir: Direction]
RETURNS [MaybeValue] ~ {
sc: ShiftClip ~ NARROW[br.data];
WITH v
SELECT
FROM
x: IntValue =>
{
c: IntInterval ~ sc.cs[Source[dir]];
RETURN [IF x.i IN [c.min .. c.max] THEN [TRUE, [i[sc.es[dir].AddI[x.i].EI]]] ELSE noMaybe];
};
ENDCASE => RETURN [noMaybe]};
SCScanRestriction:
PROC [br: BiRel, sets: SetPair,
Test: Tester, ro: RelOrder]
RETURNS [MaybePair] ~ {
sc: ShiftClip ~ NARROW[br.data];
li: IntInterval ~ Restrict[sc, sets];
IF
NOT li.Empty
THEN
SELECT ro.sub[ro.first]
FROM
fwd, no => {
i: INT ← li.min;
j: INT ← sc.es[leftToRight].AddI[i].EI;
DO
IF Test[[[i[i]], [i[j]]]] THEN RETURN [[TRUE, [[i[i]], [i[j]]]]];
IF i=li.max THEN EXIT;
i ← i + 1;
j ← j + 1;
ENDLOOP};
bwd => {
i: INT ← li.max;
j: INT ← sc.es[leftToRight].AddI[i].EI;
DO
IF Test[[[i[i]], [i[j]]]] THEN RETURN [[TRUE, [[i[i]], [i[j]]]]];
IF i=li.min THEN EXIT;
i ← i - 1;
j ← j - 1;
ENDLOOP};
ENDCASE => ERROR;
RETURN [noMaybePair]};
MaybeInt: TYPE ~ RECORD [found: BOOL, it: INT];
SCGet3:
PROC [br: BiRel, pair: Pair, ro: RelOrder, want: TripleBool]
RETURNS [TripleMaybePair] ~ {
sc: ShiftClip ~ NARROW[br.data];
i: INT ~ pair[ro.first].VI;
c: IntInterval ~ sc.cs[ro.first];
Ex:
PROC [mi: MaybeInt]
RETURNS [MaybePair] ~ {
RETURN [
SELECT ro.first
FROM
left => IF mi.found THEN [TRUE, [[i[mi.it]], [i[sc.es[leftToRight].AddI[mi.it].EI]]]] ELSE noMaybePair,
right => IF mi.found THEN [TRUE, [[i[sc.es[rightToLeft].AddI[mi.it].EI]], [i[mi.it]]]] ELSE noMaybePair,
ENDCASE => ERROR]};
Finish:
PROC [l, e, g: MaybeInt]
RETURNS [TripleMaybePair] ~ {
SELECT ro.sub[ro.first]
FROM
fwd, no => RETURN [[Ex[l], Ex[e], Ex[g]]];
bwd => RETURN [[Ex[g], Ex[e], Ex[l]]];
ENDCASE => ERROR};
SELECT
TRUE
FROM
i < c.min => RETURN Finish[[FALSE, 0], [FALSE, 0], [TRUE, c.min]];
i = c.min => RETURN Finish[[FALSE, 0], [TRUE, i], [TRUE, i+1]];
i < c.max => RETURN Finish[[TRUE, i-1], [TRUE, i], [TRUE, i+1]];
i = c.max => RETURN Finish[[TRUE, i-1], [TRUE, i], [FALSE, 0]];
ENDCASE => RETURN Finish[[FALSE, c.max], [FALSE, 0], [TRUE, 0]]};
SCRestrictionSize:
PROC [br: BiRel, sets: SetPair, limit:
EINT]
RETURNS [
EINT] ~ {
sc: ShiftClip ~ NARROW[br.data];
li: IntInterval ~ Restrict[sc, sets];
RETURN li.Length[]};
SCGetBounds:
PROC [br: BiRel, want: EndBools, ro: RelOrder]
RETURNS [MaybePairInterval] ~ {
sc: ShiftClip ~ NARROW[br.data];
RETURN [[
TRUE,
SELECT ro.sub[ro.first]
FROM
fwd, no => [
min: [[i[sc.cs[left].min]], [i[sc.cs[right].min]] ],
max: [[i[sc.cs[left].max]], [i[sc.cs[right].max]] ]],
bwd => [
max: [[i[sc.cs[left].min]], [i[sc.cs[right].min]] ],
min: [[i[sc.cs[left].max]], [i[sc.cs[right].max]] ]],
ENDCASE => ERROR]]};
SCSetOn:
PROC [br: BiRel, side: Side]
RETURNS [UWSet] ~ {
sc: ShiftClip ~ NARROW[br.data];
RETURN [IIAsSet[sc.cs[side]]]};
SCSpaces: PROC [br: BiRel] RETURNS [SpacePair] ~ {RETURN [ALL[ints]]};
SCIsDense:
PROC [br: BiRel, when: When, side: Side]
RETURNS [
BOOL]
~ {RETURN [TRUE]};
Start[];
END.