Programmer's ROM - The Computer Language Library/programmersrom.iso/ada/ai/expert.ada

Text File | 1988-05-03 | 35.3 KB | 1,049 lines

-------- SIMTEL20 Ada Software Repository Prologue ------------
--                                                           -*
-- Unit name    : EXPERT
-- Version      : 1.0
-- Author       : Alan McDonley
--              : Texas Instruments
--              :
--              :
-- DDN Address  : N/A
-- Copyright    : (c)
-- Date created :  11 Sep 85
-- Release date :  3 Dec 85
-- Last update  :  3 Dec 85
-- Machine/System Compiled/Run on : VAX 11/785, VMS 4.1, DEC Ada
--                                                           -*
---------------------------------------------------------------
--                                                           -*
-- Keywords     :  Expert System, Artificial Intelligence
----------------:
--
-- Abstract     :
----------------:
-- 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.
--                                                           -*
------------------ Revision history ---------------------------
--                                                           -*
-- DATE         VERSION    AUTHOR                  HISTORY
-- 12/3/85      1.0     Alan McDonley           Initial Release
--                                                           -*
------------------ Distribution and Copyright -----------------
--                                                           -*
-- This prologue must be included in all copies of this software.
--
-- This software is released to the Ada community.
-- This software is released to the Public Domain (note:
--   software released to the Public Domain is not subject
--   to copyright protection).
-- Restrictions on use or distribution:  NONE
--                                                           -*
------------------ Disclaimer ---------------------------------
--                                                           -*
-- This software and its documentation are provided "AS IS" and
-- without any expressed or implied warranties whatsoever.
-- No warranties as to performance, merchantability, or fitness
-- for a particular purpose exist.
--
-- Because of the diversity of conditions and hardware under
-- which this software may be used, no warranty of fitness for
-- a particular purpose is offered.  The user is advised to
-- test the software thoroughly before relying on it.  The user
-- must assume the entire risk and liability of using this
-- software.
--
-- In no event shall any person or organization of people be
-- held responsible for any direct, indirect, consequential
-- or inconsequential damages or lost profits.
--                                                           -*
-------------------END-PROLOGUE--------------------------------

with text_io; use text_io;
package DYN is

------------------------------------------------------------------------------
--  This is a package of several string manipulation functions based on     --
-- a built-in dynamic string type DYN_STRING.  It is an adaptation and      --
-- extension of the package proposed by Sylvan Rubin of Ford Aerospace and  --
-- Communications Corporation in the Nov/Dec 1984 issue of the Journal of   --
-- Pascal, Ada and Modula-2.  Some new functions have been added, the       --
-- SUBSTRING function has been modified to permit it to return the right    --
-- part of a string if the third parameter is permitted to default, and     --
-- much of the body code has been rewritten.                                --
------------------------------------------------------------------------------
-- R.G. Cleaveland 07 December 1984:                                        --
--  Implementation initially with the Telesoft Ada version                  --
-- This required definition of the DYN_STRING type without use of a         --
-- discriminant; an arbitrary maximum string length was chosen.  This       --
-- should be changed when an improved compiler is available.                --
------------------------------------------------------------------------------
-- Richard Powers 03 January 1985:                                          --
-- changed to be used with a real compiler.                                 --
-- Some of the routines removed by my whim.                                 --
------------------------------------------------------------------------------
-- Richard Powers 26 January 1985:
-- Added UPPER_CASE function
------------------------------------------------------------------------------
-- Alan McDonley 28 AUG 1985;
-- Added overload for GET_LINE, PUT, OPEN
------------------------------------------------------------------------------

type DYN_STRING is private;

STRING_TOO_SHORT: exception;

function D_STRING(CHAR: character)  return DYN_STRING;
        -- Creates a one-byte dynamic string of contents CHAR.

function D_STRING(STR : string   )  return DYN_STRING;
        -- Creates a dynamic string of contents STR.

function D_STRING(INT : in INTEGER ) return DYN_STRING;
        -- Creates a dynamic string of contents INT.

-- The following four functions convert from dynamic strings to the
-- desired representation:
function CHAR(DSTR: DYN_STRING) return character;
function STR (DSTR: DYN_STRING) return string;
function INT (DSTR: DYN_STRING) return integer;
function FLT (DSTR: DYN_STRING) return float;

