LichenSetTheoryImpl:
CEDAR
PROGRAM
IMPORTS HashTable
EXPORTS LichenSetTheory =
BEGIN OPEN LichenSetTheory;
NotMutable: PUBLIC ERROR = CODE;
CreateHashMapper:
PUBLIC
PROC [equal: HashTable.EqualProc ←
NIL, hash: HashTable.HashProc ←
NIL]
RETURNS [m: Mapper] = {
m ← NEW [MapperPrivate ← [class: hashMapperClass, data: HashTable.Create[equal: equal, hash: hash]]]};
CreateHashDictionary:
PUBLIC
PROC [caseSensitive:
BOOL]
RETURNS [m: Mapper] = {
m ←
NEW [MapperPrivate ← [
class: hashMapperClass,
data: IF caseSensitive THEN HashTable.Create[equal: HashTable.RopeEqual, hash: HashTable.HashRope] ELSE HashTable.Create[equal: HashTable.RopeEqualModCase, hash: HashTable.HashRopeModCase]
]]};
hashMapperClass: MapperClass =
NEW [MapperClassPrivate ← [
Map: MapByHash,
SetMapping: SetHashMapping,
Enumerate: EnumerateHashMapping,
Size: HashMappingSize]];
MapByHash:
PROC [m: Mapper, domain:
REF
ANY]
RETURNS [range:
REF
ANY] = {
ht: HashTable.Table = NARROW[m.data];
range ← ht.Fetch[domain].value};
SetHashMapping:
PROC [m: Mapper, domain, range:
REF
ANY]
RETURNS [hadMapping:
BOOL] = {
ht: HashTable.Table = NARROW[m.data];
SELECT range
FROM
=NIL => hadMapping ← ht.Delete[domain];
#NIL => hadMapping ← NOT ht.Store[domain, range];
ENDCASE => ERROR;
};
EnumerateHashMapping:
PROC [m: Mapper,
Consume:
PROC [domain, range:
REF
ANY]] = {
ht: HashTable.Table = NARROW[m.data];
Pass: PROC [key, value: REF ANY] RETURNS [quit: BOOL ← FALSE] --HashTable.EachPairAction-- = {Consume[key, value]};
[] ← ht.Pairs[Pass];
};
HashMappingSize:
PROC [m: Mapper]
RETURNS [size:
INT] = {
ht: HashTable.Table = NARROW[m.data];
size ← ht.GetSize[]};
CreateSingleton:
PUBLIC
PROC [elt:
REF
ANY]
RETURNS [set: Set] = {
set ← NEW [SetPrivate ← [singletonClass, FALSE, elt]];
};
singletonClass: SetClass =
NEW [SetClassPrivate ← [
TestSingletonMembership,
DontUnionSingleton,
DontUnionSet,
DontRemoveElt,
EnumerateSingleton,
SingletonSize]];
TestSingletonMembership:
PROC [set: Set, elt:
REF
ANY]
RETURNS [in:
BOOL] = {
in ← elt = set.data};
DontUnionSet: PUBLIC PROC [self, other: Set] = {ERROR};
DontRemoveElt: PUBLIC PROC [set: Set, elt: REF ANY] = {ERROR};
EnumerateSingleton: PROC [set: Set, Consumer: PROC [REF ANY]] = {Consumer[set.data]};
SingletonSize: PROC [set: Set] RETURNS [INT] = {RETURN[1]};
CreateHashSet:
PUBLIC
PROC [equal: HashTable.EqualProc ←
NIL, hash: HashTable.HashProc ←
NIL]
RETURNS [set: Set] = {
set ← NEW [SetPrivate ← [class: hashSetClass, data: HashTable.Create[equal: equal, hash: hash]]]};
hashSetClass: SetClass =
NEW [SetClassPrivate ← [
TestHashSetMembership,
HashSetUnionSingleton,
HashSetUnionSet,
RemoveHashSetElt,
EnumerateHashSet,
HashSetSize]];
TestHashSetMembership:
PROC [set: Set, elt:
REF
ANY]
RETURNS [b:
BOOL] = {
ht: HashTable.Table = NARROW[set.data];
b ← ht.Fetch[elt].found};
HashSetUnionSingleton:
PROC [set: Set, elt:
REF
ANY]
RETURNS [new:
BOOL] = {
ht: HashTable.Table = NARROW[set.data];
new ← ht.Store[elt, $T];
};
HashSetUnionSet:
PROC [self, other: Set] = {
ht: HashTable.Table = NARROW[self.data];
Addit:
PROC [elt:
REF
ANY] = {
[] ← ht.Insert[elt, $T]};
other.class.Enumerate[other, Addit];
};
RemoveHashSetElt:
PROC [set: Set, elt:
REF
ANY] = {
ht: HashTable.Table = NARROW[set.data];
IF NOT ht.Delete[elt] THEN ERROR;
};
EnumerateHashSet:
PROC [set: Set,
Consumer:
PROC [
REF
ANY]] = {
ht: HashTable.Table = NARROW[set.data];
PerPair:
PROC [key, value:
REF
ANY]
RETURNS [quit:
BOOL ←
FALSE]
--HashTable.EachPairAction-- = {
Consumer[key];
};
[] ← ht.Pairs[PerPair]};
HashSetSize:
PROC [set: Set]
RETURNS [size:
INT] = {
ht: HashTable.Table = NARROW[set.data];
size ← ht.GetSize[]};
Unioned: TYPE = REF UnionedPrivate;
UnionedPrivate:
TYPE =
RECORD [
incr, decr: SetList, --ordered by increasing size, decreasing size
eltsImmutable: BOOL,
size: INT ← notComputed
];
notComputed: INT = FIRST[INT];
unionSetClass: SetClass =
NEW [SetClassPrivate ← [
TestUnionMembership,
DontUnionSingleton,
UnionUnionSet,
DontRemoveElt,
EnumerateUnion,
UnionSize]];
CreateUnion:
PUBLIC
PROC [sets: SetList, eltsImmutable:
BOOL ←
TRUE]
RETURNS [set: Set] = {
u: Unioned = NEW [UnionedPrivate ← [eltsImmutable: eltsImmutable]];
[u.incr, u.decr] ← SizeSort[sets];
set ←
NEW [SetPrivate ← [
class: unionSetClass,
data: u
]];
};
TestUnionMembership:
PROC [set: Set, elt:
REF
ANY]
RETURNS [in:
BOOL] = {
u: Unioned = NARROW[set.data];
FOR sets: SetList ← u.decr, sets.rest
WHILE sets #
NIL
DO
IF sets.first.class.TestMembership[sets.first, elt] THEN RETURN [TRUE];
ENDLOOP;
in ← FALSE;
};
DontUnionSingleton:
PUBLIC
PROC [set: Set, elt:
REF
ANY]
RETURNS [new:
BOOL] = {
ERROR};
UnionUnionSet:
PROC [self, other: Set] = {
u: Unioned = NARROW[self.data];
[u.incr, u.decr] ← SizeInsert[u.incr, u.decr, other];
u.size ← notComputed;
};
EnumerateUnion:
PROC [set: Set,
Consumer:
PROC [
REF
ANY]] = {
u: Unioned = NARROW[set.data];
IF u.incr = NIL THEN RETURN;
u.incr.first.class.Enumerate[u.incr.first, Consumer];
EnumerateSetlistRestUnion[u.incr, Consumer];
};
EnumerateSetlistRestUnion:
PROC [sets: SetList,
Consumer:
PROC [
REF
ANY]] = {
FOR i: SetList ← sets.rest, i.rest
WHILE i #
NIL
DO
Filter:
PROC [elt:
REF
ANY] = {
FOR j: SetList ← sets, j.rest
WHILE j # i
DO
IF j.first.class.TestMembership[j.first, elt] THEN RETURN;
ENDLOOP;
Consumer[elt];
};
i.first.class.Enumerate[i.first, Filter];
ENDLOOP;
};
UnionSize:
PROC [set: Set]
RETURNS [size:
INT] = {
u: Unioned = NARROW[set.data];
CountIt: PROC [REF ANY] = {size ← size + 1};
IF u.size # notComputed THEN RETURN [u.size];
IF u.decr = NIL THEN RETURN [u.size ← 0];
size ← u.decr.first.class.Size[u.decr.first];
EnumerateSetlistRestUnion[u.decr, CountIt];
IF u.eltsImmutable THEN u.size ← size;
};
SizeSort:
PROC [sets: SetList]
RETURNS [increasing, decreasing: SetList] = {
increasing ← decreasing ← NIL;
WHILE sets #
NIL
DO
next: SetList = sets.rest;
increasing ← IncrInsert[increasing, sets];
sets ← next;
ENDLOOP;
FOR sets ← increasing, sets.rest
WHILE sets #
NIL
DO
decreasing ← CONS[sets.first, decreasing];
ENDLOOP;
};
SizeInsert:
PROC [oIncr, oDecr: SetList, set: Set]
RETURNS [
nIncr,
nDecr: SetList] = {
nIncr ← IncrInsert[oIncr, LIST[set]];
nDecr ← DecrInsert[oDecr, LIST[set]];
};
IncrInsert:
PROC [old, this: SetList]
RETURNS [new: SetList] = {
thisSize: INT = this.first.class.Size[this.first];
prev: SetList ← NIL;
following: SetList ← new ← old;
WHILE following #
NIL
AND thisSize > following.first.class.Size[following.first]
DO
prev ← following;
following ← following.rest;
ENDLOOP;
this.rest ← following;
IF prev = NIL THEN new ← this ELSE prev.rest ← this;
};
DecrInsert:
PROC [old, this: SetList]
RETURNS [new: SetList] = {
thisSize: INT = this.first.class.Size[this.first];
prev: SetList ← NIL;
following: SetList ← new ← old;
WHILE following #
NIL
AND thisSize <= following.first.class.Size[following.first]
DO
prev ← following;
following ← following.rest;
ENDLOOP;
this.rest ← following;
IF prev = NIL THEN new ← this ELSE prev.rest ← this;
};
END.