DataMuseum.dk

top - metrics - download

    Length: 13820 (0x35fc)
    Types: TextFile
    Names: »B«

└─⟦180fe333a⟧ Bits:30000405 8mm tape, Rational 1000, SW CATALOG, 10_20_0
└─⟦180fe333a⟧ Bits:30000537 8mm tape, Rational 1000, SW Catalog 10_20_0
    └─⟦5cb1d1d7f⟧ »DATA« 
        └─⟦3b1ee7bd8⟧ 
            └─⟦this⟧ 

TextFile

--------------------------------- COPYRIGHT ------------------------------------
-- (C) 1986 Swiss Federal Institute of Technology (EPFL).                     --
--     Represented by A. Strohmeier DMA-EPFL 1015 Lausanne Switzerland.       --
--     All Rights Reserved.                                                   --
--------------------------------------------------------------------------------

--+ TITLE:      GENERIC PACKAGE FOR SETS.
--+ SUPPORT:    S.R.Y. Louboutin,  CGL-DMA-EPFL,  CH-1015 LAUSANNE
--+ APPROVAL:   03-DEC-1987 C. Genillard.
--+ CREATION:   31-AUG-1987 A. Strohmeier.

package body Set_Of_Discrete_Items_G is
---------------------

--/ CONSTRUCTORS:

    function To_Set (List : List_Type) return Set_Type is
        --+ OVERVIEW: Create a set from a list.
        Set : Set_Type;
    begin -- TO_SET
        for I in List'Range loop
            Set.Table (List (I)) := True;
        end loop;
        return Set;
    end To_Set;
    pragma Inline (To_Set);

    function Set_From_Range
                (Lower_Bound, Upper_Bound : Item_Type) return Set_Type is
        --+ OVERVIEW:
        --+   Build the set of all items between LOWER_BOUND and UPPER_BOUND.
        --+ If LOWER_BOUND > UPPER_BOUND then the set will be empty.
        Result : Set_Type;
    begin  --  SET_FROM_RANGE
        for Item in Lower_Bound .. Upper_Bound loop
            Result.Table (Item) := True;
        end loop;
        return Result;
    end Set_From_Range;

    procedure Assign (Destination : out Set_Type; Source : in Set_Type) is
    begin
        Destination := Source;
    end Assign;

    procedure Destroy (Set : in out Set_Type) is
    begin
        Set := Empty_Set;
    end Destroy;

    procedure Add (Set : in out Set_Type; Item : in Item_Type) is
    begin
        Set.Table (Item) := True;
    end Add;

    procedure Insert (Set : in out Set_Type; Item : in Item_Type) is
    begin
        if Set.Table (Item) then
            raise Duplicate_Item_Error;
        else
            Set.Table (Item) := True;
        end if;
    end Insert;

    procedure Insert (Set : in out Set_Type;
                      Item : in Item_Type;
                      Duplicate_Item : out Boolean) is
    begin
        Duplicate_Item := Set.Table (Item);
        Set.Table (Item) := True;
    end Insert;

    procedure Delete (Set : in out Set_Type; Item : in Item_Type) is
    begin
        Set.Table (Item) := False;
    end Delete;

    procedure Remove (Set : in out Set_Type; Item : in Item_Type) is
    begin
        if not Set.Table (Item) then
            raise Missing_Item_Error;
        else
            Set.Table (Item) := False;
        end if;
    end Remove;

    procedure Remove (Set : in out Set_Type;
                      Item : in Item_Type;
                      Found : out Boolean) is
    begin
        Found := Set.Table (Item);
        Set.Table (Item) := False;
    end Remove;

    procedure Remove_Min (Set : in out Set_Type) is
    begin
        for E in Item_Type'First .. Item_Type'Last loop
            if Set.Table (E) then
                Set.Table (E) := False;
                return;
            end if;
        end loop;
        raise Empty_Structure_Error;
    end Remove_Min;

    procedure Remove_Min (Set : in out Set_Type; Item : out Item_Type) is
    begin
        for E in Item_Type'First .. Item_Type'Last loop
            if Set.Table (E) then
                Set.Table (E) := False;
                Item := E;
                return;
            end if;
        end loop;
        raise Empty_Structure_Error;
    end Remove_Min;

    procedure Remove_Max (Set : in out Set_Type) is
    begin
        for E in reverse Item_Type'First .. Item_Type'Last loop
            if Set.Table (E) then
                Set.Table (E) := False;
                return;
            end if;
        end loop;
        raise Empty_Structure_Error;
    end Remove_Max;

    procedure Remove_Max (Set : in out Set_Type; Item : out Item_Type) is
    begin
        for E in reverse Item_Type'First .. Item_Type'Last loop
            if Set.Table (E) then
                Set.Table (E) := False;
                Item := E;
                return;
            end if;
        end loop;
        raise Empty_Structure_Error;
    end Remove_Max;


