DIRECTORY AbSets, Atom, BiRelBasics, BiRels, Rope, SetBasics;

BiRelsBase: CEDAR MONITOR
IMPORTS AbSets, Atom, BiRelBasics, BiRels, Rope, SetBasics
EXPORTS BiRelBasics, BiRels
=

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

noPair: PUBLIC Pair ~ ALL[noValue];
noMaybePair: PUBLIC MaybePair ~ [FALSE, noPair];

AcceptAny: PUBLIC PROC [Pair] RETURNS [BOOL] ~ {RETURN [TRUE]};

refNilSets: PUBLIC RefSetPair ~ NEW [SetPair _ ALL[nilSet]];

refSpacePairs: PUBLIC Space ~ NEW [SpacePrivate _ [
Contains: SpacePairsContains,
Hash: SpacePairsHash,
Equal: SpacePairsEqual,
Compare: SpacePairsCompare,
name: "SpacePairs"]];

SpacePairsContains: PROC [data: REF ANY, v: Value] RETURNS [BOOL] ~ {
RETURN [WITH v.ra SELECT FROM
x: RefSetPair => TRUE,
ENDCASE => FALSE]};

SpacePairsHash: PROC [data: REF ANY, v: Value] RETURNS [CARDINAL] ~ {
rsp: REF SpacePair ~ NARROW[v.VA];
RETURN [(spaceSpace.SHash[AV[rsp[left]]]+1) * (spaceSpace.SHash[AV[rsp[right]]]+109)]};

SpacePairsEqual: PROC [data: REF ANY, v1, v2: Value] RETURNS [BOOL] ~ {
rsp1: REF SpacePair ~ NARROW[v1.VA];
rsp2: REF SpacePair ~ NARROW[v2.VA];
RETURN [rsp1^ = rsp2^]};

SpacePairsCompare: PROC [data: REF ANY, v1, v2: Value] RETURNS [Comparison] ~ {
rsp1: REF SpacePair ~ NARROW[v1.VA];
rsp2: REF SpacePair ~ NARROW[v2.VA];
cl: Comparison ~ spaceSpace.SCompare[AV[rsp1[left]], AV[rsp2[left]]];
IF cl#equal THEN RETURN [cl];
RETURN spaceSpace.SCompare[AV[rsp1[right]], AV[rsp2[right]]]};

CanonizeRelOrder: PUBLIC PROC [ro: RelOrder, functional: BoolPair] RETURNS [RelOrder] ~ {
IF functional[From[ro.first]] THEN ro.sub[OtherSide[ro.first]] _ no;
IF ro.sub[ro.first]=no THEN ro.sub _ ALL[no];
RETURN [ro]};

ReverseRO: PUBLIC PROC [ro: RelOrder] RETURNS [RelOrder] ~ {
ro.sub[left] _ ro.sub[left].ReverseRO[];
ro.sub[right] _ ro.sub[right].ReverseRO[];
RETURN [ro]};

RODivide: PUBLIC PROC [num, den: --Canonical--RelOrder] RETURNS [Sets.RelOrder] ~ {
IF num.sub[num.first]=no THEN RETURN [fwd];
IF num.first#den.first OR den.sub[num.first]=no THEN RETURN [no];
{second: Side ~ OtherSide[num.first];
IF num.sub[num.first]=den.sub[num.first]
THEN RETURN [IF num.sub[second]=no OR num.sub[second]=den.sub[second] THEN fwd ELSE no]
ELSE RETURN [IF num.sub[second]=no OR num.sub[second].ReverseRO[]=den.sub[second] THEN bwd ELSE no];
}};

ToSide: PUBLIC PROC [arg: REF ANY, default: Side _ left] RETURNS [Side] ~ {
RETURN [SELECT arg FROM
NIL => default,
$left => left,
$right => right,
ENDCASE => ERROR]};

ToDir: PUBLIC PROC [arg: REF ANY, default: Direction _ leftToRight] RETURNS [Direction] ~ {
RETURN [SELECT arg FROM
NIL => default,
$leftToRight => leftToRight,
$rightToLeft => rightToLeft,
ENDCASE => ERROR]};

ToBiRel: PUBLIC PROC [arg: REF ANY] RETURNS [RefBiRel] ~ {
RETURN [WITH arg SELECT FROM
x: RefBiRel => x,
ENDCASE => ERROR]};

