|
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 - metrics - download
Length: 17408 (0x4400)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Generic_Fact, package body Generic_Fact_Base, package body Working_Memory, seg_02bad1
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─⟦5a81ac88f⟧ »Space Info Vol 1«
└─⟦this⟧
package body Generic_Fact_Base is
package Working_Memory is
type Frame (Size : Value_Size := 0) is private;
type Slots is array (Slot_Names range <>) of Integer;
Null_Frame : constant Frame;
function Last return Object; -- objects are from 1 to last
procedure Make_Empty;
function Make (The_Class : Class_Name; The_Slots : Slots) return Frame;
function Get (The_Fact : Object) return Frame;
function Get (The_Fact : Object; Slot : Slot_Names) return Integer;
procedure Add (The_Fact : Frame);
procedure Delete (The_Fact : Object);
procedure Change (The_Fact : Object; Value : Frame);
procedure Change (The_Fact : Object;
The_Slot : Slot_Names;
To_Value : Integer);
function Match (The_Element : Object; Against : Query) return Boolean;
procedure Put (The_Fact : Object; Where : Output_Stream.Object);
procedure Put (Where : Output_Stream.Object); -- The working memory
private
type Frame (Size : Value_Size := 0) is
record
Class : Class_Name;
Value : Slots (1 .. Size);
end record;
Null_Frame : constant Frame :=
(Size => 0, Class => Null_Class_Name, Value => (others => 0));
end Working_Memory;
function Image (Of_Class : Class_Name) return String
renames Constant_String.Image;
function Empty_Collection return Collection is
begin
return (1 .. 0 => Null_Object);
end Empty_Collection;
function Null_Premiss return Queries is
begin
return Queries'(1 .. 0 => Null_Query);
end Null_Premiss;
function Retrieve (Filter : Queries) return Collection is
Result : Collection (Filter'Range);
function Recursive_Search (Index : Positive) return Boolean is
Filter_Class : Class_Name;
begin
if Index > Filter'Last then
return True;
else
Filter_Class := Filter (Index).Class;
case Filter (Index).Kind is
when Find =>
for Element in 1 .. Working_Memory.Last loop
if Working_Memory.Match
(Element, Against => Filter (Index)) then
if Recursive_Search (Index + 1) then
Result (Index) := Element;
return True;
end if;
end if;
end loop;
when Check_No =>
for Element in 1 .. Working_Memory.Last loop
if Working_Memory.Match
(Element, Against => Filter (Index)) then
return False;
end if;
end loop;
if Recursive_Search (Index + 1) then
Result (Index) := Null_Object;
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 Make_Empty is
begin
Working_Memory.Make_Empty;
end Make_Empty;
procedure Put (The_Patterns : Patterns;
Where : Output_Stream.Object :=
Output_Stream.Standard_Output) is
First : Boolean := True;
use Output_Stream;
begin
for I in The_Patterns'Range loop
if not First then
Put_Line (", ", Where);
else
First := False;
end if;
Put ("Slot" & Slot_Names'Image (I) & " => ", Where);
Condition_Put (The_Condition => The_Patterns (I), Where => Where);
end loop;
end Put;
procedure Put (The_Query : Query; Where : Output_Stream.Object) is
use Output_Stream;
begin
case The_Query.Kind is
when Find =>
Put_Line
("Find_" & Image (The_Query.Class) & "_Such_As'(", Where);
when Check_No =>
Put_Line
("Check_No_" & Image (The_Query.Class) & "_Has'(", Where);
end case;
Indent_Right (Where);
Put (The_Patterns => The_Query.Value, Where => Where);
Indent_Left (Where);
Put_Line (")", Where);
end Put;
procedure Put (The_Queries : Queries; Where : Output_Stream.Object) is
use Output_Stream;
begin
Put ("Premiss'(", Where);
Indent_Right (Where);
for I in The_Queries'Range loop
Put (The_Queries (I), Where);
New_Line (Where);
end loop;
Indent_Left (Where);
Put_Line (")", Where);
end Put;
procedure Put (The_Fact : Object; Where : Output_Stream.Object) is
begin
Working_Memory.Put (The_Fact, Where);
end Put;
procedure Put (The_Collection : Collection; Where : Output_Stream.Object) is
use Output_Stream;
begin
Put_Line ("Fact_collection'(", Where);
Indent_Right (Where);
if The_Collection'Length /= 0 then
for I in The_Collection'Range loop
Put (The_Collection (I), Where);
end loop;
end if;
Indent_Left (Where);
New_Line (Where);
Put_Line (")", Where);
end Put;
procedure Put (Where : Output_Stream.Object) is
begin
Working_Memory.Put (Where);
end Put;
package body Working_Memory is separate;
package body Generic_Fact is separate;
end Generic_Fact_Base;
nblk1=10
nid=3
hdr6=12
[0x00] rec0=1d rec1=00 rec2=01 rec3=03c
[0x01] rec0=20 rec1=00 rec2=0e rec3=008
[0x02] rec0=15 rec1=00 rec2=0c rec3=006
[0x03] rec0=1b rec1=00 rec2=0a rec3=044
[0x04] rec0=02 rec1=00 rec2=06 rec3=000
[0x05] rec0=1b rec1=00 rec2=04 rec3=074
[0x06] rec0=05 rec1=00 rec2=0b rec3=01e
[0x07] rec0=1f rec1=00 rec2=07 rec3=038
[0x08] rec0=0e rec1=00 rec2=05 rec3=000
[0x09] rec0=1b rec1=00 rec2=0e rec3=044
[0x0a] rec0=20 rec1=00 rec2=03 rec3=008
[0x0b] rec0=05 rec1=00 rec2=02 rec3=000
[0x0c] rec0=05 rec1=00 rec2=02 rec3=000
[0x0d] rec0=05 rec1=00 rec2=02 rec3=000
[0x0e] rec0=00 rec1=00 rec2=00 rec3=019
[0x0f] rec0=00 rec1=00 rec2=00 rec3=000
tail 0x21523da4c83ef70c52d00 0x42a00088462063c03
Free Block Chain:
0x3: 0000 00 02 02 69 80 01 3b 01 00 0f 20 20 20 20 20 20 ┆ i ; ┆
0x2: 0000 00 10 00 78 80 1a 20 20 20 20 50 75 74 5f 4c 69 ┆ x Put_Li┆
0x10: 0000 00 0d 01 31 80 36 20 52 65 63 75 72 73 69 76 65 ┆ 1 6 Recursive┆
0xd: 0000 00 08 03 fb 80 01 6e 01 00 30 20 20 20 20 20 20 ┆ n 0 ┆
0x8: 0000 00 09 03 fc 80 02 2d 2d 02 00 21 20 20 20 20 65 ┆ -- ! e┆
0x9: 0000 00 0f 03 fc 80 18 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ┆ ----------┆
0xf: 0000 00 00 02 04 80 09 72 69 6e 67 2e 22 3d 22 3b 09 ┆ ring."="; ┆