|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 13312 (0x3400)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Ball, seg_01182b
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦5a81ac88f⟧ »Space Info Vol 1«
└─⟦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;
nblk1=c
nid=8
hdr6=16
[0x00] rec0=23 rec1=00 rec2=01 rec3=004
[0x01] rec0=1f rec1=00 rec2=0c rec3=016
[0x02] rec0=05 rec1=00 rec2=0b rec3=000
[0x03] rec0=1a rec1=00 rec2=0a rec3=02c
[0x04] rec0=19 rec1=00 rec2=06 rec3=054
[0x05] rec0=04 rec1=00 rec2=07 rec3=054
[0x06] rec0=18 rec1=00 rec2=03 rec3=008
[0x07] rec0=16 rec1=00 rec2=05 rec3=050
[0x08] rec0=1c rec1=00 rec2=09 rec3=016
[0x09] rec0=1f rec1=00 rec2=04 rec3=018
[0x0a] rec0=06 rec1=00 rec2=02 rec3=000
[0x0b] rec0=06 rec1=00 rec2=02 rec3=000
tail 0x2150d0302823d49aac0df 0x42a00088462063c03
Free Block Chain:
0x8: 0000 00 00 01 1c 80 1b 69 63 74 20 28 57 68 69 74 65 ┆ ict (White┆