DIRECTORY BiRelBasics, BiRels, IntStuff, SetBasics, AbSets;

BiRelComposition: CEDAR PROGRAM
IMPORTS BiRelBasics, BiRels, SetBasics, AbSets
EXPORTS BiRels
=

BEGIN OPEN SetBasics, Sets:AbSets, Sets, BiRelBasics, BiRels;

Composition: TYPE ~ REF CompositionPrivate;
CompositionPrivate: TYPE ~ RECORD [
brs: ARRAY Side OF BiRel,
restricts: ARRAY Side OF BOOL,
spaces: SpacePair,
hasFirst: Side _ left,
easyScan: BOOL _ FALSE,
scanMappable: BoolPair _ [TRUE, FALSE]
];

Compose: PUBLIC PROC [left, right: BiRel, restricts: ARRAY Side OF BOOL _ [TRUE, TRUE]] RETURNS [BiRel] ~ {
constant: BOOL ~ left.MutabilityOf[]=constant AND right.MutabilityOf[]=constant;
fnl: BoolPair ~ [
left.Functional[][leftToRight] AND right.Functional[][leftToRight],
left.Functional[][rightToLeft] AND right.Functional[][rightToLeft]];
c: Composition ~ NEW [CompositionPrivate _ [
brs: [left, right],
restricts: restricts,
spaces: [left.Spaces[][left], right.Spaces[][right]]
]];
{q: ARRAY Side OF ImplQuality ~ [
QMin[QualityOf[c.brs[left], $ScanMapping, $leftToRight], QualityOf[c.brs[right], $HasPair]],
QMin[QualityOf[c.brs[right], $ScanMapping, $rightToLeft], QualityOf[c.brs[left], $HasPair]]];
c.hasFirst _ IF q[right] > q[left] THEN right ELSE left};
IF left.Functional[][leftToRight] OR right.Functional[][rightToLeft] THEN c.easyScan _ TRUE;
IF (NOT c.easyScan) AND fnl = [FALSE, TRUE] THEN c.scanMappable _ [FALSE, TRUE];
RETURN [[compClasses[IF constant THEN constant ELSE readonly][fnl[leftToRight]][fnl[rightToLeft]], c]]};

CompClasses: TYPE ~ ARRAY UnwriteableMutability OF ARRAY --fnl[l2r]--BOOL OF ARRAY --fnl[r2l]--BOOL OF BiRelClass;
compClasses: REF CompClasses ~ NEW [CompClasses];

CompPrimitive: PROC [br: BiRel, op: ATOM, arg1, arg2: REF ANY _ NIL] RETURNS [PrimitiveAnswer] ~ {
c: Composition ~ NARROW[br.data];
SELECT op FROM
$Index => RETURN [IF c.brs[left].IsOneToOne THEN yes ELSE no];
$SetOn, $CurSetOn => {side: Side ~ ToSide[arg1];
RETURN [IF NOT c.restricts[OtherSide[side]] THEN yes ELSE no]};
$IsDense => {side: Side ~ ToSide[arg2];
RETURN [IF NOT c.restricts[OtherSide[side]] THEN yes ELSE no]};
$SideFixed => {side: Side ~ ToSide[arg1];
RETURN [IF br.MutabilityOf[]=constant OR NOT c.restricts[OtherSide[side]] THEN yes ELSE no]};
ENDCASE => RETURN [pass];
};

CompHasPair: PROC [br: BiRel, pair: Pair] RETURNS [has: BOOL] ~ {
c: Composition ~ NARROW[br.data];
s1: Side ~ c.hasFirst;
s2: Side ~ OtherSide[s1];
PerMap: PROC [val: Value] RETURNS [pass: BOOL] ~ {
pair[s1] _ val;
pass _ c.brs[s2].HasPair[pair];
RETURN};
has _ c.brs[s1].ScanMapping[pair[s1], PerMap, From[s1]].found;
RETURN};

CompImage: PROC [br: BiRel, set: Set, dir: Direction] RETURNS [Set] ~ {
c: Composition ~ NARROW[br.data];
RETURN c.brs[Dest[dir]].Image[c.brs[Source[dir]].Image[set, dir], dir]};

CompApply: PROC [br: BiRel, v: Value, dir: Direction] RETURNS [MaybeValue] ~ {
c: Composition ~ NARROW[br.data];
mid: MaybeValue ~ c.brs[Source[dir]].Apply[v, dir];
IF NOT mid.found THEN RETURN [noMaybe];
RETURN c.brs[Dest[dir]].Apply[mid.it, dir]};

