|
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: 11264 (0x2c00)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Fact, seg_029562
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦cfc2e13cd⟧ »Space Info Vol 2«
└─⟦this⟧
with Condition;
with Text_Io;
use Condition;
package body Fact is
type Frame_Collection is array (Name range <>) of Frame;
Null_Object : constant Frame := (others => Dummy);
Working_Memory : Frame_Collection (1 .. 20) :=
(Frame'(Class => Robot, Size => Dummy, Colour => Green, State => Free),
Frame'(Class => Robot, Size => Dummy, Colour => Red, State => Busy),
Frame'(Class => Ball, Size => 50, Colour => Blue, State => On_Heap),
Frame'(Class => Ball, Size => 75, Colour => Green, State => On_Heap),
Frame'(Class => Ball, Size => 95, Colour => Red, State => On_Heap),
Frame'(Class => Ball, Size => 100, Colour => Blue, State => On_Heap),
Frame'(Class => Box, Size => 750, Colour => Red, State => Free),
Frame'(Class => Box, Size => 10000, Colour => Green, State => Free),
Frame'(Class => Box, Size => 150, Colour => Red, State => Busy),
others => Null_Object);
function Empty_Collection return Collection is
begin
return (1 .. 0 => Null_Name);
end Empty_Collection;
function Attribute_Image (Attribute : Integer) return String is
begin
case Attribute is
when Dummy =>
return "Dummy";
when Robot =>
return "Robot";
when Ball =>
return "Ball";
when Box =>
return "Box";
when Busy =>
return "Busy";
when Free =>
return "Free";
when On_Heap =>
return "On_Heap";
when In_Box =>
return "In_Box";
when Red =>
return "Red";
when Blue =>
return "Blue";
when Green =>
return "Green";
when others =>
return Integer'Image (Attribute);
end case;
end Attribute_Image;
procedure Put (The_Fact : Name) is
First : Boolean := True;
The_Object : Frame renames Working_Memory (The_Fact);
begin
if The_Object /= Null_Object then
for I in The_Object'Range loop
if not First then
Text_Io.Put (", ");
else
First := False;
end if;
Text_Io.Put (Slot_Name'Image (I) & " => " &
Attribute_Image (The_Object (I)));
end loop;
Text_Io.New_Line;
end if;
end Put;
procedure Put (The_Collection : Collection) is
begin
if The_Collection'Length /= 0 then
for I in The_Collection'Range loop
Put (The_Collection (I));
end loop;
else
Text_Io.Put_Line ("no match !!!");
end if;
end Put;
function Match (Value : Frame; Against : Pattern) return Boolean is
begin
if Value (Class) /= Dummy then
for I in Value'Range loop
if not Match (Value (I), Against (I)) then
return False;
end if;
end loop;
return True;
else
return False;
end if;
end Match;
function Find (Filter : Pattern) return Name is
begin
for I in Working_Memory'Range loop
if Match (Working_Memory (I), Against => Filter) then
return I;
end if;
end loop;
return Null_Name;
end Find;
-- procedure Solve_1 (Filter : Query) is
-- Result : Object;
-- begin
-- Result := Find (Filter.Value);
-- if Result /= Null_Object then
-- case Filter.Kind is
-- when Find =>
-- null;
-- when Check_No =>
-- Text_Io.Put ("Failed : ");
-- end case;
-- Put (Result);
-- else
-- Text_Io.Put_Line ("no match !!!");
-- end if;
-- end Solve_1;
function Retrieve (Filter : Join_Descriptor) return Collection is
Result : Collection (Filter'Range);
Wm : Frame_Collection renames Working_Memory;
function Recursive_Search (Search_Index : Positive) return Boolean is
begin
if Search_Index > Filter'Last then
return True;
else
case Filter (Search_Index).Kind is
when Find =>
for I in Wm'Range loop
if Match (Wm (I), Filter (Search_Index).Value) then
if Recursive_Search (Search_Index + 1) then
Result (Search_Index) := I;
return True;
end if;
end if;
end loop;
when Check_No =>
for I in Wm'Range loop
if Match (Wm (I), Filter (Search_Index).Value) then
return False;
end if;
end loop;
if Recursive_Search (Search_Index + 1) then
Result (Search_Index) := Null_Name;
return True;
end if;
end case;
return False;
end if;
end Recursive_Search;
begin
if Filter'Length /= 0 and then Recursive_Search (Filter'First) then
return Result;
else
return Empty_Collection;
end if;
end Retrieve;
-- procedure Solve (Filter : Join_Descriptor) is
-- begin
-- Put (Retrieve (Filter));
-- end Solve;
procedure Add (The_Fact : Frame) is
begin
for I in Working_Memory'Range loop
if Working_Memory (I) = Null_Object then
Working_Memory (I) := The_Fact;
return;
end if;
end loop;
raise Overflow;
end Add;
procedure Delete (The_Fact : Name) is
begin
Working_Memory (The_Fact) := Null_Object;
end Delete;
procedure Change (The_Fact : Name; Value : Frame) is
begin
Working_Memory (The_Fact) := Value;
end Change;
procedure Change (The_Fact : Name;
The_Slot : Slot_Name;
To_Value : Integer) is
The_Frame : Frame renames Working_Memory (The_Fact);
begin
The_Frame (The_Slot) := To_Value;
end Change;
end Fact;
nblk1=a
nid=8
hdr6=12
[0x00] rec0=17 rec1=00 rec2=01 rec3=01a
[0x01] rec0=21 rec1=00 rec2=06 rec3=016
[0x02] rec0=1f rec1=00 rec2=02 rec3=04c
[0x03] rec0=22 rec1=00 rec2=0a rec3=01e
[0x04] rec0=01 rec1=00 rec2=05 rec3=00c
[0x05] rec0=19 rec1=00 rec2=04 rec3=014
[0x06] rec0=00 rec1=00 rec2=07 rec3=008
[0x07] rec0=1c rec1=00 rec2=03 rec3=016
[0x08] rec0=1f rec1=00 rec2=09 rec3=000
[0x09] rec0=19 rec1=00 rec2=09 rec3=000
tail 0x21722d09083cd87979ec6 0x42a00088462063c03
Free Block Chain:
0x8: 0000 00 00 00 03 00 00 00 00 00 00 00 00 00 00 00 00 ┆ ┆