CacheStats: TYPE ~ RECORD [probes, misses: CARD _ 0];

lastSets: ARRAY BOOL OF SetPair _ ALL[ALL[nilSet]];
lastRefSets: ARRAY BOOL OF RefSetPair _ ALL[NIL];
mruB: BOOL _ FALSE;
stats: CacheStats _ [];

FromSets: PUBLIC ENTRY PROC [sp: SetPair] RETURNS [RefSetPair] ~ {
ENABLE UNWIND => NULL;
IF sp = ALL[nilSet] THEN RETURN [refNilSets];
IF sp[left]#nilSet AND sp[left].class.IsSingletonClass[] THEN sp[left].data _ noValue;
IF sp[right]#nilSet AND sp[right].class.IsSingletonClass[] THEN sp[right].data _ noValue;
stats.probes _ stats.probes + 1;
IF sp = lastSets[mruB] THEN RETURN [lastRefSets[mruB]];
mruB _ NOT mruB;
IF sp = lastSets[mruB] THEN RETURN [lastRefSets[mruB]];
stats.misses _ stats.misses + 1;
RETURN [lastRefSets[mruB] _ NEW[SetPair _ lastSets[mruB] _ sp]]};

ToSets: PUBLIC PROC [arg: REF ANY, default: RefSetPair _ refNilSets] RETURNS [RefSetPair] ~ {
IF arg=NIL THEN RETURN [default];
RETURN [NARROW[arg]]};

roCode: ARRAY Side OF ARRAY Sets.RelOrder OF ARRAY Sets.RelOrder OF ATOM ~ [
left: [
no: [$leftNoNo, $leftNoFwd, $leftNoBwd],
fwd: [$leftFwdNo, $leftFwdFwd, $leftFwdBwd],
bwd: [$leftBwdNo, $leftBwdFwd, $leftBwdBwd]],
right: [
no: [$rightNoNo, $rightNoFwd, $rightNoBwd],
fwd: [$rightFwdNo, $rightFwdFwd, $rightFwdBwd],
bwd: [$rightBwdNo, $rightBwdFwd, $rightBwdBwd]]
];

FromRO: PUBLIC PROC [ro: RelOrder] RETURNS [ATOM] ~ {
RETURN [roCode[ro.first][ro.sub[left]][ro.sub[right]]]};

ToRO: PUBLIC PROC [arg: REF ANY, default: RelOrder _ []] RETURNS [RelOrder] ~ {
IF arg=NIL THEN RETURN [default];
{a: ATOM ~ NARROW[arg];
val: REF RelOrder ~ NARROW[Atom.GetProp[atom: a, prop: roValKey]];
RETURN [val^]}};

roValKey: ATOM ~ $BiRelsImplROVal;
sideName: ARRAY Side OF ROPE ~ [left: "left", right: "right"];
sroName: ARRAY Sets.RelOrder OF ROPE ~ [no: "No", fwd: "Fwd", bwd: "Bwd"];

WidenPairSpace: PUBLIC PROC [ps: PairSpace] RETURNS [s: Space] ~ {
RETURN [NEW [SpacePrivate _ [
Contains: PairSpaceContains,
Equal: PairSpaceEqual,
Hash: PairSpaceHash,
Compare: PairSpaceCompare,
name: Rope.Cat["pairs[", ps.sp[left].name, ", ", ps.sp[right].name, "]"],
data: NEW [PairSpace _ ps]
]]];
};

QuaPairSpace: PUBLIC PROC [s: Space] RETURNS [MaybePairSpace] ~ {
WITH s.data SELECT FROM
x: REF PairSpace => IF
s.Contains = PairSpaceContains AND
s.Equal = PairSpaceEqual AND
s.Hash = PairSpaceHash AND
s.Compare = PairSpaceCompare
THEN RETURN [[TRUE, x^]];
ENDCASE => NULL;
RETURN [[FALSE, [[NIL, NIL], []]]]};

PairSpaceContains: PROC [data: REF ANY, v: Value] RETURNS [BOOL] ~ {
rps: REF PairSpace ~ NARROW[data];
WITH v.ra SELECT FROM
x: REF Pair => RETURN [rps.sp[left].SContains[x[left]] AND rps.sp[right].SContains[x[right]]];
ENDCASE => NULL;
RETURN [FALSE]};

