StdPairCollections3.Mesa
Last tweaked by Mike Spreitzer on October 19, 1987 1:50:59 pm PDT
DIRECTORY Basics, Collections, PairCollections, List, Rope;
StdPairCollections3:
CEDAR
PROGRAM
IMPORTS Collections, PairCollections, List, Rope
EXPORTS PairCollections
=
BEGIN OPEN Colls:Collections, Collections, PairCollections;
CreatePairSpace:
PROC [sp: SpacePair]
RETURNS [s: Space] ~ {
name: ROPE ~ Rope.Cat["pairs in [", SpaceName[sp[left]], ", ", SpaceName[sp[right]], "]"];
s ←
NEW [SpacePrivate ← [
Equal: PairEqual,
Hash: HashPair,
Compare: ComparePair,
other: List.PutAssoc[$Name, name, NIL],
data: NEW [SpacePair ← sp]
]];
RETURN};
SpaceName:
PROC [s: Space]
RETURNS [
ROPE] ~ {
WITH List.Assoc[$Name, s.other]
SELECT
FROM
x: ROPE => RETURN [x];
x: REF READONLY TEXT => RETURN [Rope.FromRefText[x]];
ENDCASE => RETURN ["??"];
};
PairEqual:
PROC [data:
REF
ANY, elt1, elt2: Value]
RETURNS [b:
BOOL] ~ {
sp: REF SpacePair ~ NARROW[data];
pair1: REF Pair ~ NARROW[elt1];
pair2: REF Pair ~ NARROW[elt2];
b ← sp[left].SpaceEqual[pair1[left], pair2[left]] AND sp[right].SpaceEqual[pair1[right], pair2[right]];
RETURN};
HashPair:
PROC [data:
REF
ANY, elt: Value]
RETURNS [hash:
CARDINAL] ~ {
sp: REF SpacePair ~ NARROW[data];
pair: REF Pair ~ NARROW[elt];
hash ← sp[left].SpaceHash[pair[left]]*17 + sp[right].SpaceHash[pair[right]];
RETURN};
ComparePair:
PROC [data:
REF
ANY, elt1, elt2: Value]
RETURNS [c: Basics.Comparison] ~ {
sp: REF SpacePair ~ NARROW[data];
pair1: REF Pair ~ NARROW[elt1];
pair2: REF Pair ~ NARROW[elt2];
c ← sp[left].SpaceCompare[pair1[left], pair2[left]];
IF c=equal THEN c ← sp[right].SpaceCompare[pair1[right], pair2[right]];
RETURN};
refPairSpace: Space ~ CreatePairSpace[[refs, refs]];
pairToSpace: Function--REF SpacePair b its pair space-- ~ CreateHashFn[spaces: [refPairSpace, refs], invable: FALSE];
WidenSpacePair:
PUBLIC
PROC [sp: SpacePair]
RETURNS [s: Space] ~ {
IF sp = [refs, refs] THEN RETURN [refPairSpace];
{rsp: REF Pair ~ NEW [Pair ← [left: sp[left], right: sp[right]]];
mv: MaybeValue ~ pairToSpace.Apply[rsp];
IF mv.found THEN RETURN [NARROW[mv.val]];
s ← CreatePairSpace[sp];
[] ← pairToSpace.AddPair[[rsp, s]];
RETURN}};
IsPairSpace:
PUBLIC
PROC [s: Space]
RETURNS [
BOOL] ~ {
RETURN [s.Equal=PairEqual AND s.Hash=HashPair AND s.Compare=ComparePair AND ISTYPE[s.data, REF SpacePair]]};
NarrowSpace:
PUBLIC
PROC [s: Space]
RETURNS [sp: SpacePair] ~ {
IF NOT IsPairSpace[s] THEN ERROR;
{rsp: REF SpacePair ~ NARROW[s.data];
RETURN [rsp^]}};
orderSpace: Colls.Space ~
NEW [Colls.SpacePrivate ← [
Equal: EqualOrderings,
Hash: HashOrdering,
Compare: CompareOrderings,
other: List.PutAssoc[$Name, "pair orderings", NIL]
]];
EqualOrderings:
PROC [data:
REF
ANY, elt1, elt2: Value]
RETURNS [
BOOL] ~ {
o1: REF Ordering ~ NARROW[elt1];
o2: REF Ordering ~ NARROW[elt2];
RETURN [o1^ = o2^]};
HashOrdering:
PROC [data:
REF
ANY, elt: Value]
RETURNS [hash:
CARDINAL] ~ {
o: REF Ordering ~ NARROW[elt];
hash ← Colls.HashIntI[INT[LOOPHOLE[o.Compare, CARDINAL]]*19] + Colls.HashRefI[o.data];
RETURN};
CompareOrderings:
PROC [data:
REF
ANY, elt1, elt2: Value]
RETURNS [c: Basics.Comparison] ~ {
o1: REF Ordering ~ NARROW[elt1];
o2: REF Ordering ~ NARROW[elt2];
IF (c ← Colls.CompareIntI[LOOPHOLE[o1.Compare, CARDINAL], LOOPHOLE[o2.Compare, CARDINAL]])#equal THEN RETURN;
c ← Colls.CompareRefI[o1.data, o2.data];
RETURN};
pairifyOrdering: Function--REF Ordering b REF Colls.Ordering-- ~ CreateHashFn[spaces: [orderSpace, refs], invable: FALSE];
WidenOrdering:
PUBLIC
PROC [o: Ordering]
RETURNS [wo: Colls.Ordering] ~ {
IF o.Compare=NarrowCompare AND ISTYPE[o.data, REF Colls.Ordering] THEN RETURN [NARROW[o.data, REF Colls.Ordering]^];
{ref: REF Ordering ~ NEW [Ordering ← o];
rwo: REF Colls.Ordering ~ NARROW[pairifyOrdering.Apply[ref].DVal];
IF rwo#NIL THEN RETURN [rwo^];
wo ← [WideCompare, ref];
[] ← pairifyOrdering.AddPair[[ref, NEW [Colls.Ordering ← wo]]];
RETURN}};
WideCompare:
PROC [data:
REF
ANY, elt1, elt2: Value]
RETURNS [Basics.Comparison] ~ {
ref: REF Ordering ~ NARROW[data];
pair1: REF Pair ~ NARROW[elt1];
pair2: REF Pair ~ NARROW[elt2];
RETURN ref.Compare[ref.data, pair1^, pair2^]};
NarrowOrdering:
PUBLIC
PROC [wo: Colls.Ordering]
RETURNS [o: Ordering] ~ {
IF wo=Colls.unordered THEN RETURN [unordered];
IF wo.Compare=WideCompare
AND
ISTYPE[wo.data,
REF Ordering]
THEN RETURN [NARROW[wo.data, REF Ordering]^]
ELSE RETURN [[NarrowCompare, NEW [Colls.Ordering ← wo], both]];
};
NarrowCompare:
PROC [data:
REF
ANY, elt1, elt2: Pair]
RETURNS [Basics.Comparison] ~ {
rwo: REF Colls.Ordering ~ NARROW[data];
rp1: REF Pair ~ NEW [Pair ← elt1];
rp2: REF Pair ~ NEW [Pair ← elt2];
RETURN rwo.Compare[rwo.data, rp1, rp2]};
CreateIDSubset:
PUBLIC
PROC [sub: Collection]
RETURNS [PairColl] ~ {
RETURN [[idClasses[sub.MayDuplicate[]][sub.OrderStyleOf][sub.MutabilityOf[]], sub.Refify]]};
IDClasses: TYPE ~ ARRAY --mayDuplicate--BOOL OF ARRAY OrderStyle OF ARRAY Mutability OF PairCollClass;
idClasses: REF IDClasses ~ NEW [IDClasses];
IDPrimitive:
PROC [pc: PairColl, op:
ATOM, args: ArgList ←
NIL]
RETURNS [PrimitiveAnswer] ~ {
sub: Collection ~ Colls.DeRef[pc.data];
SELECT op
FROM
$Scan => RETURN [IF sub.QualityOf[op, args]>=goodDefault THEN yes ELSE no];
ENDCASE => RETURN [pass];
};
IDHasPair:
PROC [pc: PairColl, pair: Pair]
RETURNS [
BOOL] ~ {
sub: Collection ~ Colls.DeRef[pc.data];
RETURN [sub.SpaceOf.SpaceEqual[pair[left], pair[right]] AND sub.HasMember[pair[left]]]};
IDApply:
PROC [pc: PairColl, v: Value, dir: Direction]
RETURNS [MaybeValue] ~ {
sub: Collection ~ Colls.DeRef[pc.data];
IF sub.HasMember[v] THEN RETURN [[TRUE, v]] ELSE RETURN [noMaybe];
};
IDScan:
PROC [pc: PairColl,
Test: Tester, bkwd:
BOOL]
RETURNS [mp: MaybePair] ~ {
sub: Collection ~ Colls.DeRef[pc.data];
PerElt:
PROC [v: Value]
RETURNS [pass:
BOOL] ~ {
IF (pass ← Test[[v, v]]) THEN mp ← [TRUE, [v, v]];
RETURN};
mp ← noMaybePair;
[] ← sub.Scan[PerElt, bkwd];
RETURN};
IDSize:
PROC [pc: PairColl, limit:
LNAT]
RETURNS [
LNAT] ~ {
sub: Collection ~ Colls.DeRef[pc.data];
RETURN sub.Size[limit]};
IDCollectionOn:
PROC [pc: PairColl, side: Side]
RETURNS [UWColl] ~ {
sub: Collection ~ Colls.DeRef[pc.data];
RETURN [sub.Insulate]};
IDCurSetOn:
PROC [pc: PairColl, side: Side]
RETURNS [ConstSet] ~ {
sub: Collection ~ Colls.DeRef[pc.data];
RETURN [sub.ValueOf]};
IDAddColl:
PROC [pc, other: PairColl, if: IfNewsPair, where: Where]
RETURNS [some: NewsSetPair] ~
TRUSTED {
sub: Collection ~ Colls.DeRef[pc.data];
space: Space ~ sub.SpaceOf[];
cWhere: Colls.Where ~
WITH where
SELECT
FROM
any => [any[]],
end => [end[end]],
rel => [rel[elt: pair[left], reln: reln]],
ENDCASE => ERROR;
PerPair:
PROC [pair: Pair] ~
CHECKED {
v: Value ~ pair[left];
IF NOT space.SpaceEqual[v, pair[right]] THEN Complain[pc, "Can't add pair of non-equal values [%g, %g]", LIST[v, pair[right]]];
IF sub.AddElt[v, cWhere]
THEN some[leftToRight][new] ← some[rightToLeft][new] ← TRUE
ELSE some[leftToRight][same] ← some[rightToLeft][same] ← TRUE;
RETURN};
WITH where
SELECT
FROM
any, end => NULL;
rel => IF NOT space.SpaceEqual[pair[left], pair[right]] THEN Complain[pc, "Can't add relative to pair of non-equal values [%g, %g]", LIST[pair[left], pair[right]]];
ENDCASE => NULL;
some ← ALL[ALL[FALSE]];
other.Enumerate[PerPair];
RETURN};
IDRemColl:
PROC [pc, other: PairColl, style: RemoveStyle]
RETURNS [hadSome, hadAll: BoolPair] ~ {
sub: Collection ~ Colls.DeRef[pc.data];
space: Space ~ sub.SpaceOf[];
PerPair:
PROC [pair: Pair] ~ {
v: Value ~ pair[left];
IF space.SpaceEqual[v, pair[right]] AND sub.RemoveElt[v, style] THEN hadSome ← ALL[TRUE] ELSE hadAll ← ALL[FALSE];
RETURN};
hadAll ← ALL[TRUE];
hadSome ← ALL[FALSE];
other.Enumerate[PerPair];
RETURN};
IDDeleteColl:
PROC [pc: PairColl, coll: Collection, side: Side, style: RemoveStyle]
RETURNS [hadSome, hadAll:
BOOL] ~ {
sub: Collection ~ Colls.DeRef[pc.data];
RETURN sub.RemoveColl[coll, style]};
IDSpaces:
PROC [pc: PairColl]
RETURNS [SpacePair] ~ {
sub: Collection ~ Colls.DeRef[pc.data];
space: Space ~ sub.SpaceOf[];
RETURN [[space, space]]};
CreateProduct:
PUBLIC
PROC [cp: CollPair]
RETURNS [PairColl] ~ {
rcp: REF CollPair ~ NEW [CollPair ← cp];
mut: UnwriteableMutability ~ IF cp[left].MutabilityOf[]=constant AND cp[right].MutabilityOf[]=constant THEN constant ELSE readonly;
mayDup: BOOL ~ cp[left].MayDuplicate[] OR cp[right].MayDuplicate[];
RETURN [[prodClasses[mut][mayDup], rcp]]};
ProdClasses: TYPE ~ ARRAY UnwriteableMutability OF ARRAY --mayDuplicate--BOOL OF PairCollClass;
prodClasses: REF ProdClasses ~ NEW [ProdClasses];
ProdPrimitive:
PROC [pc: PairColl, op:
ATOM, args: ArgList ←
NIL]
RETURNS [PrimitiveAnswer] ~ {
rcp: REF CollPair ~ NARROW[pc.data];
SELECT op
FROM
$HasPair => RETURN [IF rcp[left].QualityOf[$HasMember]>=goodDefault AND rcp[right].QualityOf[$HasMember]>=goodDefault THEN yes ELSE no];
$ScanHalfRestriction => RETURN [IF rcp[left].QualityOf[$Scan, LIST[FromBool[GetBool[args, 2]]]]>=goodDefault AND rcp[right].QualityOf[$HasMember, LIST[FromBool[GetBool[args, 2]]]]>=goodDefault THEN yes ELSE no];
$Size => RETURN [IF rcp[left].QualityOf[op, args]>=goodDefault AND rcp[right].QualityOf[op, args]>=goodDefault THEN yes ELSE no];
ENDCASE => RETURN [pass];
};
ProdHasPair:
PROC [pc: PairColl, pair: Pair]
RETURNS [
BOOL] ~ {
rcp: REF CollPair ~ NARROW[pc.data];
RETURN [rcp[left].HasMember[pair[left]] AND rcp[right].HasMember[pair[right]]]};
ProdImage:
PROC [pc: PairColl, coll: Collection, dir: Direction]
RETURNS [UWColl] ~ {
rcp: REF CollPair ~ NARROW[pc.data];
pt: ProdTest ~ NEW [ProdTestPrivate ← [rcp[Source[dir]], coll]];
cond: Condition ~ NEW [ConditionPrivate ← [TestProd, pt]];
RETURN CreateConditional[cond, rcp[Dest[dir]]]};
ProdTest: TYPE ~ REF ProdTestPrivate;
ProdTestPrivate: TYPE ~ RECORD [dom, coll: Collection];
TestProd:
PROC [data:
REF
ANY]
RETURNS [
BOOL] ~ {
pt: ProdTest ~ NARROW[data];
RETURN [pt.coll.Intersection[pt.dom].Size[1] # 0]};
ProdScanHalfRestriction:
PROC [pc: PairColl, side: Side, coll: Collection,
Test: Tester, bkwd:
BOOL]
RETURNS [mp: MaybePair ← noMaybePair] ~ {
rcp: REF CollPair ~ NARROW[pc.data];
interesection: Collection ~ rcp[side].Intersection[coll];
Pass1:
PROC [v: Value]
RETURNS [pass:
BOOL] ~ {
pair: Pair ← ALL[v];
other: Side ~ OtherSide[side];
Pass2:
PROC [v: Value]
RETURNS [pass:
BOOL] ~ {
pair[other] ← v;
IF (pass ← Test[pair]) THEN mp ← [TRUE, pair];
RETURN};
pass ← rcp[other].Scan[Pass2, bkwd].found;
RETURN};
[] ← interesection.Scan[Pass1, bkwd];
RETURN};
ProdSize:
PROC [pc: PairColl, limit:
LNAT]
RETURNS [
LNAT] ~ {
rcp: REF CollPair ~ NARROW[pc.data];
s1: LNAT ~ rcp[left].Size[limit];
IF s1=0 THEN RETURN [0];
RETURN [s1 * rcp[right].Size[(limit+s1-1)/s1]]};
ProdValueOf:
PROC [pc: PairColl]
RETURNS [ConstPairColl] ~ {
rcp: REF CollPair ~ NARROW[pc.data];
RETURN [CreateProduct[[rcp[left].ValueOf[], rcp[right].ValueOf[]]].AsConst]};
ProdCollectionOn:
PROC [pc: PairColl, side: Side]
RETURNS [UWColl] ~ {
rcp: REF CollPair ~ NARROW[pc.data];
RETURN [rcp[side].Insulate]};
ProdCurSetOn:
PROC [pc: PairColl, side: Side]
RETURNS [ConstSet] ~ {
rcp: REF CollPair ~ NARROW[pc.data];
RETURN [rcp[side].ValueOf]};
ProdSpaces:
PROC [pc: PairColl]
RETURNS [SpacePair] ~ {
rcp: REF CollPair ~ NARROW[pc.data];
RETURN [[rcp[left].SpaceOf[], rcp[right].SpaceOf[]]]};
Start:
PROC ~ {
FOR mutability: Mutability
IN Mutability
DO
FOR mayDup:
BOOL
IN
BOOL
DO
IF mutability#variable
THEN prodClasses[mutability][mayDup] ← CreateClass[
cp: [
Primitive: ProdPrimitive,
HasPair: ProdHasPair,
Image: ProdImage,
ScanHalfRestriction: ProdScanHalfRestriction,
Size: ProdSize,
ValueOf: ProdValueOf,
CollectionOn: ProdCollectionOn,
CurSetOn: IF NOT mayDup THEN ProdCurSetOn ELSE NIL,
Spaces: ProdSpaces,
functional: ALL[FALSE],
mayDuplicate: mayDup,
orderStyle: none,
mutability: mutability,
data: NIL],
dirable: ALL[TRUE]];
FOR orderStyle: OrderStyle
IN OrderStyle
DO
idClasses[mayDup][orderStyle][mutability] ← CreateClass[
cp: [
Primitive: IDPrimitive,
HasPair: IDHasPair,
Apply: IDApply,
Scan: IDScan,
Size: IDSize,
CollectionOn: IDCollectionOn,
CurSetOn: IF NOT mayDup THEN IDCurSetOn ELSE NIL,
AddColl: IF mutability=variable THEN IDAddColl ELSE NIL,
RemColl: IF mutability=variable THEN IDRemColl ELSE NIL,
DeleteColl: IF mutability=variable THEN IDDeleteColl ELSE NIL,
Spaces: IDSpaces,
functional: ALL[TRUE],
mayDuplicate: mayDup,
orderStyle: orderStyle,
mutability: mutability,
data: NIL],
dirable: ALL[TRUE]];
ENDLOOP
ENDLOOP ENDLOOP;
};
Start[];
END.