
<<LichenSetTheoryImpl.Mesa>>
<<Last Edited by: Spreitzer, May 11, 1986 4:18:25 pm PDT>>
    <<Mike Spreitzer September 20, 1986 3:05:37 pm PDT>>

    DIRECTORY HashTable, LichenSetTheory;

    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,
            DontErase,
            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};

        DontErase: PUBLIC PROC [set: Set] = {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,
            EraseHashSet,
            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]};

        EraseHashSet: PROC [set: Set] = {
            ht: HashTable.Table = NARROW[set.data];
            ht.Erase[]};

        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,
            DontErase,
            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 [
            
            
            };

        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.