BiRelsSimpleImpl.Mesa
Last tweaked by Mike Spreitzer on December 15, 1987 10:58:27 am PST
DIRECTORY AbSets, Atom, BiRelBasics, BiRels, IntStuff, List, Rope, SetBasics;
BiRelsSimpleImpl:
CEDAR
PROGRAM
IMPORTS AbSets, BiRelBasics, BiRels, IntStuff, List, SetBasics
EXPORTS BiRels
=
BEGIN OPEN IntStuff, SetBasics, Sets:AbSets, Sets, BiRelBasics, BiRels;
singletonKey: ATOM ~ $BiRelsSimpleImplSingletonClass;
CreateEmptyBiRel:
PUBLIC
PROC [sp: SpacePair]
RETURNS [ConstBiRel] ~ {
RETURN CreateProduct[[CreateEmptySet[sp[left]], CreateEmptySet[sp[right]]]].AsConst};
GetSingletonClass:
PUBLIC
PROC [spaces: SpacePair]
RETURNS [class: BiRelClass] ~ {
Update:
PROC [old: List.AList]
RETURNS [new: List.AList] ~ {
inner: List.AList ← NARROW[List.Assoc[key: singletonKey, aList: new ← old]];
class ← NARROW[List.Assoc[key: spaces[right], aList: inner]];
IF class=
NIL
THEN {
class ← CreateClass[
cp: [
HasPair: SingletonHasPair,
Apply: SingletonApply,
ScanRestriction: SingletonScanRestriction,
GetOne: SingletonGetOne,
Get3: SingletonGet3,
RestrictionSize: SingletonRestrictionSize,
GetBounds: SingletonGetBounds,
SetOn: SingletonSetOn,
CurSetOn: SingletonCurSetOn,
Spaces: SingletonSpaces,
IsDense: SingletonIsDense,
SideFixed: SingletonSideFixed,
functional: ALL[TRUE],
mutability: constant,
data: NEW [SpacePair ← spaces]
],
dirable: ALL[TRUE]
];
inner ← List.PutAssoc[key: spaces[right], val: class, aList: inner];
new ← List.PutAssoc[key: singletonKey, val: inner, aList: new];
};
RETURN};
spaces[left].UpdateSpaceOther[Update];
RETURN};
SingletonHasPair:
PROC [br: BiRel, pair: Pair]
RETURNS [
BOOL] ~ {
rp: REF Pair ~ NARROW[br.data];
rsp: REF SpacePair ~ NARROW[br.class.data];
RETURN PEqual[rsp^, pair, rp^]};
SingletonApply:
PROC [br: BiRel, v: Value, dir: Direction]
RETURNS [MaybeValue] ~ {
rp: REF Pair ~ NARROW[br.data];
rsp: REF SpacePair ~ NARROW[br.class.data];
s1: Side ~ Source[dir];
IF rsp[s1].SEqual[rp[s1], v] THEN RETURN [[TRUE, rp[Dest[dir]]]];
RETURN [noMaybe]};
SingletonScanRestriction:
PROC [br: BiRel, sets: SetPair,
Test: Tester, ro: RelOrder]
RETURNS [MaybePair] ~ {
rp: REF Pair ~ NARROW[br.data];
IF
(sets[left]=nilSet OR sets[left].HasMember[rp[left]]) AND
(sets[right]=nilSet OR sets[right].HasMember[rp[right]]) AND
Test[rp^]
THEN RETURN [[TRUE, rp^]];
RETURN [noMaybePair]};
SingletonGetOne:
PROC [br: BiRel, remove:
BOOL, ro: RelOrder]
RETURNS [MaybePair] ~ {
rp: REF Pair ~ NARROW[br.data];
IF remove THEN br.Complain[notVariable];
RETURN [[TRUE, rp^]]};
SingletonGet3:
PROC [br: BiRel, pair: Pair, ro: RelOrder, want: TripleBool]
RETURNS [TripleMaybePair] ~ {
rp: REF Pair ~ NARROW[br.data];
rsp: REF SpacePair ~ NARROW[br.class.data];
RETURN [
SELECT ro.RelPCompare[rsp^, pair, rp^]
FROM
less => [noMaybePair, noMaybePair, [TRUE, rp^]],
equal => [noMaybePair, [TRUE, rp^], noMaybePair],
greater => [[TRUE, rp^], noMaybePair, noMaybePair],
notrel => [noMaybePair, noMaybePair, noMaybePair],
ENDCASE => ERROR]};
SingletonRestrictionSize:
PROC [br: BiRel, sets: SetPair, limit:
EINT]
RETURNS [
EINT] ~ {
rp: REF Pair ~ NARROW[br.data];
IF
(sets[left]=nilSet OR sets[left].HasMember[rp[left]]) AND
(sets[right]=nilSet OR sets[right].HasMember[rp[right]])
THEN RETURN [one]
ELSE RETURN [zero]};
SingletonGetBounds:
PROC [br: BiRel, want: EndBools, ro: RelOrder]
RETURNS [MaybePairInterval] ~ {
rp: REF Pair ~ NARROW[br.data];
RETURN [[TRUE, ALL[rp^]]]};
SingletonSetOn:
PROC [br: BiRel, side: Side]
RETURNS [UWSet] ~ {
rp: REF Pair ~ NARROW[br.data];
rsp: REF SpacePair ~ NARROW[br.class.data];
RETURN [Sets.CreateSingleton[rp[side], rsp[side]]]};
SingletonCurSetOn:
PROC [br: BiRel, side: Side]
RETURNS [ConstSet] ~ {
rp: REF Pair ~ NARROW[br.data];
rsp: REF SpacePair ~ NARROW[br.class.data];
RETURN Sets.CreateSingleton[rp[side], rsp[side]]};
SingletonSpaces:
PROC [br: BiRel]
RETURNS [SpacePair] ~ {
rsp: REF SpacePair ~ NARROW[br.class.data];
RETURN [rsp^]};
SingletonIsDense:
PROC [br: BiRel, when: When, side: Side]
RETURNS [
BOOL]
~ {RETURN [TRUE]};
SingletonSideFixed:
PROC [br: BiRel, side: Side]
RETURNS [
BOOL]
~ {RETURN [TRUE]};
Product: TYPE ~ REF ProductPrivate;
ProductPrivate:
TYPE ~
RECORD [
spaces: SpacePair,
sets: SetPair
];
CreateProduct:
PUBLIC
PROC [sets: SetPair]
RETURNS [BiRel] ~ {
mut: UnwriteableMutability ~ IF sets[left].MutabilityOf[]=constant AND sets[right].MutabilityOf[]=constant THEN constant ELSE readonly;
fnl: BoolPair ~ [
sets[right].MutabilityOf[]=constant AND sets[right].GoodImpl[$Size, refTwo] AND sets[right].Size[two].Compare[one]<=equal,
sets[left].MutabilityOf[]=constant AND sets[left].GoodImpl[$Size, refTwo] AND sets[left].Size[two].Compare[one]<=equal];
p: Product ~
NEW [ProductPrivate ← [
spaces: [sets[left].SpaceOf[], sets[right].SpaceOf[]],
sets: sets
]];
RETURN [[productClasses[mut][fnl[leftToRight]][fnl[rightToLeft]], p]]};
refTwo: REF EINT ~ NEW [EINT ← two];
ProductClasses: TYPE ~ ARRAY UnwriteableMutability OF ARRAY --fnl[l2r]--BOOL OF ARRAY --fnl[r2l]--BOOL OF BiRelClass;
productClasses: REF ProductClasses ~ NEW [ProductClasses];
ProductHasPair:
PROC [br: BiRel, pair: Pair]
RETURNS [
BOOL] ~ {
p: Product ~ NARROW[br.data];
RETURN [p.sets[left].HasMember[pair[left]] AND p.sets[right].HasMember[pair[right]]]};
ProductImage:
PROC [br: BiRel, set: Set, dir: Direction]
RETURNS [Set] ~ {
p: Product ~ NARROW[br.data];
src: Side ~ Source[dir];
dst: Side ~ Dest[dir];
RETURN [CreateConditional[set.Intersection[p.sets[src]], p.sets[dst]]]};
ProductApply:
PROC [br: BiRel, v: Value, dir: Direction]
RETURNS [MaybeValue] ~ {
p: Product ~ NARROW[br.data];
dest: Side ~ Dest[dir];
IF (NOT p.sets[Source[dir]].HasMember[v]) OR p.sets[dest].Size[two].Compare[one]>equal THEN br.Complain[mappingNotSingleton, LIST[v]];
RETURN p.sets[dest].GetOne[FALSE, no]};
ApplyRestriction:
PROC [p: Product, sets: SetPair]
RETURNS [SetPair] ~ {
RETURN [[
left: IF sets[left]#nilSet THEN p.sets[left].Intersection[sets[left]] ELSE p.sets[left],
right: IF sets[right]#nilSet THEN p.sets[right].Intersection[sets[right]] ELSE p.sets[right]
]];
};
ProductScanRestriction:
PROC [br: BiRel, sets: SetPair,
Test: Tester, ro: RelOrder]
RETURNS [mp: MaybePair ← noMaybePair] ~ {
p: Product ~ NARROW[br.data];
rsets: SetPair ~ ApplyRestriction[p, sets];
s1: Side ~ ro.first;
s2: Side ~ OtherSide[s1];
Outer:
PROC [oval: Value]
RETURNS [pass:
BOOL] ~ {
test: Pair ← ALL[oval];
Inner:
PROC [ival: Value]
RETURNS [pass:
BOOL] ~ {
test[s2] ← ival;
IF (pass ← Test[test]) THEN mp ← [TRUE, test];
RETURN};
pass ← rsets[s2].Scan[Inner, ro.sub[s2]].found;
RETURN};
[] ← rsets[s1].Scan[Outer, ro.sub[s1]];
RETURN};
ProductGet3:
PROC [br: BiRel, pair: Pair, ro: RelOrder, want: TripleBool]
RETURNS [TripleMaybePair] ~ {
p: Product ~ NARROW[br.data];
IF p.sets[left].Empty OR p.sets[right].Empty THEN RETURN [[noMaybePair, noMaybePair, noMaybePair]];
{s1: Side ~ ro.first;
s2: Side ~ OtherSide[s1];
start: TripleMaybeValue ~ IF want.prev OR want.next THEN p.sets[s2].Get3[pair[s2]] ELSE [noMaybe, noMaybe, noMaybe];
Next:
PROC [ro: RelOrder]
RETURNS [MaybePair] ~ {
first: MaybeValue ~
SELECT ro.sub[s2]
FROM
no, fwd => start.next,
bwd => start.prev,
ENDCASE => ERROR;
IF first.found THEN RETURN [[TRUE, Cons[s1, pair[s1], first.it]]];
{
nxto: MaybeValue ~ IF ro.sub[s1]=bwd THEN p.sets[s1].Prev[pair[s1]] ELSE p.sets[s1].Next[pair[s1]];
IF NOT nxto.found THEN RETURN [noMaybePair];
RETURN [[TRUE, Cons[s1, nxto.it, IF ro.sub[s2]=bwd THEN p.sets[s2].Last[].it ELSE p.sets[s2].First[].it]]]}};
RETURN [[
prev: IF want.prev THEN Next[ro.ReverseRO] ELSE noMaybePair,
same: IF want.same AND br.HasPair[pair] THEN [TRUE, pair] ELSE noMaybePair,
next: IF want.next THEN Next[ro] ELSE noMaybePair
]];
}};
ProductRestrictionSize:
PROC [br: BiRel, sets: SetPair, limit:
EINT]
RETURNS [
EINT] ~ {
p: Product ~ NARROW[br.data];
rsets: SetPair ~ ApplyRestriction[p, sets];
s1: EINT ~ rsets[left].Size[limit];
IF s1=zero THEN RETURN [s1];
{s2: EINT ~ rsets[right].Size[IF s1.Compare[limit]>=equal THEN one ELSE IF limit.IsInt AND s1.IsInt AND limit.Add[s1].CompareI[INT.LAST]<=equal THEN IE[CeilDiv[limit.EI, s1.Min[limit].EI]] ELSE limit];
prod: DEINT ~ s1.Mul[s2];
IF prod.hi # zero THEN RETURN [limit];
RETURN [prod.lo]}};
ProductGetBounds:
PROC [br: BiRel, want: EndBools, ro: RelOrder]
RETURNS [MaybePairInterval] ~ {
p: Product ~ NARROW[br.data];
IF want=ALL[FALSE] OR p.sets[left].Empty OR p.sets[right].Empty THEN RETURN [[FALSE, []]];
ro ← ro.CanonizeRelOrder[br.Functional[]];
{mil: MaybeInterval ~ IF ro.sub[left]#no THEN p.sets[left].GetBounds[want] ELSE [TRUE, ALL[p.sets[left].AnElt[].Val]];
mir: MaybeInterval ~ IF ro.sub[right]#no THEN p.sets[right].GetBounds[want] ELSE [TRUE, ALL[p.sets[right].AnElt[].Val]];
IF NOT (mil.found AND mir.found) THEN ERROR;
RETURN [[
TRUE, [
min: [mil.it[min], mir.it[min]],
max: [mil.it[max], mir.it[max]]
]]]
}};
ProductValueOf:
PROC [br: BiRel]
RETURNS [ConstBiRel] ~ {
IF br.MutabilityOf[]=constant THEN RETURN br.AsConst;
{p: Product ~ NARROW[br.data];
RETURN CreateProduct[[p.sets[left].ValueOf, p.sets[right].ValueOf]].AsConst}};
ProductSetOn:
PROC [br: BiRel, side: Side]
RETURNS [UWSet] ~ {
p: Product ~ NARROW[br.data];
RETURN [p.sets[side].Insulate]};
ProductCurSetOn:
PROC [br: BiRel, side: Side]
RETURNS [ConstSet] ~ {
p: Product ~ NARROW[br.data];
RETURN [p.sets[side].ValueOf]};
ProductSpaces:
PROC [br: BiRel]
RETURNS [SpacePair] ~ {
p: Product ~ NARROW[br.data];
RETURN [p.spaces]};
ProductIsDense:
PROC [br: BiRel, when: When, side: Side]
RETURNS [
BOOL] ~ {
p: Product ~ NARROW[br.data];
RETURN p.sets[side].IsDense[when]};
ProductSideFixed:
PROC [br: BiRel, side: Side]
RETURNS [
BOOL] ~ {
p: Product ~ NARROW[br.data];
RETURN [p.sets[side].MutabilityOf[]=constant]};
IsIDSubset:
PUBLIC
PROC [br: BiRel]
RETURNS [
BOOL] ~ {
IF br.data#NIL AND ISTYPE[br.data, IDSubset] THEN RETURN [TRUE];
{space: Space ~ br.Spaces[][left];
Bad:
PROC [pair: Pair]
RETURNS [
BOOL]
~ {RETURN [NOT space.SEqual[pair[left], pair[right]]]};
IF space#br.Spaces[][right] THEN RETURN [FALSE];
RETURN [NOT br.Scan[Bad].found]}};
CreateIDSubset:
PUBLIC
PROC [set: Set]
RETURNS [BiRel] ~ {
ids: IDSubset ~ NEW [IDSubsetPrivate ← [set, set.SpaceOf]];
RETURN [[idsClasses[MIN[set.MutabilityOf, readonly]], ids]]};
IDSubset: TYPE ~ REF IDSubsetPrivate;
IDSubsetPrivate: TYPE ~ RECORD [set: Set, space: Space];
IDSClasses: TYPE ~ ARRAY UnwriteableMutability OF BiRelClass;
idsClasses: REF IDSClasses ~ NEW [IDSClasses];
IDSHasPair:
PROC [br: BiRel, pair: Pair]
RETURNS [
BOOL] ~ {
ids: IDSubset ~ NARROW[br.data];
RETURN [ids.space.SEqual[pair[left], pair[right]] AND ids.set.HasMember[pair[left]]]};
IDSImage:
PROC [br: BiRel, set: Set, dir: Direction]
RETURNS [Set] ~ {
ids: IDSubset ~ NARROW[br.data];
RETURN [set.Intersection[ids.set]]};
IDSApply:
PROC [br: BiRel, v: Value, dir: Direction]
RETURNS [MaybeValue] ~ {
ids: IDSubset ~ NARROW[br.data];
RETURN [IF ids.set.HasMember[v] THEN [TRUE, v] ELSE noMaybe]};
PairMaybe:
PROC [mv: MaybeValue]
RETURNS [MaybePair]
~ INLINE {RETURN [[mv.found, ALL[mv.it]]]};
Restrict:
PROC [set: Set, sets: SetPair]
RETURNS [Set]
~
INLINE {
RETURN [
IF sets[left]#nilSet
THEN
IF sets[right]#nilSet
THEN set.Intersection[sets[left].Intersection[sets[right]]]
ELSE set.Intersection[sets[left]]
ELSE
IF sets[right]#nilSet
THEN set.Intersection[sets[right]]
ELSE set]};
IDSScanRestriction:
PROC [br: BiRel, sets: SetPair,
Test: Tester, ro: RelOrder]
RETURNS [MaybePair] ~ {
ids: IDSubset ~ NARROW[br.data];
Pass: PROC [v: Value] RETURNS [BOOL] ~ {RETURN Test[ALL[v]]};
subj: Set ~ Restrict[ids.set, sets];
RETURN PairMaybe[subj.Scan[Pass, ro.sub[ro.first]]]};
IDSGetOne:
PROC [br: BiRel, remove:
BOOL, ro: RelOrder]
RETURNS [MaybePair] ~ {
ids: IDSubset ~ NARROW[br.data];
RETURN PairMaybe[ids.set.GetOne[remove, ro.sub[ro.first]]]};
IDSGet3:
PROC [br: BiRel, pair: Pair, ro: RelOrder, want: TripleBool]
RETURNS [TripleMaybePair] ~ {
ids: IDSubset ~ NARROW[br.data];
tmv: TripleMaybeValue ~ ids.set.Get3[pair[ro.first], want];
tmp: TripleMaybePair ~ [
prev: PairMaybe[tmv.prev],
same: IF tmv.same.found AND ids.space.SEqual[pair[left], pair[right]] THEN PairMaybe[tmv.same] ELSE noMaybePair,
next: PairMaybe[tmv.next]];
IF ro.sub[ro.first]#bwd THEN RETURN [tmp];
RETURN [[tmp.next, tmp.same, tmp.prev]]};
IDSRestrictionSize:
PROC [br: BiRel, sets: SetPair, limit:
EINT]
RETURNS [
EINT] ~ {
ids: IDSubset ~ NARROW[br.data];
subj: Set ~ Restrict[ids.set, sets];
RETURN subj.Size[limit]};
IDSGetBounds:
PROC [br: BiRel, want: EndBools, ro: RelOrder]
RETURNS [MaybePairInterval] ~ {
ids: IDSubset ~ NARROW[br.data];
iwant: EndBools ~ IF ro.sub[ro.first]#bwd THEN want ELSE [want[max], want[min]];
mi: MaybeInterval ~ ids.set.GetBounds[iwant];
IF ro.sub[ro.first]#bwd THEN RETURN [[TRUE, [[mi.it[min], mi.it[min]], [mi.it[max], mi.it[max]]]]];
RETURN [[TRUE, [[mi.it[max], mi.it[max]], [mi.it[min], mi.it[min]]]]]};
IDSValueOf:
PROC [br: BiRel]
RETURNS [ConstBiRel] ~ {
ids: IDSubset ~ NARROW[br.data];
RETURN CreateIDSubset[ids.set.ValueOf].AsConst};
IDSSetOn:
PROC [br: BiRel, side: Side]
RETURNS [UWSet] ~ {
ids: IDSubset ~ NARROW[br.data];
RETURN ids.set.Insulate};
IDSCurSetOn:
PROC [br: BiRel, side: Side]
RETURNS [ConstSet] ~ {
ids: IDSubset ~ NARROW[br.data];
RETURN ids.set.ValueOf};
IDSSpaces:
PROC [br: BiRel]
RETURNS [SpacePair] ~ {
ids: IDSubset ~ NARROW[br.data];
RETURN [ALL[ids.space]]};
IDSIsDense:
PROC [br: BiRel, when: When, side: Side]
RETURNS [
BOOL] ~ {
ids: IDSubset ~ NARROW[br.data];
RETURN ids.set.IsDense[when]};
Start:
PROC ~ {
FOR mut: UnwriteableMutability
IN UnwriteableMutability
DO
idsClasses[mut] ← CreateClass[
cp: [
HasPair: IDSHasPair,
Image: IF mut#variable THEN IDSImage ELSE NIL,
Apply: IDSApply,
ScanRestriction: IDSScanRestriction,
GetOne: IDSGetOne,
Get3: IDSGet3,
RestrictionSize: IDSRestrictionSize,
GetBounds: IDSGetBounds,
ValueOf: IF mut#constant THEN IDSValueOf ELSE NIL,
SetOn: IDSSetOn,
CurSetOn: IDSCurSetOn,
Spaces: IDSSpaces,
IsDense: IDSIsDense,
functional: ALL[TRUE],
mutability: mut],
dirable: ALL[TRUE]];
FOR l2r:
BOOL
IN
BOOL
DO
FOR r2l:
BOOL
IN
BOOL
DO
productClasses[mut][l2r][r2l] ← CreateClass[
cp: [
HasPair: ProductHasPair,
Image: ProductImage,
Apply: ProductApply,
ScanRestriction: ProductScanRestriction,
Get3: ProductGet3,
RestrictionSize: ProductRestrictionSize,
GetBounds: ProductGetBounds,
ValueOf: ProductValueOf,
SetOn: ProductSetOn,
CurSetOn: ProductCurSetOn,
Spaces: ProductSpaces,
IsDense: ProductIsDense,
SideFixed: ProductSideFixed,
functional: [l2r, r2l],
mutability: mut],
dirable: ALL[TRUE]];
ENDLOOP ENDLOOP
ENDLOOP;
};
CeilDiv:
PROC [num, den:
LNAT]
RETURNS [
LNAT] ~ {
RETURN [(num+den-1)/den]};
Start[];
END.