CompScanRestriction: PROC [br: BiRel, sets: SetPair, Test: Tester, ro: RelOrder] RETURNS [mp: MaybePair _ noMaybePair] ~ {
c: Composition ~ NARROW[br.data];
q: ARRAY Side OF ImplQuality;
seen: BiRel _ nilBiRel;
IF NOT c.easyScan THEN seen _ CreateHashReln[spaces: br.Spaces[], functional: br.Functional[], mappable: c.scanMappable];
FOR s1: Side IN Side DO
s2: Side ~ OtherSide[s1];
dir: Direction ~ From[s1];
iro: RelOrder ~ ConsRelOrder[s2, ro.sub[s2]];
set2: Set ~ sets[s2];
q[s1] _ QMin[
c.brs[s1].QualityOf[$ScanRestriction, FromSets[ConsSets[s1, sets[s1]]], FromRO[ConsRelOrder[s1, ro.sub[s1]]]],
QMin[
c.brs[s2].QualityOf[$ScanMapping, FromDir[dir], Sets.FromRO[ro.sub[s2]]],
IF IsNil[set2] THEN primitive ELSE set2.QualityOf[$HasMember]]];
ENDLOOP;
IF q=ALL[cant] THEN br.Cant[];
{
s1: Side ~ IF q[right]>q[left] THEN right ELSE left;
s2: Side ~ OtherSide[s1];
dir: Direction ~ From[s1];
set2: Set ~ sets[s2];
Outer: PROC [pair: Pair] RETURNS [pass: BOOL _ FALSE] ~ {
test: Pair _ ALL[pair[s1]];
mapping: Set ~ c.brs[s2].Mapping[pair[s2], dir];
Inner: PROC [val: Value] RETURNS [pass: BOOL _ FALSE] ~ {
IF NOT (IsNil[set2] OR set2.HasMember[val]) THEN RETURN;
test[s2] _ val;
IF c.easyScan OR NOT seen.HasPair[test] THEN {
IF NOT c.easyScan THEN [] _ seen.AddPair[test];
IF (pass _ Test[test]) THEN mp _ [TRUE, test];
};
RETURN};
pass _ mapping.Scan[Inner, ro.sub[s2]].found;
RETURN};
[] _ c.brs[s1].ScanRestriction[ConsSets[s1, sets[s1]], Outer, ConsRelOrder[s1, ro.sub[s1]]];
RETURN}};

CompGet3: PROC [br: BiRel, pair: Pair, ro: RelOrder, want: TripleBool] RETURNS [tmp: TripleMaybePair _ [noMaybePair, noMaybePair, noMaybePair]] ~ {
c: Composition ~ NARROW[br.data];
ro _ ro.CanonizeRelOrder[br.Functional[]];
IF ro.sub[ro.first]=no THEN {
IF NOT br.Empty[] THEN tmp.same _ [TRUE, pair];
RETURN};
{s1: Side ~ ro.first;
s2: Side ~ OtherSide[s1];
dir: Direction ~ From[s1];
ro1: RelOrder ~ ConsRelOrder[s1, ro.sub[s1]];
pNext, pPrev: MaybePair _ [TRUE, pair];
mNext, mPrev: Set _ br.Mapping[pair[s1], dir];
tmp.same _ IF ro.sub[s2]=no
THEN IF mNext.Empty[] THEN noMaybePair ELSE [TRUE, pair]
ELSE IF mNext.HasMember[pair[s2]] THEN [TRUE, pair] ELSE noMaybePair;
IF want.prev THEN DO
this: MaybeValue ~ IF ro.sub[s2]=fwd THEN mPrev.Get3[pair[s2], [TRUE, FALSE, FALSE]].prev ELSE mPrev.Get3[pair[s2], [FALSE, FALSE, TRUE]].next;
IF this.found THEN {tmp.prev _ [TRUE, Cons[s1, pair[s1], this.it]]; EXIT};
pPrev _ c.brs[s1].Get3[pPrev.it, ro1, [TRUE, FALSE, FALSE]].prev;
IF NOT pPrev.found THEN EXIT;
mPrev _ br.Mapping[pPrev.it[s1], dir];
ENDLOOP;
IF want.next THEN DO
this: MaybeValue ~ IF ro.sub[s2]=fwd THEN mNext.Get3[pair[s2], [FALSE, FALSE, TRUE]].next ELSE mNext.Get3[pair[s2], [TRUE, FALSE, FALSE]].prev;
IF this.found THEN {tmp.next _ [TRUE, Cons[s1, pair[s1], this.it]]; EXIT};
pNext _ c.brs[s1].Get3[pNext.it, ro1, [TRUE, FALSE, FALSE]].next;
IF NOT pNext.found THEN EXIT;
mNext _ br.Mapping[pNext.it[s1], dir];
ENDLOOP;
RETURN}};

