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: 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;