BiRelsBase.Mesa
Last tweaked by Mike Spreitzer on February 27, 1988 2:02:22 pm PST
DIRECTORY AbSets, Atom, BiRelBasics, BiRels, IO, Rope, SetBasics, StructuredStreams;
BiRelsBase:
CEDAR
MONITOR
IMPORTS AbSets, Atom, BiRelBasics, BiRels, IO, Rope, SetBasics, StructuredStreams
EXPORTS BiRelBasics, BiRels
=
BEGIN OPEN SetBasics, Sets:AbSets, Sets, BiRelBasics, BiRels, SS:StructuredStreams;
noPair: PUBLIC Pair ~ ALL[noValue];
noMaybePair: PUBLIC MaybePair ~ [FALSE, noPair];
PrintPair:
PUBLIC
PROC [pair: Pair, spaces: SpacePair, to:
IO.
STREAM, depth:
INT ← 4, length:
INT ← 32, verbose:
BOOL ←
FALSE] ~ {
spaces[left].SPrint[v: pair[left], to: to, depth: depth-1, length: length, verbose: verbose];
to.PutRope[":"];
SS.Bp[to, lookLeft, 3, " "];
spaces[right].SPrint[v: pair[right], to: to, depth: depth-1, length: length, verbose: verbose];
RETURN};
FormatPair:
PUBLIC
PROC [pair: Pair, spaces: SpacePair, depth:
INT ← 4, length:
INT ← 32, verbose:
BOOL ←
FALSE]
RETURNS [
ROPE] ~ {
out: IO.STREAM ~ IO.ROS[];
PrintPair[pair, spaces, out, depth, length, verbose];
RETURN [out.RopeFromROS]};
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,
Print: SpacePairsPrint,
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]]]};
SpacePairsPrint:
PROC [data:
REF
ANY, v: Value, to:
IO.
STREAM, depth, length:
INT, verbose:
BOOL] ~ {
rsp: REF SpacePair ~ NARROW[v.VA];
IF depth <= 1 THEN {to.PutRope["<..>"]; RETURN};
to.PutRope["<"];
to.PutRope[rsp[left].name];
to.PutRope[", "];
to.PutRope[rsp[right].name];
to.PutRope[">"];
RETURN};
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]};
FromSetsCacheStats: TYPE ~ RECORD [probes, misses, hashs: CARD ← 0];
FromSetsCache: TYPE ~ RECORD [seq: SEQUENCE size: NATURAL OF REF FromSetsCacheEntry];
FromSetsCacheEntry:
TYPE ~
RECORD [
mruB: BOOL ← FALSE,
lastSets: ARRAY BOOL OF SetPair ← ALL[ALL[nilSet]],
lastRefSets: ARRAY BOOL OF RefSetPair ← ALL[NIL]];
fromSetsCache: REF FromSetsCache ← CreateFromSetsCache[32];
fromSetsStats: FromSetsCacheStats ← [];
CreateFromSetsCache: PROC [size: NATURAL] RETURNS [cache: REF FromSetsCache] ~ {cache ← NEW [FromSetsCache[size]]};
HashSetRep:
PROC [set: Set]
RETURNS [
CARDINAL] ~
INLINE {
RETURN [HashRefI[set.class] + HashRefI[set.data.ra] + HashIntI[set.data.i]]};
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;
{index: NATURAL ~ (HashSetRep[sp[left]] + HashSetRep[sp[right]]) MOD fromSetsCache.size;
rce: REF FromSetsCacheEntry ← fromSetsCache[index];
IF rce=
NIL
THEN {
fromSetsCache[index] ← rce ← NEW [FromSetsCacheEntry ← []];
fromSetsStats.hashs ← fromSetsStats.hashs + 1};
fromSetsStats.probes ← fromSetsStats.probes + 1;
IF sp = rce.lastSets[rce.mruB] THEN RETURN [rce.lastRefSets[rce.mruB]];
rce.mruB ← NOT rce.mruB;
IF sp = rce.lastSets[rce.mruB] THEN RETURN [rce.lastRefSets[rce.mruB]];
fromSetsStats.misses ← fromSetsStats.misses + 1;
RETURN [rce.lastRefSets[rce.mruB] ← NEW[SetPair ← rce.lastSets[rce.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,
Print: PairSpacePrint,
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};
PairSpacePrint:
PROC [data:
REF
ANY, v: Value, to:
IO.
STREAM, depth, length:
INT, verbose:
BOOL] ~ {
rps: REF PairSpace ~ NARROW[data];
rp: REF Pair ~ NARROW[v.VA];
PrintPair[rp^, rps.sp, to, depth, length, verbose];
RETURN};
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,
Print: BiRelsPrint,
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^]};
BiRelsPrint:
PROC [data:
REF
ANY, v: Value, to:
IO.
STREAM, depth, length:
INT, verbose:
BOOL] ~ {
rbr: RefBiRel ~ NARROW[v.VA];
rbr^.PrintBiRel[to, depth, length, verbose];
RETURN};
FormatBiRel:
PUBLIC
PROC [br: BiRel, depth:
INT ← 4, length:
INT ← 32, verbose:
BOOL ←
FALSE]
RETURNS [
ROPE] ~ {
out: IO.STREAM ~ IO.ROS[];
br.PrintBiRel[out, depth, length, verbose];
RETURN [out.RopeFromROS[]]};
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.