CompIndex: PROC [br, goal: IntRel, bounds: IntInterval, bwd: BOOL] RETURNS [MaybeValue] ~ {
c: Composition ~ NARROW[br.data];
IF c.brs[left].IsOneToOne THEN RETURN c.brs[left].Index[goal.Compose[c.brs[right].Invert[]], bounds, bwd];
RETURN DefaultIndex[br, goal, bounds, bwd]};

CompRestrictionSize: PROC [br: BiRel, sets: SetPair, limit: EINT] RETURNS [EINT] ~ {
c: Composition ~ NARROW[br.data];
FOR dir: Direction IN Direction DO
s2: Side ~ Dest[dir];
IF IsNil[sets[s2]] AND c.brs[s2].Functional[][dir] AND NOT c.restricts[s2] THEN RETURN c.brs[Source[dir]].RestrictionSize[sets, limit];
ENDLOOP;
FOR dir: Direction IN Direction DO
s1: Side ~ Source[dir];
s2: Side ~ Dest[dir];
IF c.brs[s2].IsOneToOne AND NOT c.restricts[s2] AND (NOT IsNil[sets[s2]]) THEN RETURN c.brs[s1].RestrictionSize[ConsSets[s1, sets[s1], c.brs[s2].Invert[].Image[sets[s2], From[s2]]], limit];
ENDLOOP;
FOR dir: Direction DECREASING IN Direction DO
s1: Side ~ Source[dir];
s2: Side ~ Dest[dir];
IF br.Functional[][dir] OR dir=leftToRight THEN RETURN c.brs[s2].ImageSize[IF IsNil[sets[s1]] THEN c.brs[s1].SetOn[s2] ELSE c.brs[s1].Image[sets[s1], dir], dir, limit];
ENDLOOP;
ERROR};

CompValueOf: PROC [br: BiRel] RETURNS [ConstBiRel] ~ {
c: Composition ~ NARROW[br.data];
RETURN c.brs[left].Compose[c.brs[right], c.restricts].AsConst};

CompSetOn: PROC [br: BiRel, side: Side] RETURNS [UWSet] ~ {
c: Composition ~ NARROW[br.data];
IF NOT c.restricts[OtherSide[side]] THEN RETURN c.brs[side].SetOn[side];
RETURN DefaultSetOn[br, side]};

CompCurSetOn: PROC [br: BiRel, side: Side] RETURNS [ConstSet] ~ {
c: Composition ~ NARROW[br.data];
IF NOT c.restricts[OtherSide[side]] THEN RETURN c.brs[side].CurSetOn[side];
RETURN DefaultCurSetOn[br, side]};

CompSpaces: PROC [br: BiRel] RETURNS [SpacePair] ~ {
c: Composition ~ NARROW[br.data];
RETURN [c.spaces]};

CompIsDense: PROC [br: BiRel, when: When, side: Side] RETURNS [BOOL] ~ {
c: Composition ~ NARROW[br.data];
IF NOT c.restricts[OtherSide[side]] THEN RETURN c.brs[side].IsDense[when, side];
RETURN DefaultIsDense[br, when, side]};

CompSideFixed: PROC [br: BiRel, side: Side] RETURNS [BOOL] ~ {
c: Composition ~ NARROW[br.data];
IF br.MutabilityOf[]=constant THEN RETURN [TRUE];
IF NOT c.restricts[OtherSide[side]] THEN RETURN c.brs[side].SideFixed[side];
RETURN DefaultSideFixed[br, side]};

Start: PROC ~ {
FOR mut: UnwriteableMutability IN UnwriteableMutability DO FOR l2r: BOOL IN BOOL DO FOR r2l: BOOL IN BOOL DO
compClasses[mut][l2r][r2l] _ CreateClass[[
Primitive: CompPrimitive,
HasPair: CompHasPair,
Image: CompImage,
Apply: CompApply,
ScanRestriction: CompScanRestriction,
Get3: CompGet3,
Index: CompIndex,
RestrictionSize: CompRestrictionSize,
ValueOf: CompValueOf,
SetOn: CompSetOn,
CurSetOn: CompCurSetOn,
Spaces: CompSpaces,
IsDense: CompIsDense,
SideFixed: CompSideFixed,
functional: [l2r, r2l],
mutability: mut]];
ENDLOOP ENDLOOP ENDLOOP;
};

Start[];

