|
|
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 - metrics - downloadIndex: B T
Length: 25970 (0x6572)
Types: TextFile
Names: »B«
└─⟦149519bd4⟧ Bits:30000546 8mm tape, Rational 1000, !projects 93-07-13
└─⟦124ff5788⟧ »DATA«
└─⟦this⟧
└─⟦a7d1ea751⟧ Bits:30000550 8mm tape, Rational 1000, !users!projects 94_04_11
└─⟦129cab021⟧ »DATA«
└─⟦this⟧
└─⟦f64eaa120⟧ Bits:30000752 8mm tape, Rational 1000, !projects 93 02 16
└─⟦6f12a12be⟧ »DATA«
└─⟦this⟧
└─⟦2f6cfab89⟧ Bits:30000547 8mm tape, Rational 1000, !projects 94-01-04
└─⟦d65440be7⟧ »DATA«
└─⟦this⟧
with Text_Io, Dyn;
procedure Expert is
------------------------------------------------------------------------------
--GENERAL INFORMATION:
--
-- EXPERT is a backward chaining or goal driven expert system. It is based on
--two articles, first Sept 1981 BYTE (Duda and Gaschnig)
--published the expert system in BASIC
--skirting the use of recursion, second Jan/Feb 85 issue of
--JOURNAL OF PASCAL,ADA, & MODULA-2 (Darrell Morgeson)
--published in Modula-2 with recursion
--implemented. The listing had one logic error which caused pointer
--explosion on the last hypothesis in the GETRULE routine. This
--implementation follows the MODULA-2 design completely and
--was not designed from the ground up in Ada. Many improvements would
--be possible if more time permitted my working on this.
--AUTHOR: (sort of, translator) Alan McDonley (303) 593-7528 (home phone)
--DATE: 11 SEPT 85
--
------------------------------------------------------------------------------
--INPUTS:
--
-- Expert requires an expert rulebase. The rule base consists of the following
-- items in the particular format:
--
--DATABASE NAME (thrown away by program)
--HYPOTHESIS 1 (Must fit on one line, any characters including spaces legal)
--.
--.
--HYPOTHESIS n
-- (blank line to signify end of all hypothesis)
--IF,ANTECEDENT 1[,ANTECEDENT n][,CONCLUSION n],THEN,CONCLUSION 1,
--IF,.....,CONCLUSION n, (must be a comma after last conclusion)
--
-- If you put spaces after comma be careful to note that the space becomes
-- part of symbol and that the symbols "IF" and "THEN" may not have a space
-- preceding them as they are defined by EXPERT without the spaces.
--
-- Each Hypothesis must appear as a conclusion at least once, program will
-- check for this and halt cleanly if not true.
--
-- Rules may cross line boundry at any comma (start of a symbol). See Animals
-- rulebase for example.
--
-- Blank lines may be inserted after any comma (useful to separate long rules)
------------------------------------------------------------------------------
--EXAMPLE RULE BASES: (remove -- from each line to use)
--THIS IS AN ANIMAL RULE SET
--IS ALBATROSS
--IS PENGUIN
--IS OSTRICH
--IS ZEBRA
--IS GIRAFFE
--IS TIGER
--IS CHEETAH
--IF,HAS HAIR,THEN,IS MAMMAL,
--IF,GIVES MILK,THEN,IS MAMMAL,
--IF,HAS FEATHERS,THEN,IS BIRD,
--IF,FLIES,LAYS EGGS,THEN,IS BIRD,
--IF,EATS MEAT,THEN,IS CARNIVORE,
--IF,HAS POINTED TEETH,HAS CLAWS,HAS FORWARD EYES,THEN,IS CARNIVORE,
--IF,IS MAMMAL,HAS HOOFS,THEN,IS UNGULATE,
--IF,IS MAMMAL,CHEWS CUD,THEN,IS UNGULATE,
--IF,IS MAMMAL,IS CARNIVORE,HAS TAWNY COLOR,HAS BLACK STRIPES,THEN,IS TIGER,
--IF,IS MAMMAL,IS CARNIVORE,HAS TAWNY COLOR,HAS DARK SPOTS,
--THEN,IS CHEETAH,
--IF,IS UNGULATE,HAS LONG NECK,HAS LONG LEGS,HAS DARK SPOTS,
--THEN,IS GIRAFFE,
--IF,IS UNGULATE,HAS BLACK STRIPES,THEN,IS ZEBRA,
--IF,IS BIRD,DOES NOT FLY,HAS LONG NECK,IS BLACK AND WHITE,
--THEN,IS OSTRICH,
--IF,IS BIRD,DOES NOT FLY,SWIMS,IS BLACK AND WHITE,THEN,IS PENGUIN,
--IF,IS BIRD,FLIES WELL,THEN,IS ALBATROSS,
------------------------------------------------------------------------------
--EXAMPLE RULE BASE: (remove -- from each line to use)
--FUSION DATABASE FROM "THE BUTTON" BY DANIEL FORD
--DEFINITE SS-18 LAUNCH
--DEFINITE SOFT TARGET ATTACK
--IF,DSP EAST REPORTS,SOUTH CENTRAL SIBERIA LAUNCH,THEN,PROBABLE SS-18 LAUNCH,
--IF,DSP EAST REPORTS,MONGOLIAN BORDER LAUNCH,THEN,PROBABLE SS-11 LAUNCH,
--IF,PROBABLE SS-11 LAUNCH,THEN,PROBABLE SOFT TARGET ATTACK,
--IF,DEFINITE SS-11 LAUNCH,THEN,DEFINITE SOFT TARGET ATTACK,
--IF,PROBABLE SS-18 LAUNCH,ALASKAN RADAR SHOWS INCOMING ICBM,THEN,
--DEFINITE SS-18 LAUNCH,
--IF,PROBABLE SS-11 LAUNCH,FYLINGDALES MOOR-ENGLAND RADAR SHOWS INCOMING ICBM,
--THEN,DEFINITE SS-11 LAUNCH,
------------------------------------------------------------------------------
--OPERATION:
--
--To use compile MYDYN.ADA, then EXPERT.ADA, then link EXPERT.
--RUN EXPERT
--enter name of rulebase
--answer questions
------------------------------------------------------------------------------
--THEORY OF OPERATION:
--
--EXPERT loads the rulebase, creating pointers to each symbol, rule and
--hypothesis. EXPERT attempts to prove the last hypothesis first. To prove
--an hypothesis, the rules are searched for one having the hypothesis as a
--conclusion, when found, VERIFIED attempts to verify that rule by calling
--VERIFIED recursively to verify each antecedent of that rule. When all
--antecedents of a rule are verified true, EXPERT deduces the rule is true,
--If the conclusion of the rule is an hypothesis then execution stops.
--If any antecedent of a rule is false, EXPERT searches for another rule
--to prove the conclusion.
--EXAMPLE:
--for rulebase:
--TEST RULEBASE
--HYPOTHESIS 1
--
--IF,ANTECEDENT 1,THEN,CONCLUSION 1,
--IF,ANTECEDENT 2,CONCLUSION 1,THEN,HYPOTHESIS 1,
--
--EXPERT begins by looking for a rule with HYPOTHESIS 1 as its conclusion and
--finds rule 2. To verify rule 2 it attempts to verify the first antecedent
--which is ANTECEDENT 2. ANTECEDENT 2 does not appear as a conclusion in any
--other rule and so the user is asked to verify (Is this true? ANTECEDENT 2)
--the antecedent. The user may respond Y or y for YES, N or n for NO, or
--E or e for EXPLAIN. Requesting an explanation at this point will print:
--
--TRYING TO PROVE RULE 2:
--IF ANTECEDENT 2
-- CONCLUSION 1
--THEN
-- HYPOTHESIS 1
--
--Is this true? ANTECEDENT 2?
--
--If the user responds yes, then the symbol value is set to true and the
--next antecedent of rule 2 ( CONCLUSION 1) is verified. To verify
--CONCLUSION 1 the rule set is searched for a rule with CONCLUSION 1 as the
--conclusion. Rule 1 is found. So the first antecedent of rule 1 is verified
--by searching the ruleset for a rule with ANTECEDENT 1 as the conclusion. None
--is found, so the user is asked to verify it. If the user answers yes (true)
-- then EXPERT deduces rule 1 (CONCLUSION 1) to be true, and subsequently
-- deduces rule 2 (HYPOTHESIS 1) to be true since both antecedents (ANTECEDENT 1
-- and CONCLUSION 1) are true. Execution stops after displaying the deductions.
-- Backward chaining or goal driven chaining is the process of starting with
-- a hypothesis and finding ways to prove it true, where as forward chaining
-- would start with a known antecedent, then another antecedent (possibly
-- unrelated to the hypothesis that the first antecedent is part of)
-- and prove one or more hypothesis.
--
-- BACKWARD FORWARD
--
-- goal false antecedent
-- | |
-- false antecedent | antecedent
-- | | | \
-- new goal no goal antecedent \
-- | | other goals
-- antecedent proven goal
-- |
-- antecedent
-- |
-- proven goal
--
-- Each has a particular purpose and sometimes mixing the two is the best.
-- Forward chaining would work well on parallel processors, and where random
-- data is coming in.
-- Backward Chaining works well were requested data or queued systems are
-- involved.
--
-- Symbols are stored in a binary tree with no duplicate symbols. Rules are
-- stored as a list of pointers to the symbols belonging to the rule.
-- Symbol values begin as U or Unknown and gradually are proven (T or true) or
-- disproved (F or False).
--
-- Current limits of the array of symbol pointers and the array of rule pointers
-- are set to 100 rules containing no more than 250 symbols. These of course
-- are easily modified.
--
------------------------------------------------------------------------------
------------------------------------------------------------------------------
use Text_Io, Dyn;
package Integer_Io is new Text_Io.Integer_Io (Integer);
Maxstrgsrules : constant := 250;
Maxrules : constant := 100;
subtype Rulrange is Integer range 0 .. Maxrules;
subtype Ptrrange is Integer range 1 .. Maxstrgsrules;
type Hypttype;
type Hyptptr is access Hypttype;
type Hypttype is
record
Symbol : Dyn_String;
Next : Hyptptr;
end record;
type Symboltype;
type Symbolptr is access Symboltype;
type Symboltype is
record
Symbol : Dyn_String;
Value : Character;
Left, Right : Symbolptr;
end record;
Hypthdr, Hypttail : Hyptptr;
Rules : array (Ptrrange'First .. Ptrrange'Last) of Symbolptr;
Numrules : Rulrange;
Ruleptr : array (Rulrange'First .. Rulrange'Last) of Ptrrange;
Infile : Text_Io.File_Type;
In_File_Name : Dyn_String;
Response : Dyn_String;
Response_Len : Natural;
function Comparestr (Str1, Str2 : in Dyn_String) return Integer is
-- If two dynamic strings are of same length and contents return 0,
-- else order the strings
begin
if Str (Str1) = Str (Str2) then
return (0);
elsif Str (Str1) < Str (Str2) then
return (-1);
else
return (1);
end if;
end Comparestr;
procedure Getrules is
--GET HYPOTHESIS and RULES from rulebase
Numstrgsrules : Ptrrange; --current number of symbols in rules
Root : Symbolptr; -- root of symbol binary tree
Strg : Dyn_String;
Sstrg : Dyn_String;
procedure Makehyptlist (Symbol : Dyn_String) is
--create a circular list of hypothesis strings
Hypt : Hyptptr;
begin
Hypt := new Hypttype;
if Hypthdr = null then
Hypthdr := Hypt;
Hypttail := Hypt;
else
Hypttail.Next := Hypt;
Hypttail := Hypt;
end if;
Hypt.Symbol := Symbol;
Hypt.Next := Hypthdr;
end Makehyptlist;
procedure Search (Curptr, Prevptr : in out Symbolptr;
Symbol : Dyn_String;
Found : in out Boolean) is
-- searches the binary tree containing the rule symbols to see if the
-- symbol already exists. If not then prevptr points to the node at
-- which the next symbol will be inserted
begin
Found := False;
while not (Found) and (Curptr /= null) loop
Prevptr := Curptr;
if Comparestr (Symbol, Curptr.Symbol) = 0 then
Found := True;
elsif Comparestr (Symbol, Curptr.Symbol) < 0 then
Curptr := Curptr.Left;
else
Curptr := Curptr.Right;
end if;
end loop;
end Search;
procedure Makesymbol (Ptr : in out Symbolptr; Strg : Dyn_String) is
--creates a symbol node, fills the node with the string (antecedent or
--conclusion), then sets symbol value to unknown, and links the symbol into
-- the binary symbol tree.
Newptr : Symbolptr;
begin
Newptr := new Symboltype;
Newptr.Symbol := Strg;
Newptr.Value := 'U';
Newptr.Left := null;
Newptr.Right := null;
Ptr := Newptr;
end Makesymbol;
procedure Loadrules (Strg : Dyn_String) is
-- parses a rule extracting symbols and puting them in rule tree
Local_Strg : Dyn_String := Strg;
Curptr, Prevptr : Symbolptr;
Symbol : Dyn_String;
Found : Boolean := False;
Endsymbol : Natural;
begin
while Length (Local_Strg) > 0 loop
Endsymbol := Dyn.Index
(Local_Strg, D_String (','), 1); -- find comma
if Endsymbol > 0 then
Symbol := Dyn.Substring
(Local_Strg, 1, Endsymbol -
1); --get
--symbol,leave comma
if Dyn.Length (Local_Strg) >
Endsymbol then --if more to string
Local_Strg := Dyn.Substring (Local_Strg, Endsymbol + 1,
0);--remove symbol
else
Local_Strg := Dyn.D_String (""); --end of string
end if;
if Root = null then
-- begins the binary tree
Makesymbol (Root, Symbol);
Curptr := Root;
else
Curptr := Root;
Search (Curptr, Prevptr, Symbol, Found);
if not Found then
Makesymbol (Curptr, Symbol);
if Comparestr (Prevptr.Symbol, Symbol) > 0 then
Prevptr.Left := Curptr;
else
Prevptr.Right := Curptr;
end if;
end if;
end if;
if Comparestr (Curptr.Symbol, D_String ("IF")) = 0 then
Ruleptr (Numrules) :=
Numstrgsrules; -- put first antecedents symbol
-- number as start of rule
Numrules := Numrules + 1;
end if;
Rules (Numstrgsrules) := Curptr;
Numstrgsrules := Numstrgsrules + 1;
end if;
end loop;
end Loadrules;
begin --GETRULES
Hypthdr := null;
Hypttail := null;
Text_Io.Put ("ENTER NAME OF RULE BASE: ");
Dyn.Get_Line (In_File_Name, Response_Len);
Dyn.Open (Infile, Text_Io.In_File, In_File_Name);
Dyn.Get_Line (Infile, Strg, Response_Len); -- dispose of header line
loop
Dyn.Get_Line (Infile, Sstrg, Response_Len); --read first hypothesis
if Response_Len = 0 then
exit;
end if;
Makehyptlist (Sstrg);
end loop;
Numrules := 1;
Numstrgsrules := 1;
Root := null;
loop
Dyn.Get_Line (Infile, Strg, Response_Len); -- read a rule line
if Response_Len > 0 then -- skip blank lines between rules if any
Loadrules (Strg);
end if;
if Text_Io.End_Of_File (Infile) then
exit;
end if; -- if no more rules exit
end loop;
Ruleptr (Numrules) := Numstrgsrules; --set end of list mark
Numrules := Numrules - 1;
Text_Io.Close (Infile);
end Getrules;
function Verified (Tgtstrg : Dyn_String;
Newstrptr : Ptrrange;
Startrule, Currulnum : Rulrange) return Boolean is
-- Attempts to verify a particular symbol (antecedent) as true or false
-- recurses if antecedent is a conclusion in another rule attempting to
-- prove each antecedent for the conclusion.
Newstr : Dyn_String;
Nomorestrgs,
Found : Boolean;
-- need local copies for sending to procedures with out parms
New_Strptr : Ptrrange := Newstrptr; --symbol number
Tgtstring : Dyn_String := Tgtstrg; --symbol string
Startrul : Rulrange :=
Startrule; --first rule to look in for the symbol
Currulenum : Rulrange := Currulnum; --current rule that working on
function Userverifies (Tgtstrg : Dyn_String;
Currulnum : Rulrange;
Newstrptr : Ptrrange) return Boolean is
--ASKS USER ABOUT THE TGTSTRG AND RECORDS HIS ANSWER when antecedent does
--not appear as a conclusion in any other rule.
Ch : Character;
Validchars : Dyn_String := D_String ("YyNnEe");
I, J : Natural;
begin
loop
loop
Text_Io.Put ("Is this true? ");
Dyn.Put (Tgtstrg);
Text_Io.Put (" ?? ");
Text_Io.Get (Ch);
exit when (Dyn.Index (Validchars, D_String (Ch), 1)) > 0;
end loop;
case Ch is
when 'Y' | 'y' =>
Rules (Newstrptr).Value := 'T';
return True;
when 'N' | 'n' =>
Rules (Newstrptr).Value := 'F';
return False;
when 'E' | 'e' =>
Text_Io.New_Line (2);
Text_Io.Put ("TRYING TO USE RULE");
Integer_Io.Put (Currulnum);
Text_Io.New_Line;
I := Newstrptr;
loop
I := I - 1;
exit when
Comparestr (Rules (I).Symbol, D_String ("IF")) =
0;
end loop;
I := I + 1;
if I /= Newstrptr then
Text_Io.New_Line (2);
Text_Io.Put ("I already know that :");
Text_Io.New_Line;
J := I;
loop
Text_Io.Put (" ");
Dyn.Put (Rules (J).Symbol);
Text_Io.New_Line;
exit when J = (Newstrptr - 1);
J := J + 1;
end loop;
end if;
Text_Io.New_Line (2);
Text_Io.Put ("IF");
Text_Io.New_Line;
I := Newstrptr;
loop
Text_Io.Put (" ");
Dyn.Put (Rules (I).Symbol);
Text_Io.New_Line;
I := I + 1;
exit when
Comparestr
(Rules (I).Symbol, D_String ("THEN")) = 0;
end loop;
Text_Io.Put ("THEN");
Text_Io.New_Line;
Text_Io.Put (" ");
Dyn.Put (Rules (I + 1).Symbol);
Text_Io.New_Line (2);
when others =>
null;
end case;
end loop;
end Userverifies;
procedure Getrule (Startrule : in out Rulrange;
Tgtstrg : Dyn_String;
Found : out Boolean) is
-- Finds the rule in which the tgtstrg appears as a consequent;
-- begins search at the value of startrule; makes no change to
-- startrule unless a new rule is found
Rul : Rulrange;
Strptr : Ptrrange;
Strg : Dyn_String;
begin --Gets relevant rules for tgtstrg if any; Puts result
-- in currulnum
Rul := Startrule + 1;
loop
if Rul >
Numrules then --This line and three following put at top
Found :=
False; --of loop to prevent overrunning structure
exit; --when startrule is passed in as last rule
end if; --of rulebase. Alan McDonley
Strptr := Ruleptr (Rul + 1) - 1;
Strg := Rules (Strptr).Symbol;
if Comparestr (Strg, Tgtstrg) = 0 then --if found
Found := True;
Startrule := Rul;
exit;
end if;
Rul := Rul + 1;
--Location of test in journal listing
end loop;
end Getrule;
procedure Getstring (Newstr : in out Dyn_String;
Newstrptr : Ptrrange;
Nomorestrgs : out Boolean;
Currulnum : Rulrange) is
-- Works in the current rule to find the next antecedent;
-- if no more antecedents, sets rule consequent to 'T'rue
-- and nomrestrgs to true;
begin
if Comparestr (Rules (Newstrptr).Symbol, D_String ("THEN")) = 0 then
-- no more antecedents, confirm consequent as true
Rules (Newstrptr + 1).Value := 'T';
Nomorestrgs := True;
Text_Io.New_Line (2);
Text_Io.Put ("Rule");
Integer_Io.Put (Currulnum);
Text_Io.Put (" deduces ");
Dyn.Put (Rules (Newstrptr + 1).Symbol);
Text_Io.New_Line (2);
else -- Set newstr to the next antecedent
Newstr := Rules (Newstrptr).Symbol;
Nomorestrgs := False;
end if;
end Getstring;
begin --VERIFIED
-- Check to see if value is T or F
if Rules (New_Strptr).Value = 'T' then
return True;
elsif Rules (New_Strptr).Value = 'F' then
return False;
end if;
-- Find a rule with tgtstring as consequent; if there are none,
-- must ask the user about the veracity of the antecedent;
Getrule (Startrul, Tgtstring, Found);
if not Found then
if Userverifies (Tgtstring, Currulenum, New_Strptr) then
return True;
else
return False;
end if;
else
Currulenum := Startrul;
loop --1
New_Strptr := Ruleptr (Currulenum) + 1; -- first antecedent
Getstring (Newstr, New_Strptr, Nomorestrgs, Currulenum);
loop --2
-- Stay with this rule until all antecedents have been
-- confirmed as true; exit the loop if one is false
if Verified (Newstr, New_Strptr, 0, Currulenum) then
New_Strptr := New_Strptr + 1;
Getstring (Newstr, New_Strptr, Nomorestrgs, Currulenum);
if Nomorestrgs then
return True;
end if;
else
exit;
end if;
end loop; --2
Getrule (Currulenum, Tgtstring, Found);
if not Found then
-- Last call to VERIFIED is FLSE; RECORD TGTSTRING
-- as 'F'alse and return from verified
Rules (New_Strptr).Value := 'F';
return False;
end if;
end loop; --1
end if;
end Verified;
procedure Diagnose is
-- Called to make a reccommendation
-- first checks to be sure rulebase is consistant, then procedes to verify
-- the last hypothesis in the rulebase.
-- If not proven moves to next hypothesis from last,etc. till first is
-- disproved or an hypothesis is proven.
Hypothesis : Dyn_String;
Hypt : Hyptptr;
procedure Ckhypt (Hypothesis : Dyn_String) is
Rule : Rulrange;
Strptr : Ptrrange;
Strg : Dyn_String;
Bad_Rulebase : exception;
-- Checks to insure all hypothesis have applicable rules
-- (some rule contains hypothesis as conclusion)
begin
Rule := 1;
loop
Strptr := Ruleptr (Rule + 1) - 1; --Consequent of rule;
Strg := Rules (Strptr).Symbol;
if Comparestr (Strg, Hypothesis) = 0 then
exit;
end if;
Rule := Rule + 1;
if Rule > Numrules then
Text_Io.New_Line;
Dyn.Put (Hypothesis);
Text_Io.Put (" not in rule set ");
raise Bad_Rulebase;
-- hypothesis cannot be confirmed with rule base so halt program
end if;
end loop;
end Ckhypt;
--Go thru the hypothesis one at a time until one is confirmed
-- as true or all are false
begin -- DIAGNOSE
Text_Io.New_Line;
Text_Io.Put ("I will use my ");
Integer_Io.Put (Numrules);
Text_Io.Put (" rules to prove one of the following:");
Text_Io.New_Line (2);
Hypt := Hypthdr;
loop
Ckhypt (Hypt.Symbol);
Dyn.Put (Hypt.Symbol);
Text_Io.New_Line;
Hypt := Hypt.Next;
exit when Hypt = Hypthdr;
end loop;
Text_Io.New_Line (2);
Text_Io.Put ("Please answer with (Y)es, (N)o, or (E)xplain ");
Text_Io.New_Line (2);
Hypt := Hypthdr;
loop
Hypothesis := Hypt.Symbol;
if Verified (Hypothesis, 1, 0, 1) then
Text_Io.Put ("RECOMMENDATION: ");
Dyn.Put (Hypothesis);
Text_Io.New_Line;
exit;
end if;
Hypt := Hypt.Next;
if Hypt = Hypthdr then
Text_Io.Put ("NO RECOMMENDATION CAN BE CONFIRMED");
exit;
end if;
end loop;
end Diagnose;
begin -- EXPERT main block
for I in 1 .. 10 loop
Text_Io.New_Line;
end loop;
Text_Io.Put_Line ("Ada EXPERT SYSTEM");
Getrules;
Diagnose;
end Expert;