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 ANYNIL] 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: PROC ~ {
RETURN};
Start[];
END.