home *** CD-ROM | disk | FTP | other *** search
/ Shareware Overload / ShartewareOverload.cdr / progm / pxg.zip / PXG.PAS < prev   
Pascal/Delphi Source File  |  1985-10-19  |  13KB  |  607 lines
  1.  
  2.  
  3. (* * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  4.  *
  5.  * PXG - A Pascal Expert Generator
  6.  *
  7.  * By Samuel H. Smith,  Public Domain Material
  8.  *
  9.  * Version 1.0, 4-Oct-85
  10.  *
  11.  *)
  12.  
  13. {$D-,U+,R+}
  14.  
  15.  
  16. program expert(console, display, knowledge_files);
  17.  
  18. type
  19.    anystring = string[80];
  20.  
  21.    treeptr = ^tree;           {this is the basic structure of the}
  22.    tree = record              {knowledge tree}
  23.       question:   anystring;      {question to ask at this node in the tree}
  24.       ifyes:      treeptr;           {subtree if answer is yes}
  25.       ifno:       treeptr;           {subtree if answer is no}
  26.       conclusion: anystring;      {conclusion if there is no question}
  27.    end;
  28.  
  29.  
  30. var
  31.    title:  anystring;    {the title of the current knowledge base}
  32.    root:   treeptr;      {the root of the knowledge tree}
  33.    fd:     text[1024];   {file for read/write tree to disk}
  34.    line:   anystring;    {a working line buffer}
  35.    saved:  boolean;      {has the current knowledge base been saved?}
  36.  
  37.  
  38.  
  39. (* * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  40.  *
  41.  * ask a yes/no question
  42.  *
  43.  * returns true if the answer is yes
  44.  *
  45.  *)
  46.  
  47. function ask(question: anystring): boolean;
  48. var
  49.    answer: char;
  50. begin
  51.    repeat
  52.       write(question,' (Y/N) ');
  53.  
  54.       read(kbd,answer);
  55.       answer := upcase(answer);
  56.       writeln(answer);
  57.  
  58.       if not (answer in ['Y','N']) then
  59.          writeln('Please answer the question!');
  60.  
  61.    until answer in ['Y','N'];
  62.  
  63.    ask := (answer = 'Y');
  64. end;
  65.  
  66.  
  67. (* * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  68.  *
  69.  * make a conclusion
  70.  *
  71.  *)
  72.  
  73. procedure conclude(conc: anystring);
  74. begin
  75.    writeln;
  76.    writeln('Conclusion: ',conc);
  77.    writeln;
  78. end;
  79.  
  80.  
  81.  
  82. (* * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  83.  *
  84.  * learn a new rule
  85.  *
  86.  * entered when an incorrect conclusion is drawn
  87.  * moves the current conclusion down the 'no' branch of the tree
  88.  * makes a new question and moves it's conclusion down the 'yes' branch
  89.  *
  90.  *)
  91.  
  92. procedure learn(var node: treeptr);
  93. var
  94.    temptree: treeptr;
  95.  
  96. begin
  97.    saved := false;
  98.  
  99.    with node^ do
  100.    begin
  101.       new(ifno);       {initialize the new subtrees}
  102.       with ifno^ do
  103.       begin
  104.          ifyes      := nil;
  105.          ifno       := nil;
  106.          question   := node^.question;    {the ifno subtree inherits the}
  107.          conclusion := node^.conclusion;  {question and conclusion that}
  108.       end;                                {used to be at this node}
  109.  
  110.       new(ifyes);
  111.       with ifyes^ do
  112.       begin
  113.          ifyes      := nil;
  114.          ifno       := nil;
  115.          question   := '';
  116.       end;
  117.  
  118.  
  119.       {now gather the information needed to enter a new question and
  120.        conclusion into the tree}
  121.  
  122.       writeln;
  123.       writeln('Please enter the correct conclusion:');
  124.       write('> ');
  125.       readln(conclusion);
  126.       ifyes^.conclusion := conclusion;
  127.  
  128.       repeat
  129.          writeln;
  130.          writeln('Please enter a new question.  Phrase the question');
  131.          writeln('so that when answered "yes" it gives the conclusion: ');
  132.          writeln('   ',ifyes^.conclusion);
  133.          writeln('and that when answered "no" gives the conclusion:');
  134.          writeln('   ',ifno^.conclusion);
  135.  
  136.          writeln;
  137.          writeln('Enter "X" to exchange the "yes" and "no" conclusions,');
  138.          writeln('otherwise enter the actual question.');
  139.          write('> ');
  140.          readln(question);
  141.          question[1] := upcase(question[1]);
  142.          writeln;
  143.  
  144.          if question = 'X' then
  145.          begin
  146.             temptree := ifno;
  147.             ifno := ifyes;
  148.             ifyes := temptree;
  149.          end;
  150.  
  151.       until question <> 'X';
  152.    end;
  153. end;
  154.  
  155.  
  156.  
  157. (* * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  158.  *
  159.  * solve a problem with a knowledge tree
  160.  *
  161.  * makes a conclusion if there is no question in the current subtree.
  162.  * otherwise, it asks the question and then tries to solve
  163.  * the remaining subtree.
  164.  * will learn a new fact if an incorrect conclusion is drawn.
  165.  *
  166.  *)
  167.  
  168. procedure solvetree(node: treeptr);
  169. begin
  170.    with node^ do
  171.    begin
  172.       if question <> '' then   {ask the question if there is one}
  173.       begin
  174.          if ask(question) then
  175.             solvetree(ifyes)      {decide which branch of the tree}
  176.          else                     {to solve based on the answer}
  177.             solvetree(ifno);
  178.       end
  179.       else
  180.  
  181.       begin           {there is no question; just make a conclusion}
  182.          conclude(conclusion);
  183.  
  184.          if ask('Is this the right conclusion?') = false then
  185.             learn(node);
  186.       end;
  187.  
  188.    end;
  189. end;
  190.  
  191.  
  192.  
  193. (* * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  194.  *
  195.  * list all of the knowledge contained in a knowledge tree
  196.  *
  197.  *)
  198.  
  199. procedure disptree(level: integer;  node: treeptr);
  200. begin
  201.    with node^ do
  202.    begin
  203.       if question <> '' then
  204.       begin
  205.          writeln('':level,question);
  206.          writeln('':level,'If yes:');
  207.          disptree(level+3,ifyes);
  208.  
  209.          writeln('':level,'If no:');
  210.          disptree(level+3,ifno);
  211.       end
  212.       else
  213.          writeln('':level,conclusion)
  214.    end;
  215. end;
  216.  
  217.  
  218.  
  219. (* * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  220.  *
  221.  * write a node in the knowledge tree to a file
  222.  *
  223.  *)
  224.  
  225. procedure writenode(node: treeptr);
  226. begin
  227.    with node^ do
  228.    begin
  229.       if question <> '' then
  230.       begin
  231.          writeln(fd,'Q:');
  232.          writeln(fd,question);
  233.          writeln(fd,'Y:');
  234.          writenode(ifyes);
  235.  
  236.          writeln(fd,'N:');
  237.          writenode(ifno);
  238.       end
  239.       else
  240.       begin
  241.          writeln(fd,'C:');
  242.          writeln(fd,conclusion);
  243.       end;
  244.    end;
  245. end;
  246.  
  247.  
  248.  
  249. (* * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  250.  *
  251.  * write the entire knowledge tree to a file
  252.  *
  253.  *)
  254.  
  255. procedure writetree;
  256. begin
  257.    write('Enter the name of the file to write to [.KDB]: ');
  258.    readln(line);
  259.    if line = '' then
  260.       exit;
  261.  
  262.    if pos('.',line) = 0 then
  263.       line := line + '.kdb';
  264.  
  265.    assign(fd,line);
  266.  
  267. {$I-}
  268.    rewrite(fd);
  269.    writeln(fd,title);
  270.    writenode(root);
  271.    close(fd);
  272.  
  273.    if ioresult <> 0 then
  274.       writeln('Error writing file!')
  275.    else
  276.       saved := true;
  277. {$I+}
  278.  
  279. end;
  280.  
  281.  
  282.  
  283. (* * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  284.  *
  285.  * read a node of the knowledge tree from a file
  286.  * and verify that the file is valid
  287.  *
  288.  *)
  289.  
  290. procedure readnode(node: treeptr);
  291.  
  292.    procedure expect(message: anystring);
  293.    begin
  294.       readln(fd,line);
  295.       if line <> message then
  296.          writeln('"',message,'" expected, "',line,'" found.');
  297.    end;
  298.  
  299. begin
  300.    with node^ do
  301.    begin
  302.       readln(fd,line);
  303.       if line = 'Q:' then
  304.       begin
  305.          conclusion := '';
  306.          readln(fd,question);
  307.          expect('Y:');
  308.          new(ifyes);
  309.          readnode(ifyes);
  310.          expect('N:');
  311.          new(ifno);
  312.          readnode(ifno);
  313.       end
  314.       else
  315.  
  316.       begin
  317.          if line <> 'C:' then
  318.             writeln('"C:" expected, "',line,'" found.');
  319.  
  320.          readln(fd,conclusion);
  321.       end;
  322.    end;
  323. end;
  324.  
  325.  
  326.  
  327. (* * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  328.  *
  329.  * read a new knowledge tree from a file
  330.  *
  331.  *)
  332.  
  333. procedure readtree;
  334. begin
  335.  
  336.    {if there is anything in the current knowledge tree, then see if}
  337.    {the user wants to save it}
  338.  
  339.    if not saved then
  340.       if ask('Do you want to save the current knowledge base?') then
  341.          writetree;
  342.  
  343.    write('Enter the name of the file to read from [.KDB]: ');
  344.    readln(line);
  345.    if line = '' then
  346.       exit;
  347.  
  348.    if pos('.',line) = 0 then
  349.       line := line + '.kdb';
  350.  
  351.    assign(fd,line);
  352.  
  353. {$I-}
  354.    reset(fd);
  355.    if ioresult <> 0 then
  356.       writeln('File not found!')
  357.    else
  358.  
  359.    begin
  360.       readln(fd,title);
  361.       readnode(root);
  362.       close(fd);
  363.    end;
  364.  
  365.    if ioresult <> 0 then
  366.       writeln('Error reading file!');
  367. {$I+}
  368.  
  369.    saved := true;
  370.  
  371. end;
  372.  
  373.  
  374.  
  375.  
  376. (* * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  377.  *
  378.  * generate a program fragment for the current node in the knowledge tree
  379.  *
  380.  *)
  381.  
  382. procedure prognode(level: integer;  node: treeptr);
  383. begin
  384.    with node^ do
  385.    begin
  386.       if question <> '' then
  387.       begin
  388.          writeln(fd,'':level,'if ask(''',question,''') = true then');
  389.          prognode(level+3,ifyes);
  390.  
  391.          writeln(fd);
  392.          writeln(fd,'':level,'else    {',question,' = false}');
  393.          prognode(level+3,ifno);
  394.       end
  395.       else
  396.          writeln(fd,'':level,'conclude(''',conclusion,''')');
  397.    end;
  398. end;
  399.  
  400.  
  401.  
  402. (* * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  403.  *
  404.  * generate a program to walk the knowledge tree
  405.  *
  406.  *)
  407.  
  408. procedure progtree;
  409. begin
  410.    write('Enter the name of the file to save the program in [.PAS]: ');
  411.    readln(line);
  412.    if line = '' then
  413.       exit;
  414.  
  415.    if pos('.',line) = 0 then
  416.       line := line + '.pas';
  417.  
  418.    assign(fd,line);
  419.  
  420. {$I-}
  421.    reset(fd);
  422. {$I+}
  423.  
  424.    if ioresult = 0 then
  425.    begin
  426.       close(fd);
  427.       if ask('The file '+line+' exists!   Overwrite it?') = false then
  428.          exit;
  429.    end;
  430.  
  431. {$I-}
  432.    rewrite(fd);
  433.    writeln(fd);
  434.    writeln(fd,'{Expert program ',line,' generated by PXG}');
  435.    writeln(fd,'{',title,'}');
  436.    writeln(fd);
  437.    writeln(fd,'{$I PXG.INC}');
  438.    writeln(fd);
  439.  
  440.    writeln(fd,'begin');
  441.    writeln(fd,'   writeln;');
  442.    writeln(fd,'   writeln(''',title,''');');
  443.    writeln(fd,'   writeln;');
  444.  
  445.    prognode(3,root);
  446.    writeln(fd,'end.');
  447.  
  448.    close(fd);
  449.  
  450.    if ioresult <> 0 then
  451.       writeln('Error writing file!')
  452.    else
  453.  
  454.    begin
  455.       writeln;
  456.       writeln('Use Turbo Pascal to compile ',line);
  457.       writeln;
  458.    end;
  459.  
  460. {$I+}
  461.  
  462. end;
  463.  
  464.  
  465.  
  466. (* * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  467.  *
  468.  * initialize a new knowledge tree
  469.  *
  470.  *)
  471.  
  472. procedure inittree;
  473. begin
  474.    new(root);
  475.    with root^ do
  476.    begin
  477.       ifyes      := nil;
  478.       ifno       := nil;
  479.       question   := '';
  480.       conclusion := 'No conclusion';
  481.    end;
  482.  
  483.    saved := true;
  484.    title := 'Default knowledge base';
  485.  
  486. end;
  487.  
  488.  
  489.  
  490. (* * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  491.  *
  492.  * initialize a new knowledge tree
  493.  *
  494.  *)
  495.  
  496. procedure newtree;
  497. begin
  498.  
  499.    {if there is anything in the current knowledge tree, then see if}
  500.    {the user wants to save it}
  501.  
  502.    if not saved then
  503.       if ask('Do you want to save the current knowledge base?') then
  504.          writetree;
  505.  
  506.    writeln('Enter the title of the new expert:');
  507.    write('> ');
  508.    readln(title);
  509.  
  510. end;
  511.  
  512.  
  513.  
  514. (* * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  515.  *
  516.  * help - give some help
  517.  *
  518.  *)
  519.  
  520. procedure help;
  521. begin
  522.    writeln;
  523.    writeln('Actions:');
  524.    writeln('   New          Create a new knowledge base');
  525.    writeln('   Read         Read a knowledge base from a disk file');
  526.    writeln('   Write        Write the current knowledge base to a file');
  527.    writeln('   Display      Display the rules in the current knowledge base');
  528.    writeln('   Program      Generate an expert program from this knowledge base');
  529.    writeln('   Learn        Test this knowledge base and learn new rules');
  530.    writeln('   Quit         Exit to the system');
  531.    writeln;
  532.  
  533. end;
  534.  
  535.  
  536.  
  537. (* * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  538.  *
  539.  * main program
  540.  * select expert commands and process them
  541.  *
  542.  *)
  543.  
  544. var
  545.    command:  char;
  546.  
  547. begin
  548.    clrscr;
  549.    writeln;
  550.    writeln('PXG - A Pascal Expert Generator');
  551.    writeln;
  552.    writeln('This program allows you to prepare a set of rules for a');
  553.    writeln('decision-tree based expert system.');
  554.    writeln;
  555.    writeln('You teach the expert by repeatedly "Learning" new facts. ');
  556.    writeln('When you have your rules working properly, you can generate ');
  557.    writeln('a stand-alone expert program in turbo pascal!');
  558.    writeln;
  559.    writeln('By Samuel H. Smith,  Public Domain Material');
  560.    writeln('Version 1.0, 4-Oct-85');
  561.    inittree;
  562.  
  563.    repeat
  564.       writeln;
  565.       writeln('Working on:');
  566.       writeln('   ',title);
  567.       writeln;
  568.       write('Action:  New, Read, Write, Display, Program, Learn, Quit, ?: ');
  569.       read(kbd,command);
  570.       command := upcase(command);
  571.       writeln(command);
  572.       writeln;
  573.  
  574.       case command of
  575.          'N':  newtree;
  576.  
  577.          'R':  readtree;
  578.  
  579.          'W':  writetree;
  580.  
  581.          'D':  disptree(3,root);
  582.  
  583.          'P':  progtree;
  584.  
  585.          'L':  solvetree(root);
  586.  
  587.          '?':  help;
  588.  
  589.          'Q':  ;
  590.  
  591.          else  writeln('What?   Type "?" for help.');
  592.       end;
  593.  
  594.    until command = 'Q';
  595.  
  596.  
  597.    {if there is anything in the current knowledge tree, then see if}
  598.    {the user wants to save it}
  599.  
  600.    if not saved then
  601.       if ask('Do you want to save the current knowledge base?') then
  602.          writetree;
  603.  
  604.    writeln('Goodbye.');
  605. end.
  606.  
  607.