{%%%%%%%%%
#
          PXG - The Pascal Expert Generator

based on the original
by Samuel H. Smith, Public Domain Material, Version 1.1, 6-Oct-85


This program allows you to prepare a set of rules for a
decision-tree based expert system.

You teach the expert by repeatedly "Learning" new facts in the
interactive learn mode.

When you have your rules working properly, PXG will generate a
stand-alone expert program in p5x pascal!


This distribution contains the following files:

pxg.pas     Source code for the pascal expert generator
pxg.inc.pas Include file needed when compiling your experts

langexp.kdb A knowledge base for a language selection expert
langexp.pas Generated source code for the language expert

mechanic.kdb The knowledge base for an auto mechanic expert
mechanic.pas Generated source code for the expert mechanic



Legal commands while running PXG:

New	Create a new knowledge base
        Use this to erase the current set of rules and prepare
        to create your own expert. You will be prompted to
        enter the title of the expert. This title will be
        included in the expert program that you generate.

Read	Read a knowledge base from a disk file
        Use this to load in a saved knowledge base. You
        can load either of the demonstration knowledge
        bases (LANGEXP or MECHANIC) with this option.

Write	Write the current knowledge base to a file
        Use this to save your knowledge bases. You can
        also edit a saved knowledge base with a text
        editor to improve the rules.

Display	Display the rules in the current knowledge base
        Use this to get a listing of all of the current
        rules.

Program	Generate an expert program from this knowledge base
        PXG will write a complete, ready to compile program
        in p5x pascal to implement your expert!

Learn	Test this knowledge base and learn new rules
        Operate the expert and learn new rules. This is
        the way you refine and build up your expert.

Quit	Exit to the system

?	Print a list of commands.

}


(* -------------------------------------------------------
*
* PXG - A Pascal Expert Generator
*
* By Samuel H. Smith, Public Domain Material
*
* Version 1.0, 4-Oct-85
* Initial public domain release
*
* Version 1.1, 6-Oct-85
* This version uses a new, more compact format for .KDB files
* and is not compatible with old .KDB files.
*
*)



program pascalExpertGenerator(input, output);

label 111;

const strLen = 80;

type
   strIndex  =  1 .. strLen;
   anystring = record
                  str : packed array[strIndex] of char;
                  len : 0..strLen;
               end;

   treeptr = ^tree; {this is the basic structure of the}
   tree = record    {knowledge base tree}

             question: anystring; {question to ask at this node in the tree}
             ifyes: treeptr; {subtree if answer is yes}
             ifno: treeptr; {subtree if answer is no}

             conclusion: anystring; {conclusion if there is no question}

          end;



var
   title: anystring; {the title of the current knowledge base}

   root: treeptr;    {the root of the knowledge tree}

   line: anystring;  {a working filename line buffer}

   saved: boolean;   {has the current knowledge base been saved?}

   command: char;