function LENGTH(DSTR: DYN_STRING) return natural;
function "<" (DS1, DS2: DYN_STRING) return boolean;
function "&" (DS1, DS2: DYN_STRING) return DYN_STRING;

function SUBSTRING (DSTR: DYN_STRING;      -- Returns a subpart of this string
                    START  : natural;      -- starting at this position
                    LENGTH : natural := 0) -- and of this length.
                return DYN_STRING;
                -- if LENGTH is zero or not specified, the remainder of the
                -- string is returned (eg the "RIGHT" function).

function INDEX (SOURCE_STRING,              --If this string contains
                PATTERN_STRING: DYN_STRING; --this string starting at or AFTER
                START_POS: integer)         --this position, the position of
                return integer;             --such start is returned.
                -- If the string lengths prohibit the search -1 is returned.
                -- If no match was found, 0 is returned.
                -- (This is like the INSTR function of BASIC).

function RINDEX (SOURCE_STRING,             --If this string contains
                PATTERN_STRING: DYN_STRING; --this string starting at or BEFORE
                START_POS: integer)         --this position, the position of
                return integer;             --such start is returned.
                -- If the string lengths prohibit the search -1 is returned.
                -- If no match was found, 0 is returned.

function UPPER_CASE(STRG : in DYN.DYN_STRING) return STRING;
                -- Return the input string in upper case


Procedure GET_LINE (filename: in text_io.file_type;
                    item    : out dyn.dyn_string;
                    last    : out natural) ;

Procedure GET_LINE (item    : out dyn.dyn_string;
                    last    : out natural) ;

Procedure PUT (filename: in text_io.file_type;
               item    : in dyn.dyn_string);

Procedure PUT (item    : in dyn.dyn_string);

Procedure OPEN (filename : in out text_io.file_type;
                mode : in  text_io.file_mode;
                filenm   : in  dyn_string);

private

        type STRING_CONTENTS(SIZE : natural := 0) is
           record
               DATA: string(1..SIZE);
           end record;

        type DYN_STRING is access STRING_CONTENTS;

end DYN;

----------------------------------------------------------------------------

package body DYN is

package MY_INTEGER_IO is new INTEGER_IO(INTEGER);

package MY_FLOAT_IO is new FLOAT_IO(FLOAT);

function "&" (DS1, DS2: DYN_STRING) return DYN_STRING is
        DS3 : DYN_STRING;
    begin
        DS3 := new STRING_CONTENTS(DS1.SIZE+DS2.SIZE);
        DS3.DATA(1..DS3.SIZE):=   DS1.DATA(1..DS1.SIZE)
                                & DS2.DATA(1..DS2.SIZE);
        return DS3;
    end "&";

function D_STRING(CHAR: character)  return DYN_STRING is
        DS : DYN_STRING;
    begin
        DS := new STRING_CONTENTS(SIZE=>1);
        DS.DATA(1) := CHAR;
        return DS;
    end D_STRING;

