DataMuseum.dk

top - download

    Length: 7233 (0x1c41)
    Types: TextFile
    Names: »B«

└─⟦f64eaa120⟧ Bits:30000752 8mm tape, Rational 1000, !projects 93 02 16
    └─ ⟦6f12a12be⟧ »DATA« 
        └─⟦this⟧ 

TextFile

with Class_Behavior;
with Collection;
with Instance;

package body Ne_Ball is

    type Ball_Structure is
        record
            Size   : Natural;
            Color  : Colors;
            Place  : Places;
            Weight : Natural;
        end record;


    package Behavior is new Class_Behavior (Ball_Structure, "BALLS");

------------------------------------------------------------------------------
    function Size (O : Object) return Natural is
    begin
        return Behavior.Get (O).Size;
    end Size;

------------------------------------------------------------------------------
    function Weight (O : Object) return Natural is
    begin
        return Behavior.Get (O).Weight;
    end Weight;

------------------------------------------------------------------------------
    function Color (O : Object) return Colors is
    begin
        return Behavior.Get (O).Color;
    end Color;

------------------------------------------------------------------------------
    function Place (O : Object) return Places is
    begin
        return Behavior.Get (O).Place;
    end Place;

------------------------------------------------------------------------------


    function Instances return Collection.Object is
    begin
        return Behavior.Instances;  
    end Instances;




    function Instances (Kind : Existences := All_Balls)
                       return Collection.Object is
        function White_Ball_Predicate (O : Object) return Boolean is
        begin
            return Behavior.Get (O).Color = White;
        end White_Ball_Predicate;
        function White_Balls is new Collection.Restrict (White_Ball_Predicate);

        function Red_Ball_Predicate (O : Object) return Boolean is
        begin
            return Behavior.Get (O).Color = Red;
        end Red_Ball_Predicate;
        function Red_Balls is new Collection.Restrict (Red_Ball_Predicate);

        function Ball_On_Heap_Predicate (O : Object) return Boolean is
        begin
            return Behavior.Get (O).Place = Is_On_Heap;
        end Ball_On_Heap_Predicate;
        function Balls_On_Heap is
           new Collection.Restrict (Ball_On_Heap_Predicate);

    begin
        case Kind is
            when All_Balls =>
                return Behavior.Instances;
            when White_Balls =>
                return White_Balls (Behavior.Instances);
            when Red_Balls =>
                return Red_Balls (Behavior.Instances);
            when Balls_On_Heap =>
                return Balls_On_Heap (Behavior.Instances);
            when others =>
                return Behavior.Instances;
        end case;
    end Instances;

------------------------------------------------------------------------------
    function Exist (With_Place : Places; In_Kind_Of_Collection : Existences)
                   return Boolean is
        function Is_Place (O : Object) return Boolean is
        begin
            return Behavior.Get (O).Place = With_Place;
        end Is_Place;  
        function Exist_Place is new Collection.Exist (Is_Place);
    begin
        return Exist_Place (Instances (Kind => In_Kind_Of_Collection));
    end Exist;


    function Exist (With_Color : String; In_Kind_Of_Collection : Existences)
                   return Boolean is
        function Is_Color (O : Object) return Boolean is
        begin
            return Ball.Colors'Image (Behavior.Get (O).Color) = With_Color;
        end Is_Color;  
        function Exist_Color is new Collection.Exist (Is_Color);
    begin
        return Exist_Color (Instances (Kind => In_Kind_Of_Collection));
    end Exist;


    function Exist (With_Attributes       : Attributes;
                    Greater_Than          : Natural;
                    In_Kind_Of_Collection : Existences) return Boolean is
        function Is_Greater (O : Object) return Boolean is
        begin  
            case With_Attributes is
                when Ball.Is_Size =>
                    return Behavior.Get (O).Size > Greater_Than;
                when Ball.Is_Weight =>
                    return Behavior.Get (O).Weight > Greater_Than;
                when others =>
                    return False;
            end case;
        end Is_Greater;  
        function Exist_Greater is new Collection.Exist (Is_Greater);
    begin
        return Exist_Greater (Instances (Kind => In_Kind_Of_Collection));
    end Exist;


    function Exist (With_Attributes       : Attributes;
                    Between               : Natural;
                    And_Value             : Natural;
                    In_Kind_Of_Collection : Existences) return Boolean is
        function Is_Between (O : Object) return Boolean is
        begin  
            case With_Attributes is
                when Ball.Is_Size =>
                    return Behavior.Get (O).Size >= Between and
                              Behavior.Get (O).Size <= And_Value;
                when Ball.Is_Weight =>
                    return Behavior.Get (O).Weight >= Between and
                              Behavior.Get (O).Weight <= And_Value;
                when others =>
                    return False;
            end case;
        end Is_Between;  
        function Exist_Between is new Collection.Exist (Is_Between);
    begin
        return Exist_Between (Instances (Kind => In_Kind_Of_Collection));
    end Exist;

------------------------------------------------------------------------------
    function Add (With_Size   : Natural := Default_Size;
                  With_Color  : Colors  := Default_Color;
                  With_Place  : Places  := Default_Place;
                  With_Weight : Natural := Default_Weight) return Object is
        A_Ball : Ball_Structure;
    begin
        A_Ball.Size   := With_Size;
        A_Ball.Color  := With_Color;
        A_Ball.Place  := With_Place;  
        A_Ball.Weight := With_Weight;
        return Behavior.Allocate (The_Element => A_Ball);
    end Add;


------------------------------------------------------------------------------
    procedure Change (O           : Object;
                      With_Size   : Natural;
                      With_Color  : Colors;
                      With_Place  : Places;
                      With_Weight : Natural) is
        A_Ball : Ball_Structure;
    begin
        A_Ball        := Behavior.Get (The_Reference => O);
        A_Ball.Size   := With_Size;
        A_Ball.Color  := With_Color;
        A_Ball.Place  := With_Place;  
        A_Ball.Weight := With_Weight;
        Behavior.Set (The_Reference => O, With_Value => A_Ball);
    end Change;

    procedure Change (O : Object; With_Place : Places) is
        A_Ball : Ball_Structure;
    begin
        A_Ball       := Behavior.Get (The_Reference => O);
        A_Ball.Place := With_Place;
        Behavior.Set (The_Reference => O, With_Value => A_Ball);
    end Change;

------------------------------------------------------------------------------
    procedure Delete (O : Object) is
    begin
        Behavior.Dispose (The_Reference => O);
    end Delete;

------------------------------------------------------------------------------
    procedure Clean is
    begin
        Behavior.Clear;
    end Clean;

end Ne_Ball;