|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - downloadIndex: ┃ B T ┃
Length: 8158 (0x1fde)
Types: TextFile
Names: »B«
└─⟦149519bd4⟧ Bits:30000546 8mm tape, Rational 1000, !projects 93-07-13
└─ ⟦124ff5788⟧ »DATA«
└─⟦this⟧
└─⟦f64eaa120⟧ Bits:30000752 8mm tape, Rational 1000, !projects 93 02 16
└─ ⟦6f12a12be⟧ »DATA«
└─⟦this⟧
with Class_Behavior;
with Collection;
with Instance;
package body Ball is
type Ball_Structure is
record
Size : Natural;
Color : Colors;
Place : Places;
Weight : Natural;
end record;
package Behavior is new Class_Behavior (Element => Ball_Structure,
With_Name => Class_Name,
With_Dates => Is_Dated,
With_Date_Mode => Date_Mode);
------------------------------------------------------------------------------
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 Mask (O : Object) is
begin
Behavior.Mask (The_Reference => O);
end Mask;
------------------------------------------------------------------------------
procedure Unmask (O : Object) is
begin
Behavior.Unmask (The_Reference => O);
end Unmask;
------------------------------------------------------------------------------
procedure Clean is
begin
Behavior.Clear;
end Clean;
------------------------------------------------------------------------------
procedure Mask_All is
begin
Behavior.Mask_All;
end Mask_All;
------------------------------------------------------------------------------
procedure Unmask_All is
begin
Behavior.Unmask_All;
end Unmask_All;
end Ball;