PairSpaceHash: PROC [data: REF ANY, v: Value] RETURNS [CARDINAL] ~ {
rps: REF PairSpace ~ NARROW[data];
WITH v.ra SELECT FROM
x: REF Pair => RETURN HashIntI[INT[rps.sp[left].SHash[x[left]]]*259 + rps.sp[right].SHash[x[right]]];
ENDCASE => NULL;
ERROR};

PairSpaceEqual: PROC [data: REF ANY, v1, v2: Value] RETURNS [BOOL] ~ {
rps: REF PairSpace ~ NARROW[data];
WITH v1.ra SELECT FROM
x: REF Pair => WITH v2.ra SELECT FROM
y: REF Pair => RETURN PEqual[rps.sp, x^, y^];
ENDCASE => NULL;
ENDCASE => NULL;
ERROR};

PairSpaceCompare: PROC [data: REF ANY, v1, v2: Value] RETURNS [Comparison] ~ {
rps: REF PairSpace ~ NARROW[data];
WITH v1.ra SELECT FROM
x: REF Pair => WITH v2.ra SELECT FROM
y: REF Pair => RETURN rps.tro.RelCompare[rps.sp, x^, y^];
ENDCASE => NULL;
ENDCASE => NULL;
ERROR};

Equal: PUBLIC PROC [a, b: BiRel, bounds: SetPair _ []] RETURNS [BOOL] ~ {
spaces: SpacePair ~ a.Spaces[];
easy: BOOL ~ bounds=[];
Try: PROC [x, y: BiRel] RETURNS [BOOL] ~ {
LookInX: PROC [p: Pair] RETURNS [BOOL] ~ {RETURN [NOT x.HasPair[p]]};
RETURN [NOT y.ScanRestriction[bounds, LookInX].found]};
IF b.Spaces[]#spaces THEN ERROR;
IF easy AND a.Size[]#b.Size[] THEN RETURN [FALSE];
RETURN [Try[a, b] AND (easy OR Try[b, a])]};

Hash: PUBLIC PROC [br: BiRel, bounds: SetPair _ []] RETURNS [hash: CARDINAL _ 0] ~ {
spaces: SpacePair ~ br.Spaces[];
Per: PROC [pair: Pair] RETURNS [BOOL] ~ {
hash _ hash + (spaces[left].SHash[pair[left]]+1) * (spaces[right].SHash[pair[right]]+1);
RETURN [FALSE]};
IF br.ScanRestriction[bounds, Per].found THEN ERROR;
RETURN};