function D_STRING(STR : string   )  return DYN_STRING is
        DS : DYN_STRING;
    begin
        DS := new STRING_CONTENTS(SIZE => STR'length);
        DS.DATA(1..DS.SIZE)  := STR;
        return DS;
    end D_STRING;

function D_STRING( INT : in INTEGER ) return DYN_STRING is
        DS : DYN_STRING;
    begin
        DS:=D_STRING(integer'image(int));
        return DS;
    end D_STRING;

function CHAR(DSTR: DYN_STRING) return character is
    begin
        return DSTR.DATA(1);
    end CHAR;

function STR (DSTR: DYN_STRING) return string is
    begin
        return DSTR.DATA(1..DSTR.SIZE);
    end STR;

function INT (DSTR: DYN_STRING) return integer is
        V: integer;
        L: positive;
    begin
        MY_INTEGER_IO.get(STR(DSTR),V,L);
        return V;
    end INT;

function FLT (DSTR: DYN_STRING) return float is
        V: float;
        L: positive;
    begin
        MY_FLOAT_IO.get(STR(DSTR),V,L);
        return V;
    end FLT;

function LENGTH(DSTR: DYN_STRING) return natural is
    begin
        return DSTR.SIZE;
    end LENGTH;

function "<" (DS1, DS2: DYN_STRING) return boolean is
    begin
        if STR(DS1) < STR(DS2)
        then return (TRUE);
        else return (FALSE);
        end if;
    end "<";

function SUBSTRING (DSTR: DYN_STRING;
                    START  : natural;
                    LENGTH : natural := 0)
                                           return DYN_STRING is
        DS: DYN_STRING;
        L : natural := LENGTH;
    begin
        if (START < 1) or (START > DSTR.SIZE)
        then raise CONSTRAINT_ERROR;
        else if L = 0
             then L := DSTR.SIZE-START+1;
             end if;
             if DSTR.SIZE < START + L - 1
             then  raise STRING_TOO_SHORT;
             else
                   DS := new STRING_CONTENTS(L);
                   DS.DATA(1..L) := DSTR.DATA(START..START+L-1);
                   return DS;
             end if;
         end if;
    end SUBSTRING;

function INDEX(SOURCE_STRING, PATTERN_STRING: DYN_STRING;
                        START_POS: integer) return integer is
        NO_MATCH        : integer := 0;
        NO_FIT          : integer := -1;
    begin
        if SOURCE_STRING.SIZE < PATTERN_STRING.SIZE + START_POS - 1
        or START_POS < 1
        then return NO_FIT;
        end if;
        for I in START_POS..SOURCE_STRING.SIZE-PATTERN_STRING.SIZE+1 loop
            if SOURCE_STRING.DATA(I..I+PATTERN_STRING.SIZE-1)
               = PATTERN_STRING.DATA(1..PATTERN_STRING.SIZE)
            then return I;
            end if;
        end loop;
        return NO_MATCH;
    end INDEX;

function RINDEX(SOURCE_STRING, PATTERN_STRING: DYN_STRING;
                        START_POS: integer) return integer is
        NO_MATCH        : integer := 0;
        NO_FIT          : integer := -1;
    begin
        if SOURCE_STRING.SIZE < PATTERN_STRING.SIZE + START_POS - 1
        or START_POS < 1
        then return NO_FIT;
        end if;
        for I in reverse 1..START_POS loop
            if SOURCE_STRING.DATA(I..I+PATTERN_STRING.SIZE-1)
               = PATTERN_STRING.DATA(1..PATTERN_STRING.SIZE)
            then return I;
            end if;
        end loop;
        return NO_MATCH;
    end RINDEX;

    function UPPER_CASE(STRG : in DYN.DYN_STRING) return STRING is
        ANSWER : STRING(1..LENGTH(STRG));
    begin
        ANSWER := STR(STRG);
        for I in 1..LENGTH(STRG) loop
            if (ANSWER(I) >= 'a') and (ANSWER(I) <= 'z') then
                ANSWER(I) := CHARACTER'VAL(CHARACTER'POS(ANSWER(I)) -
                    CHARACTER'POS('a') + CHARACTER'POS('A'));
            end if;
        end loop;
        return ANSWER;
end UPPER_CASE;

Procedure GET_LINE (filename: in text_io.file_type;
                    item    : out dyn.dyn_string;
                    last    : out natural) is

static_string_var: string(1..255);
lastchar:natural;

BEGIN
  Text_io.get_line(filename,static_string_var,lastchar);
  item:=dyn.substring(dyn.d_string(static_string_var),1,lastchar);
  last:=lastchar;
END;


Procedure GET_LINE (item    : out dyn.dyn_string;
                    last    : out natural) is

static_string_var: string(1..255);
lastchar:natural;

BEGIN
  Text_io.get_line(static_string_var,lastchar);
  item:=dyn.substring(dyn.d_string(static_string_var),1,lastchar);
  last:=lastchar;
END;

Procedure PUT (filename : in text_io.file_type;
               item     : in dyn.dyn_string) is

BEGIN
   put(filename,STR(item));
END;

Procedure PUT (item  : in dyn.dyn_string) is

BEGIN
   put(STR(item));
END;

Procedure OPEN (filename : in out text_io.file_type;
                mode     : in  text_io.file_mode;
                filenm   : in  dyn_string) is
BEGIN
  text_io.open(filename,mode,STR(filenm));
end;

end DYN;




--
-- EXPERT SYSTEM
--

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 [phone] (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;