[Cyan]<CedarChest7.0>SetsAndStuff>BiRelsSimpleImpl.Mesa!3

BiRelsSimpleImpl.Mesa

Last tweaked by Mike Spreitzer on December 14, 1987 4:46:38 pm 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];

(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];

(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] ~ TRUSTED {

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.