--/ QUERIES:

    function Size (Set : Set_Type) return Natural is
        N : Natural := 0;
    begin
        for E in Item_Type'First .. Item_Type'Last loop
            if Set.Table (E) then
                N := N + 1;
            end if;
        end loop;
        return N;
    end Size;

    function Is_Empty (Set : Set_Type) return Boolean is
    begin -- IS_EMPTY
        return Set = Empty_Set;
    end Is_Empty;

    function Is_Full (Set : Set_Type) return Boolean is
    begin -- IS_FULL
        return Set = Full_Set;
    end Is_Full;

    function Is_Present (Set : Set_Type; Item : Item_Type) return Boolean is
    begin
        return Set.Table (Item);
    end Is_Present;

--/ LOCAL SUBPROGRAM:
    function Local_Get_Min (Set : Set_Type) return Item_Type is
    begin
        for E in Item_Type'First .. Item_Type'Last loop
            if Set.Table (E) then
                return E;
            end if;
        end loop;
        raise Empty_Structure_Error;
    end Local_Get_Min;
    pragma Inline (Local_Get_Min);

    function Min (Set : Set_Type) return Item_Type is
    begin
        return Local_Get_Min (Set);
    end Min;

    procedure Get_Min (Set : in Set_Type; Item : out Item_Type) is
    begin
        Item := Local_Get_Min (Set);
    end Get_Min;

--/ LOCAL SUBPROGRAM:
    function Local_Get_Max (Set : Set_Type) return Item_Type is
    begin
        for E in reverse Item_Type'First .. Item_Type'Last loop
            if Set.Table (E) then
                return E;
            end if;
        end loop;
        raise Empty_Structure_Error;
    end Local_Get_Max;

    function Max (Set : Set_Type) return Item_Type is
    begin
        return Local_Get_Max (Set);
    end Max;

    procedure Get_Max (Set : in Set_Type; Item : out Item_Type) is
    begin
        Item := Local_Get_Max (Set);
    end Get_Max;

--/ LOCAL SUBPROGRAM:
    function Local_Get_Less
                (Set : Set_Type; Item : Item_Type) return Item_Type is
    begin
        if Item = Item_Type'First then
            raise Missing_Item_Error;
        end if;
        for E in reverse Item_Type'First .. Item_Type'Pred (Item) loop
            if Set.Table (E) then
                return E;
            end if;
        end loop;
        raise Missing_Item_Error;
    end Local_Get_Less;
    pragma Inline (Local_Get_Less);

    function Less (Set : Set_Type; Item : Item_Type) return Item_Type is
    begin
        return Local_Get_Less (Set, Item);
    end Less;

    procedure Get_Less (Set : in Set_Type; Item : in out Item_Type) is
    begin
        Item := Local_Get_Less (Set, Item);
    end Get_Less;

    procedure Get_Less (Set : in Set_Type;
                        Item : in out Item_Type;
                        Found : out Boolean) is
    begin
        Found := True;
        Item := Local_Get_Less (Set, Item);
    exception
        when Missing_Item_Error =>
            Found := False;
    end Get_Less;

--/ LOCAL SUBPROGRAM:
    function Local_Get_Less_Or_Equal
                (Set : Set_Type; Item : Item_Type) return Item_Type is
    begin
        for E in reverse Item_Type'First .. Item loop
            if Set.Table (E) then
                return E;
            end if;
        end loop;
        raise Missing_Item_Error;
    end Local_Get_Less_Or_Equal;
    pragma Inline (Local_Get_Less_Or_Equal);

    function Less_Or_Equal
                (Set : Set_Type; Item : Item_Type) return Item_Type is
    begin
        return Local_Get_Less_Or_Equal (Set, Item);
    end Less_Or_Equal;

    procedure Get_Less_Or_Equal (Set : in Set_Type; Item : in out Item_Type) is
    begin
        Item := Local_Get_Less_Or_Equal (Set, Item);
    end Get_Less_Or_Equal;

    procedure Get_Less_Or_Equal (Set : in Set_Type;
                                 Item : in out Item_Type;
                                 Found : out Boolean) is
    begin
        Found := True;
        Item := Local_Get_Less_Or_Equal (Set, Item);
    exception
        when Missing_Item_Error =>
            Found := False;
    end Get_Less_Or_Equal;

--/ LOCAL SUBPROGRAM:
    function Local_Get_Greater
                (Set : Set_Type; Item : Item_Type) return Item_Type is
    begin
        if Item = Item_Type'Last then
            raise Missing_Item_Error;
        end if;
        for E in Item_Type'Succ (Item) .. Item_Type'Last loop
            if Set.Table (E) then
                return E;
            end if;
        end loop;
        raise Missing_Item_Error;
    end Local_Get_Greater;
    pragma Inline (Local_Get_Greater);

    function Greater (Set : Set_Type; Item : Item_Type) return Item_Type is
    begin
        return Local_Get_Greater (Set, Item);
    end Greater;

    procedure Get_Greater (Set : in Set_Type; Item : in out Item_Type) is
    begin
        Item := Local_Get_Greater (Set, Item);
    end Get_Greater;

    procedure Get_Greater (Set : in Set_Type;
                           Item : in out Item_Type;
                           Found : out Boolean) is
    begin
        Found := True;
        Item := Local_Get_Greater (Set, Item);
    exception
        when Missing_Item_Error =>
            Found := False;
    end Get_Greater;