Compare: PUBLIC PROC [a, b: BiRel, bounds: SetPair _ [], tro: TotalRelOrder _ [ALL[fwd]]] RETURNS [c: Comparison _ equal] ~ {
spaces: SpacePair ~ a.Spaces[];
Test: PROC [a, b: MaybePair] RETURNS [BOOL] ~ {
IF a.found < b.found THEN {c _ less; RETURN [TRUE]};
IF a.found > b.found THEN {c _ greater; RETURN [TRUE]};
c _ Totalify[tro.RelPCompare[spaces, a.it, b.it]];
RETURN [c#equal]};
IF b.Spaces[]#spaces THEN ERROR;
[] _ ParallelScanRestriction[a, b, Test, bounds, bounds, tro, tro];
RETURN};

CreateBiRelSpace: PUBLIC PROC [eltSpaces: SpacePair] RETURNS [Space] ~ {
RETURN [NEW [SpacePrivate _ [
Contains: BiRelsContains,
Equal: BiRelsEqual,
Hash: BiRelsHash,
Compare: BiRelsCompare,
name: Rope.Cat["birels between ", eltSpaces[left].name, " and ", eltSpaces[right].name],
data: NEW [SpacePair _ eltSpaces]
]]]};

QuaBiRelSpace: PUBLIC PROC [bs: Space] RETURNS [found: BOOL, eltSpaces: SpacePair] ~ {
IF bs.Compare = BiRelsCompare THEN RETURN [TRUE, NARROW[bs.data, REF SpacePair]^];
RETURN [FALSE, ALL[NIL]]};

BiRelsContains: PROC [data: REF ANY, v: Value] RETURNS [BOOL] ~ {
rsp: REF SpacePair ~ NARROW[data];
RETURN [WITH v.ra SELECT FROM
y: RefBiRel => y^.Spaces[]=rsp^,
ENDCASE => FALSE
]};

BiRelsEqual: PROC [data: REF ANY, v1, v2: Value] RETURNS [BOOL] ~ {
rsp: REF SpacePair ~ NARROW[data];
rbr1: RefBiRel ~ NARROW[v1.VA];
rbr2: RefBiRel ~ NARROW[v2.VA];
IF rsp^ # rbr1^.Spaces[] THEN ERROR;
IF rsp^ # rbr2^.Spaces[] THEN ERROR;
RETURN rbr1^.Equal[rbr2^]};

BiRelsHash: PROC [data: REF ANY, v: Value] RETURNS [CARDINAL] ~ {
rsp: REF SpacePair ~ NARROW[data];
rbr: RefBiRel ~ NARROW[v.VA];
IF rsp^ # rbr^.Spaces[] THEN ERROR;
RETURN rbr^.Hash[]};

BiRelsCompare: PROC [data: REF ANY, v1, v2: Value] RETURNS [Comparison] ~ {
rsp: REF SpacePair ~ NARROW[data];
rbr1: RefBiRel ~ NARROW[v1.VA];
rbr2: RefBiRel ~ NARROW[v2.VA];
IF rsp^ # rbr1^.Spaces[] THEN ERROR;
IF rsp^ # rbr2^.Spaces[] THEN ERROR;
RETURN rbr1^.Compare[rbr2^]};

GetIntDom: PUBLIC PROC [br: BiRel, want: EndBools _ []] RETURNS [IntInterval] ~ {
mpi: MaybePairInterval ~ br.GetBounds[want];
RETURN IIntify[PISide[mpi.it, left]]};

Start: PROC ~ {
FOR first: Side IN Side DO FOR lo: Sets.RelOrder IN Sets.RelOrder DO FOR ro: Sets.RelOrder IN Sets.RelOrder DO
a: ATOM ~ Atom.MakeAtom[sideName[first].Cat[sroName[lo], sroName[ro]]];
Atom.PutProp[atom: a, prop: roValKey, val: NEW [RelOrder _ [[lo, ro], first]]];
ENDLOOP ENDLOOP ENDLOOP;
};

Start[];

END.
XBiRelsBase.Mesa
Last tweaked by Mike Spreitzer on January 7, 1988 8:53:43 am PST
Κo–

"cedar" style˜
codeš
œ™Kš
œ@™@—K˜KšΟk	œ4˜=K˜šΟn
œœ
˜Kšœ3˜:Kšœ˜K˜
—K˜Kšœ
œžœ#˜=K˜Kšœœœ
˜#Kšœ
œœ
˜0K˜Kšž	œœ
œœœœœ˜?K˜Kšœœœœ
˜<K˜šœœ	œ˜3Kšžœ˜Kšžœ˜Kšžœ˜Kšžœ˜Kš
œ˜—K˜šžœœœ
œœœ˜Ešœœœ
˜Kšœœ
˜Kšœœ˜——K˜šžœœœ
œœœ˜EKšœœ
œœ˜"Kšœœ$œ˜W—K˜šžœœœ
œœœ˜GKšœœ
œœ˜$Kšœœ
œœ˜$Kšœ˜—K˜š
žœœœ
œœ˜OKšœœ
œœ˜$Kšœœ
œœ˜$Kšœ%œœ˜EKšœ
œ
œ˜Kšœœœ˜>—K˜šžœœ
œ&œ˜YKšœœ"˜DKšœœ
œ˜-Kšœ˜
—K˜šž	œœ
œœ˜<Kš
œ(˜(Kš
œ*˜*Kšœ˜
—K˜š
žœœ
œΟc
œ
œ˜SKšœœ
œ˜+Kšœœœ
œ˜AKš
œ%˜%Kšœ&˜(Kšœ
œœœ!œœ˜WKšœ
œœœ-œœ˜dK˜—K˜šžœœ
œœ
œœ˜Kšœœ˜Kšœ˜Kš
œ˜Kš
œ˜Kšœœ˜——K˜šžœœ
œœ
œ$œ˜[šœœ˜Kšœ˜Kš
œ˜Kš
œ˜Kšœœ˜——K˜šžœœ
œœ
œœ˜:šœœœ
˜Kš
œ˜Kšœœ˜——K˜Kšœœœœ˜5K˜Kšœ
œ
œ
œœ
œ
˜3Kšœ
œ
œ
œœ
œ˜1Kšœœœ
˜Kš
œ˜K˜š
žœœ
œ
œœ˜BKšœ
œœ
˜Kšœœ	œ
œ˜-Kšœœ#œ˜VKšœœ$œ˜YK˜ Kšœœ
œ˜7Kšœœ˜Kšœœ
œ˜7Kš
œ ˜ Kšœœ"˜A—K˜šžœœ
œœ
œ$œ˜]Kšœœ
œ
œ˜!Kšœœ˜—K˜šœœœ
œœ
œœ
œ˜L˜K˜(K˜,K˜-—˜K˜+K˜/K˜/—K˜—K˜š
žœœ
œœœ˜5Kšœ2˜8—K˜šžœœ
œœ
œœ˜OKšœœ
œ
œ˜!Kšœœœ˜K•StartOfExpansion[atom: 
ATOM, prop: 
REF ANY]šœœœ(˜BKšœ
˜—K˜Kšœ
œ˜"Kšœ
œœ
œ"˜>Kšœ	œœ
œ&˜JK˜šžœœ
œœ˜Bšœœ˜Kšžœ˜Kšžœ˜Kšžœ˜Kšžœ˜K˜IKšœœ˜K˜—K˜—K˜šžœœ
œœ˜Ašœœ
˜šœœ˜Kšœ˜"Kšœ˜Kšœ˜Kš
œ˜Kšœ
œœ˜—Kšœœ
˜—Kšœœœœ
˜$—K˜šžœœœ
œœœ˜DKšœœ
œ˜"šœœ
˜Kšœœ	œ"œ$˜^Kšœœ
˜—Kšœœ˜—K˜šž
œœœ
œœœ˜DKšœœ
œ˜"šœœ
˜Kšœœ	œ
œC˜eKšœœ
˜—Kšœ˜—K˜šžœœœ
œœœ˜FKšœœ
œ˜"šœœ
˜šœœ	œœ
˜%Kšœœ	œ˜-Kšœœ
˜—Kšœœ
˜—Kšœ˜—K˜š
žœœœ
œœ˜NKšœœ
œ˜"šœœ
˜šœœ	œœ
˜%Kšœœ	œ$˜9Kšœœ
˜—Kšœœ
˜—Kšœ˜—K˜š
žœœ
œ%œœ˜IK˜Kšœœ
˜šžœœœœ˜*Kšžœœœœœœ˜EKšœœ,˜7—Kšœœ
œ
˜ Kš
œœœ
œœ˜2Kšœœœ˜,—K˜š
žœœ
œ#œœ	˜TK˜ šžœœœœ˜)Kš
œX˜XKšœœ˜—Kšœ'œ
œ
˜4Kšœ˜—K˜š
žœœ
œ;œœ˜}K˜šžœœœœ˜/Kšœœœœ˜4Kšœœœœ˜7Kš
œ2˜2Kšœ˜—Kšœœ
œ
˜ Kš
œC˜CKšœ˜—K˜šžœœ
œœ˜Hšœœ˜Kšžœ˜Kšžœ˜Kšžœ
˜Kšžœ˜K˜XKšœœ˜!K˜——K˜š
ž
œœ
œ
œ	œ˜VKšœœ
œœœ
œ˜RKšœœœ
œ˜—K˜šžœœœ
œœœ˜AKšœœ
œ˜"šœœœ
˜Kš
œ ˜ Kšœ˜Kš
œ˜——K˜šžœœœ
œœœ˜CKšœœ
œ˜"Kšœœœ˜Kšœœœ˜Kšœœ
œ
˜$Kšœœ
œ
˜$Kšœ˜—K˜šž
œœœ
œœœ˜AKšœœ
œ˜"Kšœœœ˜Kšœœ
œ
˜#Kšœ˜—K˜š
ž
œœœ
œœ˜KKšœœ
œ˜"Kšœœœ˜Kšœœœ˜Kšœœ
œ
˜$Kšœœ
œ
˜$Kšœ˜—K˜šž	œœ
œ"œ˜QKš
œ,˜,Kšœ ˜&—K˜šžœœ˜šœ
œœ
œœœ
œœ˜nKšœœ@˜GK–/[atom: 
ATOM, prop: 
REF ANY, val: 
REF ANY]šœ+œ!˜OKšœ
œ
œ
˜—K˜—K˜K˜K˜Kšœ
˜—…—%3Ν