{@@ #include <sys/stat.h> @@}

function fileExists(fname : packed array[one..len :integer] of char ) : boolean;
begin
{@@ {}
    char filename[NAME_MAX+1];
    const char *s =  fname_2c;
    struct stat st;
    int i=0,l=0;
    while(i<len_2) {
       if(s[i]!=' ') l=i;
       if(i<NAME_MAX) {filename[i] = s[i]; i++;}
    } //while
    filename[l+1] = '\0';
    int result = stat(filename, &st);
    return result == 0;
@@}
   fileExists := true;  {unused}
end; { fileExists }

function upCase(c :  char): char;
begin
   if c in ['a'..'z'] then
      upCase := chr(ord(c) + ord('A') - ord('a') )
   else
      upCase := c;
end; { upCase }

{get a string from the file f, which could be the terminal
 string is right padded,
 len does not include right padding
 end of input string marked by eoln
 }
procedure readStr(var f : text;  var s : anystring);
var
   i : strIndex;
   c : char;
begin
   with s do begin
      len := 0;
      {skip leading blanks}
      c := ' ';
      while not eoln(f) and (c=' ') do
         read(f, c);

      if c <> ' ' then begin
         str[1] := c;
         len := 1;
         i := 2;
      end;
# if 1
   while not eoln(f) do begin
      read(f, c);
      if i <= strLen then begin
         str[i] := c;
         len := i;
         i := i+1;
      end;
   end; {while}
   for i := len+1 to strLen do
      str[i] := ' ';
#else
      for i := 1 to strLen do begin
         str[i] := c;
         writeln('str[',i:1,'] := ',c);
         if eoln(f) then
            c := ' '
         else begin
            len := i+1;
            read(f, c)
         end;
      end; {with}
#endif
   end;
   readln(f);
end; { readStr }


{request file name from user,
 assign file variable to the file
 return true iff file exists
}
function getFile(var fd : text; isPas : boolean) : boolean;
var
   i : strIndex;
begin

   readStr(input, line);
   with line do begin
      if len = 0 then begin
         writeln('no file name - starting again');
         goto 111;
      end;

      i := 1;
      while (i <= len) and (str[i] <> '.') do
         i := i+1;
      if i > len then begin
         // line := line + extension ('.kdb' or '.pas');
         if len+4 > strLen then begin
            writeln('filename too long - starting again');
            goto 111;
         end;
         str[len+1] := '.';
         if isPas then begin
            str[len+2] := 'p';
            str[len+3] := 'a';
            str[len+4] := 's';
         end
         else begin
            str[len+2] := 'k';
            str[len+3] := 'd';
            str[len+4] := 'b';
         end;
         len := len+4;
      end;

      writeln('file is ''', str:len, '''');
      assign(fd,str);
      getFile := fileExists( str );

   end; {with}
end; { getfile }


(* -------------------------------------------------------
*
* ask a yes/no question
*
* returns true if the answer is yes
*
*)

function ask(question: packed array[one..len:integer] of char): boolean;
var
   i      : integer;
   answer : char;
begin
   repeat
      for i := one to len do
         write(question[i]);
      write(' (Y/N) ');

      readln(answer);
      answer := upcase(answer);
      writeln(answer);

      if not (answer in ['Y', 'N']) then
         writeln('Please answer the question!');

   until answer in ['Y', 'N'];

   ask := (answer = 'Y');
end; { ask }


(* -------------------------------------------------------
*
* make a conclusion
*
*)

procedure conclude(conc: anystring);
begin
   writeln;
   writeln('Conclusion: ', conc.str:conc.len);
   writeln;
end; { conclude }


(* -------------------------------------------------------
*
* learn a new rule
*
* entered when an incorrect conclusion is drawn
* moves the current conclusion down the 'no' branch of the tree
* makes a new question and moves it's conclusion down the 'yes' branch
*
*)
procedure learn(var node: treeptr);
var
   temptree: treeptr;

begin
   saved := false;

   with node^ do begin
      new(ifno); {initialize the new subtrees}
      with ifno^ do  begin
         ifyes := nil;
         ifno := nil;
         question := node^.question;     {the ifno subtree inherits the}
         conclusion := node^.conclusion; {question and conclusion that}
      end;                               {used to be at this node}

      new(ifyes);
      with ifyes^ do  begin
         ifyes := nil;
         ifno := nil;
         question.len := 0;
      end;


      {now gather the information needed to enter a new question and
      conclusion into the tree}

      writeln;
      writeln('Please enter the correct conclusion:');
      write('> ');
      readStr(input,  conclusion);
      ifyes^.conclusion := conclusion;

      repeat
         writeln;
         writeln('Please enter a new question or leave blank for no new question. ');
         writeln('Phrase the question so that when answered "yes" it gives the conclusion:');
         writeln(' ', ifyes^.conclusion.str:ifyes^.conclusion.len);
         writeln('and that when answered "no" gives the conclusion:');
         writeln(' ', ifno^.conclusion.str:ifno^.conclusion.len);

         writeln;
         writeln('Enter "X" to exchange the "yes" and "no" conclusions,');
         writeln('otherwise enter the actual question.');
         write('> ');
         readStr(input, question);
         question.str[1] := upcase(question.str[1]);
         writeln;

         if (question.str[1] = 'X') and (question.len = 1) then begin
            temptree := ifno;
            ifno := ifyes;
            ifyes := temptree;
         end;

      until (question.str[1] <> 'X') or (question.len <> 1);

      if question.len = 0 then begin
         dispose(ifyes); ifyes := nil;
         dispose(ifno);  ifno := nil;
      end;
   end; {with}
end; { learn }


(* -------------------------------------------------------
*
* solve a problem with a knowledge tree
*
* makes a conclusion if there is no question in the current node.
* otherwise, it asks the question and then tries to solve
* the remaining subtree.
* will learn a new fact if an incorrect conclusion is drawn.
*
*)

procedure solvetree(node: treeptr);
begin
   with node^ do begin
      if question.len <> 0 then {ask the question if there is one}
      begin
         if ask(question.str) then
            solvetree(ifyes) {decide which branch of the tree}
         else                {to solve based on the answer}
            solvetree(ifno);
      end
      else

      begin {there is no question; just make a conclusion}
         conclude(conclusion);

         if ask('Is this the right conclusion?') = false then
            learn(node);
      end;

   end;
end; { solvetree }


(* -------------------------------------------------------
*
* list all of the knowledge contained in a knowledge tree
*
*)

procedure disptree(level: integer; node: treeptr);
begin
   with node^ do begin
      if question.len <> 0 then begin
         writeln(' ':level, 'If ''', question.str:question.len, ''' is true:');
         disptree(level+3, ifyes);

         writeln;
         writeln(' ':level, 'If ''', question.str:question.len, ''' is false:');
         disptree(level+3,ifno);
      end
      else
         writeln(' ':level, conclusion.str:conclusion.len)
   end;
end; { disptree }


(* -------------------------------------------------------
*
* free all memory in the tree
*
*)

procedure freetree(node: treeptr);
begin
   with node^ do begin
      if ifyes <> nil then
         freetree(ifyes);
      if ifno <> nil then
         freetree(ifno);
      dispose(node);
   end;
end; { freetree }


(* -------------------------------------------------------
*
* initialize a new knowledge tree
*
*)

procedure inittree;
begin
   new(root);
   with root^ do begin
      ifyes := nil;
      ifno := nil;
      question.len := 0;
      conclusion.len := 14;
      conclusion.str := 'No conclusion';
   end;

   saved := true;
   title.len := 22;
   title.str := 'Default knowledge base';

end; { inittree }


(* -------------------------------------------------------
*
* write a node in the knowledge tree to a file
*
*)

procedure writenode(var fd : text; level: integer; node: treeptr);
begin
   with node^ do
   begin
      if question.len <> 0 then begin
         writeln(fd, 'Q:', question.str:question.len);
         write(fd, ' ':level, 'Y');
         writenode(fd, level+1, ifyes);

         write(fd, ' ':level, 'N');
         writenode(fd, level+1, ifno);
      end
      else
         writeln(fd, 'C:', conclusion.str:conclusion.len);
   end;
end; { writenode }


(* -------------------------------------------------------
*
* write the entire knowledge tree to a file
*
*)

procedure writetree;
var
   kdb    : text;
begin
   write('Enter the name of the file to write to [.kdb]: ');
   if getFile(kdb, false) then begin
      if ask('That file exists! Overwrite it?') = false then begin
         writeln('skipping');
         goto 111;
      end;
   end;
   rewrite(kdb);
   writeln(kdb, title.str:title.len);
   writenode(kdb, 0, root);
   saved := true;
end; { writetree }



(* -------------------------------------------------------
*
* read a node of the knowledge tree from a file
* and verify that the file is valid
*
*)

procedure readnode(var fd :text;  node: treeptr);
var
   c: char;

   procedure expect(message: char);
   begin
      repeat
         read(fd, c);
      until c <> ' ';

      if c <> message then
         writeln('"', message, '" expected, "', c, '" found.');
   end; { expect }

begin
   with node^ do begin
      read(fd, c);
      if c = 'Q' then  begin
         conclusion.len := 0;
         expect(':');
         readStr(fd, question);

         expect('Y');
         new(ifyes);
         readnode(fd, ifyes);

         expect('N');
         new(ifno);
         readnode(fd, ifno);
      end
      else begin
         if c <> 'C' then
            writeln('"C" expected, "', c, '" found.');

         expect(':');
         readStr(fd, conclusion);
      end;
   end;
end; { readnode }


(* -------------------------------------------------------
*
* read a new knowledge tree from a file
*
*)

procedure readtree;
var
   kdb:text;         {file to read tree from}
begin

   {if there is anything in the current knowledge tree, then see if}
   {the user wants to save it}

   if not saved then
      if ask('Do you want to save the current knowledge base?') then
         writetree;

   freetree(root); inittree;
   write('Enter the name of the file to read from [.kdb]: ');

   if not getFile(kdb, false) then begin
      writeln(line.str:line.len, ' does not exist - starting again');
      goto 111;
   end;
   reset(kdb);
   readStr(kdb, title);
   writeln('reading kdb ''', title.str:title.len, '''');
   readnode(kdb, root);

   saved := true;

end; { readtree }


(* -------------------------------------------------------
*
* generate a program fragment for the current node in the knowledge tree
*
*)

procedure prognode(var f : text; level: integer; node: treeptr);

   procedure pwrite(s : anystring);
   {write out string s, expanding quotes}
   var i : strIndex;
   begin
      with s do begin
         for i := 1 to len do begin
            if str[i] = '''' then
               write(f, '''');
            write(f, str[i]);
         end; {for}
      end; {with}
   end; { pwrite }

begin
   with node^ do begin
      if question.len <> 0 then begin
         write(f, ' ':level, 'if ask(''' );
         pwrite(question);
         writeln(f, ''') = true then');
         prognode(f, level+3, ifyes);

         writeln(f);
         write(f, ' ':level, 'else {');
         pwrite(question);
         writeln(f, ' = false}');
         prognode(f, level+3, ifno);
      end
      else begin
         write(f, ' ':level, 'conclude(''');
         pwrite( conclusion);
         writeln(f, ''')');
      end;
   end;
end; { prognode }


(* -------------------------------------------------------
*
* generate a program to walk the knowledge tree
*
*)
procedure progtree;
var
   pfile:text;         {file to write to}
begin
   write('Enter the name of the file to save the program in [.pas]: ');
   if getFile(pfile, true) then begin
      if ask('That file exists! Overwrite it?') = false then
         goto 111;
   end;
   rewrite(pfile);
   writeln(pfile);
   writeln(pfile, '{Expert program ', line.str:line.len, ' generated by PXG}');
   writeln(pfile);
   writeln(pfile, 'program ', line.str:line.len-4, '(input, output);');
   writeln(pfile, '#include "pxg.inc.pas"');
   writeln(pfile);
   writeln(pfile, 'begin');
   writeln(pfile, ' repeat');
   writeln(pfile, ' writeln;');
   writeln(pfile, ' writeln(''', title.str:title.len, ''');');
   writeln(pfile, ' writeln;');
   writeln(pfile);
   prognode(pfile, 6, root);
   writeln(pfile);
   writeln(pfile, ' until ask(''Run again?'') = false;');
   writeln(pfile, 'end.');

   writeln;
   writeln('Use p5c pascal to compile ', line.str:line.len);
   writeln;

end; { progtree }


(* -------------------------------------------------------
*
* initialize a new knowledge tree
*
*)
procedure newtree;
begin

   {if there is anything in the current knowledge tree, then see if}
   {the user wants to save it}

   if not saved then
      if ask('Do you want to save the current knowledge base?') then
         writetree;

   freetree(root);  inittree;
   writeln('Enter the title of the new expert:');
   write('> ');
   readStr(input, title);

end; { newtree }


(* -------------------------------------------------------
*
* help - give some help
*
*)

procedure help;
begin
   {clrscr;}
   writeln;
   writeln('Actions:');
   writeln(' New     Create a new knowledge base');
   writeln(' Read    Read a knowledge base from a disk file');
   writeln(' Write   Write the current knowledge base to a file');
   writeln(' Display Display the rules in the current knowledge base');
   writeln(' Program Generate an expert program from this knowledge base');
   writeln(' Learn   Test this knowledge base and learn new rules');
   writeln(' Quit    Exit to the system');
   writeln;

end; { help }


(* -------------------------------------------------------
*
* main program
* select expert commands and process them
*
*)

begin
   {clrscr;}
   writeln;
   writeln('PXG - A Pascal Expert Generator');
   writeln;
   writeln('This program allows you to prepare a set of rules for a');
   writeln('decision-tree based expert system.');
   writeln;
   writeln('You teach the expert by repeatedly "Learning" new facts. ');
   writeln('When you have your rules working properly, you can generate ');
   writeln('a stand-alone expert program in p5c pascal!');
   writeln;
   writeln('By Samuel H. Smith, Public Domain Material');
   writeln('Version 1.1, 6-Oct-85');

   help;

   inittree;

111:     {goto here if command failed}
   repeat
      writeln;
      writeln('Working on:');
      writeln(' ', title.str:title.len);
      writeln;
      write('Action: New, Read, Write, Display, Program, Learn, Quit, ?: ');

      readln(command);
      command := upcase(command);
      writeln(command);
      writeln;

      case command of
        'N': newtree;
        'R': readtree;
        'W': writetree;
        'D': disptree(3, root);
        'P': progtree;
        'L': solvetree(root);
        '?': help;
        'Q': writeln('Goodbye.');
        otherwise writeln('What? Type "?" for help.');
      end

   until command = 'Q';


   {if there is anything in the current knowledge tree, then see if}
   {the user wants to save it}

   if not saved then
      if ask('Do you want to save the current knowledge base?') then
         writetree;

   freeTree(root);

end.


{%%%%%%%%%%%%%%%%%%%%%%%%%%%%% end of pxg.pas %%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