--/ LOCAL SUBPROGRAM:
    function Local_Get_Greater_Or_Equal
                (Set : Set_Type; Item : Item_Type) return Item_Type is
    begin
        for E in Item .. Item_Type'Last loop
            if Set.Table (E) then
                return E;
            end if;
        end loop;
        raise Missing_Item_Error;
    end Local_Get_Greater_Or_Equal;
    pragma Inline (Local_Get_Greater_Or_Equal);

    function Greater_Or_Equal
                (Set : Set_Type; Item : Item_Type) return Item_Type is
    begin
        return Local_Get_Greater_Or_Equal (Set, Item);
    end Greater_Or_Equal;

    procedure Get_Greater_Or_Equal
                 (Set : in Set_Type; Item : in out Item_Type) is
    begin
        Item := Local_Get_Greater_Or_Equal (Set, Item);
    end Get_Greater_Or_Equal;

    procedure Get_Greater_Or_Equal (Set : in Set_Type;
                                    Item : in out Item_Type;
                                    Found : out Boolean) is
    begin
        Found := True;
        Item := Local_Get_Greater_Or_Equal (Set, Item);
    exception
        when Missing_Item_Error =>
            Found := False;
    end Get_Greater_Or_Equal;

--/ SET OPERATIONS:


    procedure Complement (Destination : out Set_Type; Source : in Set_Type) is
    begin
        Destination.Table := not Source.Table;
    end Complement;

    function Complement (Set : Set_Type) return Set_Type is
    begin
        return (Table => not Set.Table);
    end Complement;

    procedure Union (Destination : out Set_Type; Left, Right : in Set_Type) is
    begin
        Destination.Table := Left.Table or Right.Table;
    end Union;

    function Union (Left, Right : Set_Type) return Set_Type is
    begin
        return (Table => Left.Table or Right.Table);
    end Union;

    procedure Intersection (Destination : out Set_Type;
                            Left, Right : in Set_Type) is
    begin
        Destination.Table := Left.Table and Right.Table;
    end Intersection;

    function Intersection (Left, Right : Set_Type) return Set_Type is
    begin
        return (Table => Left.Table and Right.Table);
    end Intersection;

    procedure Difference (Destination : out Set_Type;
                          Left, Right : in Set_Type) is
    begin
        Destination.Table := Left.Table and not Right.Table;
    end Difference;

    function Difference (Left, Right : Set_Type) return Set_Type is
    begin
        return (Table => Left.Table and not Right.Table);
    end Difference;

    procedure Symmetric_Difference
                 (Destination : out Set_Type; Left, Right : in Set_Type) is
    begin
        Destination.Table := Left.Table xor Right.Table;
    end Symmetric_Difference;

    function Symmetric_Difference (Left, Right : Set_Type) return Set_Type is
    begin
        return (Table => Left.Table xor Right.Table);
    end Symmetric_Difference;

    function "<" (Left : Set_Type; Right : Set_Type) return Boolean is
    begin
        return ((Left /= Right) and then (Left and Right) = Left);
    end "<";

    function "<=" (Left : Set_Type; Right : Set_Type) return Boolean is
    begin -- "<="
        return (Left and Right) = Left;
    end "<=";

    function ">" (Left : Set_Type; Right : Set_Type) return Boolean is
    begin -- ">"
        return ((Left /= Right) and then (Left and Right) = Right);
    end ">";

    function ">=" (Left : Set_Type; Right : Set_Type) return Boolean is
    begin -- ">="
        return (Left and Right) = Right;
    end ">=";

--/ ITERATORS:

    procedure Traverse_Asc_G (Set : in Set_Type) is
        L_Rank : Natural := 0;
        Continue : Boolean := True;
    begin
        for E in Item_Type'First .. Item_Type'Last loop
            if Set.Table (E) then
                L_Rank := L_Rank + 1;
                Action (E, L_Rank, Continue);
            end if;
            exit when not Continue;
        end loop;
    end Traverse_Asc_G;

    procedure Traverse_Desc_G (Set : in Set_Type) is
        L_Rank : Natural := 0;
        Continue : Boolean := True;
    begin
        for E in reverse Item_Type'First .. Item_Type'Last loop
            if Set.Table (E) then
                L_Rank := L_Rank + 1;
                Action (E, L_Rank, Continue);
            end if;
            exit when not Continue;
        end loop;
    end Traverse_Desc_G;


end Set_Of_Discrete_Items_G;