END.
`BiRelComposition.Mesa
Last tweaked by Mike Spreitzer on December 15, 1987 11:10:23 am PST
Κ
ž–

"cedar" style˜
code™K™C—K˜KšΟk	œ2˜;K˜šΟnœœ
˜Kšœ'˜.Kšœ˜K˜
—K˜Kšœ
œžœ#˜=K˜Kšœ
œœ˜+šœœœ˜#Kšœœœ˜Kšœœœ
œ
˜K˜K˜Kšœ
œœ
˜Kšœœœ
˜&Kš
œ˜—K˜šžœœ
œ!œœ
œœœœ˜kKšœ
œ œ˜P˜Kšœœ!˜CKšœœ"˜D—šœœ˜,K˜Kš
œ˜K˜4K˜—šœœœ˜!Kš
œ\˜\Kš
œ]˜]—Kšœ
œœœ˜9Kšœ œ!œœ
˜\Kšœœ
œœœœœœ˜PKšœœ
œ
œ5˜h—K˜Kšœ
œœœ
œ
Οcœ
œ
œ
Ÿœ
œ˜rKšœ
œœ˜1K˜šž
œœœœ
œœœ˜bKšœœ
˜!šœ˜Kš	œ
œœœœ˜>˜0Kš
œœ
œœœ˜?—š
œ'˜'Kš
œœ
œœœ˜?—š
œ)˜)Kšœœœ
œœœ˜]—Kšœœ˜—K˜—K˜šžœœœœ˜AKšœœ
˜!K˜K˜šžœœœœ˜2K˜Kš
œ˜Kšœ˜—Kš
œ>˜>Kšœ˜—K˜šž	œœ'œ
˜GKšœœ
˜!KšœB˜H—K˜šž	œœ'œ˜NKšœœ
˜!K˜3Kšœ
œœ
œ˜'Kšœ&˜,—K˜šžœœžœœ"˜zKšœœ
˜!Kšœœœ
˜K˜Kšœ
œœc˜yšœ
œ˜K˜K˜K˜-K˜˜
Kš
œn˜nš
œ˜Kš
œI˜IKšœ
œœ˜@——Kšœ
˜—Kšœœœ˜Kš
œ
˜
Kšœœœœ˜4K˜K˜K˜š
žœœœœœ˜9Kšœ
œ˜Kš
œ0˜0š
žœœœœœ˜9Kš
œ
œœœ
œ
˜8Kš
œ˜šœœ
œœ˜.Kšœ
œœ˜/Kšœœœ˜.K˜—Kšœ˜—Kš
œ-˜-Kšœ˜—Kš
œ\˜\Kšœ˜	—K˜šžœœ9œE˜“
Kšœœ
˜!Kš
œ*˜*šœœ˜Kšœ
œœ
œ˜/Kšœ˜—K˜K˜K˜K˜-Kšœœ˜'Kš
œ.˜.šœœ˜Kš
œ
œœ
œœ˜8Kš
œ
œœœœ
˜E—šœœ
˜Kšœœœœœœœœœœ˜
Kšœœœ œ˜JKšœ'œœœ˜AKšœ
œ
œ
œ
˜K˜&Kšœ
˜—šœœ
˜Kšœœœœœœœœœœ˜
Kšœœœ œ˜JKšœ'œœœ˜AKšœ
œ
œ
œ
˜K˜&Kšœ
˜—Kšœ˜	—K˜šž	œœ.œœ˜[Kšœœ
˜!Kšœœ
œE˜jKšœ&˜,—K˜š
žœœ#œœœ˜TKšœœ
˜!šœœ˜"K˜Kšœœœ
œœ
œ1˜‡
Kšœ
˜—šœœ˜"K˜K˜Kšœœ
œœœœ
œh˜½
Kšœ
˜—šœ
œ
œ˜-K˜K˜Kšœœœ
œœœœ-˜¨
Kšœ
˜—Kšœ˜—K˜šžœœ
œ˜6Kšœœ
˜!Kšœ9˜?—K˜šž	œœœ˜;Kšœœ
˜!Kšœ
œœ
œ˜HKšœ˜—K˜šžœœœ˜AKšœœ
˜!Kšœ
œœ
œ˜KKšœ˜"—K˜šž
œœ
œ˜4Kšœœ
˜!Kšœ
˜—K˜šžœœ%œœ˜HKšœœ
˜!Kšœ
œœ
œ!˜PKšœ!˜'—K˜šž
œœœœ˜>Kšœœ
˜!Kšœœ
œœ˜1Kšœ
œœ
œ˜LKšœ˜#—K˜šžœœ˜šœœœ
œœ
œ
œ
œ
œœ
œ
œ
˜lš
œ*˜*Kšž	œ˜Kšžœ˜Kšžœ˜Kšžœ˜Kšžœ˜%Kšžœ˜Kšžœ˜Kšžœ˜%Kšžœ˜Kšžœ˜Kšžœ˜Kšžœ
˜Kšžœ˜Kšž	œ˜K˜K˜—Kšœ
œ
œ
˜—K˜—K˜K˜K˜Kšœ
˜—…—"Ό-Ί