program MultEliza;
   {Derived from the Eliza program published in "More BASIC Computer Games,"
    edited by David H. Ahl.  The original Eliza was written in LISP by
    Joseph Weizenbaum at MIT.  It was converted to BASIC by Jeff Shrager
    and further modified to work in Microsoft BASIC by Steve North.}

   {Personal Pascal version by Rod Smith, 2/20/90}

{$I AUXSUBS.PAS}

const
   KEYNUM   = 100;           {maximum # of keywords which can be handled}
   CONJNUM  = 13;            {# of conjugation conversions in code}
   LINELEN  = 80;	     {# of chars on one line}
   DATAFILE = 'M_ELIZA.DAT'; {default data file}

type
   {OK, this'll take some explaining.  Draw a diagram.  At the top is an
    array (variable Keywords, of type KeyArray) which contains keywords
    that the program looks for in the user's input, along with a pointer
    (type KeyConcept) to a pointer (type Index) to a looped set of pointers
    (type Cycle) containing replies.  The reason for the double indirection
    is so that more than one keyword can point to the same structure (the
    pointer to the "Cycle" is changed by the program).  ConjSet is a
    simpler structure which just has sets of words to be swapped in making
    a reply from the user's input.}

   Index = ^Cycle;
   Cycle = record
              Response: string; {response given to user}
              Next:     Index;  {pointer to next response to use}
           end;
   KeyConcept = ^Index;
   KeyArray = array [1..KEYNUM] of record
                 Word:    string;     {keyword itself}
                 Concept: KeyConcept; {pointer to a pointer to responses}
              end;
   ConjSet = array [1..CONJNUM] of record
                Original:    string; {word in user's input}
                Replacement: string; {word to replace it with}
             end;
   LongStr = string [165]; {should be long enough}

var
   Reply, Putin, Terminate,
   OldInput, Conj:		LongStr;  {strings for "conversation"}
   Keywords:			KeyArray; {array of keywords}
   KeyNo:			integer;  {keyword number}
   ConjPairs:			ConjSet;  {pairs of words to be swapped}
   Junk:			char;     {char. user enters to exit prg.}

{==1====1====1====1====1====1====1====1====1====1====1====1====1====1==}

procedure Initialize (var Keywords: KeyArray; var Reply, Terminate: LongStr;
                      var ConjPairs: ConjSet);
   {Initializes everything that needs initializing}

{==2====2====2====2====2====2====2====2====2====2====2====2====2====2==}

procedure InitConj (var ConjPairs: ConjSet);
   {Initializes conjugation pairs structure}

begin {InitConj}
   ConjPairs[1].Original := ' ARE '; ConjPairs[1].Replacement := ' ~AM ';
   ConjPairs[2].Original := ' AM '; ConjPairs[2].Replacement := ' ~ARE ';
   ConjPairs[3].Original := ' WERE '; ConjPairs[3].Replacement := ' ~WAS ';
   ConjPairs[4].Original := ' WAS '; ConjPairs[4].Replacement := ' ~WERE ';
   ConjPairs[5].Original := ' YOU '; ConjPairs[5].Replacement := ' ~I ';
   ConjPairs[6].Original := ' I '; ConjPairs[6].Replacement := ' ~YOU ';
   ConjPairs[7].Original := ' ME '; ConjPairs[7].Replacement := ' ~YOU ';
   ConjPairs[8].Original := ' YOUR'; ConjPairs[8].Replacement := ' ~MY';
   ConjPairs[9].Original := ' MY '; ConjPairs[9].Replacement := ' ~YOUR ';
   ConjPairs[10].Original := ' IVE '; ConjPairs[10].Replacement := ' YOU''VE ';
   ConjPairs[11].Original := ' YOUVE '; ConjPairs[11].Replacement := ' I''VE ';
   ConjPairs[12].Original := ' IM '; ConjPairs[12].Replacement := ' YOU''RE ';
   ConjPairs[13].Original := ' YOURE '; ConjPairs[13].Replacement := ' I''M ';
   {note: the "~"s above will be eliminated later.  They keeps the program
    from then replacing the new word with the old on a subsequent search of
    the string.}
end; {InitConj}

{==2====2====2====2====2====2====2====2====2====2====2====2====2====2==}

procedure InitReplies (var KeyWords: KeyArray; var Reply, BugOff: LongStr);
   {Reads keywords and replies from the file M_ELIZA.DAT.  The first
    character of each line determines its function: any alphabetic
    character signifies a reply; a "@" is a keyword; a "^" means to use
    the replies from the previous keyword; and a line of ##END## means
    the end of the data has been reached.  The first two lines are the
    first & last sentences "spoken" by Eliza to the user.}

var Pointer:           KeyConcept; {pointer to the reply "cycle"}
    Data:              text;       {text file with data in it}
    KeyWordNum, Extra: integer;    {keyword # being worked on}
    FName,                         {filename of keywords/replies file}
    Line:              string;     {line input from file}

{==3====3====3====3====3====3====3====3====3====3====3====3====3====3==}

procedure LoadReplies (var Line: string; var KeyWords: KeyArray; 
                       var WordNum: integer);
   {Loads the responses for one keyword, if file is formatted right}

var Reply, NewReply, FirstReply: Index; {pointers to response records}

begin {LoadReplies}
   if Line [1] = '@'
      then begin {Line contains a keyword}
         delete (Line, 1, 1); {delete the "@"}
         KeyWords [WordNum].Word := Line;
         readln (Data, Line);
         if (Line [1] = '^') then
            KeyWords [WordNum].Concept := KeyWords [WordNum - 1].Concept;
            {NOTE: WILL CRASH if WordNum = 1 (no preceding data anyhow)}
         if (Line [1] in ['a'..'z', 'A'..'Z']) then begin
            new (Pointer); {make new pointer to "cycle"}
            KeyWords [WordNum].Concept := Pointer; {point to the pointer}
            new (FirstReply);                      {make new reply record}
            Pointer^ := FirstReply;                {point pointer to record}
            FirstReply^.Response := Line;          {assign response}
            Reply := FirstReply;                   {so loop, below, can link}
            Reply^.Next := Reply                   {in case it's the only one}
         end; {if}
         loop
            readln (Data, Line); {get the next line of the file}
         exit if not (Line [1] in ['a'..'z', 'A'..'Z']);
            new (NewReply);               {make new record}
            Reply^.Next := NewReply;      {link into cycle}
            NewReply^.Response := Line;   {assign response}
            NewReply^.Next := FirstReply; {will probably be changed, but...}
            Reply := NewReply;            {move pointers along chain}
         end; {loop}
         WordNum := WordNum + 1; {increment keyword number}
      end {then begin}
      else readln (Data, Line);
end; {LoadReplies}

{==3====3====3====3====3====3====3====3====3====3====3====3====3====3==}

procedure TestError (var FName: string);
   {Checks to see if there was an error opening FName}
   {NOTE: Doesn't seem to work on the current version of Personal Pascal,
    because of a bug in the language's disk I/O error handling.}

var Error: integer; {result of the error check}

begin {TestError}
   Error := io_result; {get error #}
   if io_result <> 0 then begin
      if FName <> DATAFILE
         then begin
            writeln ('I''m having trouble reading the specified data file.');
            writeln ('Please enter a new filename or <RETURN> for the default.');
         end {then}
         else begin
            writeln ('I''m having trouble reading the default data file ',
                     '(M_ELIZA.DAT).');
            writeln ('Please enter a new filename or <RETURN> to try again.');
         end; {else}
      write ('==> ');
      readln (FName);
      reset (Data, FName); {try to open the file again}
      TestError (FName); {check it again (recursively)}
   end; {if}
end; {TestError}

{==3====3====3====3====3====3====3====3====3====3====3====3====3====3==}

begin {InitReplies}
   if cmd_args > 0 {if data file stated}
      then cmd_getarg (1, FName)   {get the filename}
      else FName := DATAFILE;      {default file to load}
   reset (Data, FName);            {bind file to handle}
   TestError (FName);              {checks to see if there was an I/O error}
   if not eof (Data)
      then readln (Data, Reply);   {read Eliza's first words to user}
   if not eof (Data)
      then readln (Data, BugOff);  {read Eliza's last words to user}
   KeyWordNum := 1;                {keyword number}
   Pointer := nil;                 {be sure says no nodes loaded already}
   readln (Data, Line);            {input line}
   while ((not eof (Data)) and (Line <> '##END##')) do
      LoadReplies (Line, KeyWords, KeyWordNum);
      {loads replies for one keyword (if the file is formatted right)}
   for Extra := KeyWordNum to KEYNUM do
      KeyWords [Extra] := KeyWords [Extra - 1];
      {fills out the array to avoid crashes if/when no keywords found}
      {NOTE: Results in the last keyword's data being used for the no-
       keyword-found condition}
   close (Data); {close the file up}
end; {InitReplies}

{==2====2====2====2====2====2====2====2====2====2====2====2====2====2==}

procedure WriteIntro;
   {Just outputs a message saying what the program is.}

begin {WriteIntro}
   clrscrn;
   gotoxy (34,0);
   inversevideo;
   write (' MULT-ELIZA ');
   gotoxy (33,2);
   write (' by Rod Smith ');
   gotoxy (26,3);
   write (' written in Personal Pascal ');
   gotoxy (23,4);
   write (' portions are copyright (c) 1987 ');
   gotoxy (32,5);
   write (' by OSS and CCD ');
   normvideo;
   writeln; writeln;
   writeln ('Type "shut up" to exit.'); writeln;
end; {WriteIntro}

{==2====2====2====2====2====2====2====2====2====2====2====2====2====2==}

begin {Initialize}
   io_check (FALSE);			     {lets the program handle I/O errors}
   WriteIntro;				     {output introductory blurb}
   InitConj (ConjPairs);		     {initialize conjugation pairs}
   InitReplies (KeyWords, Reply, Terminate); {initialize keywords & replies}
end; {Initialize}

{==1====1====1====1====1====1====1====1====1====1====1====1====1====1==}

procedure Remove (var Office: LongStr; Reagan: string);
   {Removes the first character of Reagan throughout Office}

var Where: integer; {where Reagan is}

begin {Remove}
   loop
      Where := pos (Reagan, Office)
   exit if Where = 0;
      delete (Office, Where, 1);
   end; {loop}
end; {Remove}

{==1====1====1====1====1====1====1====1====1====1====1====1====1====1==}

procedure Dialog (var Putin, OldInput, Reply: LongStr);
   {Gets the user's input.  Puts a space before punctuation, converts
    it all to uppercase, and deletes apostrophes.  Prompts with Reply}

var Where: integer; {var. for locating characters in string}

{==2====2====2====2====2====2====2====2====2====2====2====2====2====2==}

procedure SpacePunc (var Putin: LongStr; Punc: char);
   {Puts a space before all occurrances of Punc in Input}

var Where: integer; {position of Punc in Putin}

begin {SpacePunc}
   for Where := length (Putin) downto 2 do begin
      if ((Putin [Where] = Punc) and (Putin [Where - 1] <> ' '))
         then insert (' ', Putin, Where);
   end {for Where}
end; {SpacePunc}

{==2====2====2====2====2====2====2====2====2====2====2====2====2====2==}

procedure UpCase (var Line: LongStr);
   {Converts Line to uppercase characters}

var Where: integer; {current position in Line}

begin {UpCase}
   for Where := 1 to length (Line) do
      if Line [Where] in ['a'..'z'] {it's lowercase}
         then Line [Where] := chr (ord (Line [Where]) - 32); {so convert}
end; {UpCase}

{==2====2====2====2====2====2====2====2====2====2====2====2====2====2==}

procedure Babble (Sentence: LongStr);
   {Outputs Sentence, breaking words across lines appropriately.}
   {This is a potentially RECURSIVE routine!}

var First: string [LINELEN];
    Where: integer;

begin {Babble}
   if length (Sentence) < LINELEN
      then writeln (Sentence) {the easy part}
      else begin
         Where := LINELEN;
         while ((Sentence [Where] <> ' ') and (Where > 1)) do
            Where := Where - 1; {finds first space before end of line}
         First := copy (Sentence, 1, Where); {get Sentence up to Where}
         writeln (First);
         delete (Sentence, 1, Where); {delete what was just printed}
         Babble (Sentence); {recurse on remainder}
      end; {else}
end; {Babble}

{==2====2====2====2====2====2====2====2====2====2====2====2====2====2==}

begin {Dialog}
   OldInput := Putin; {store last user input for comparison with new}
   repeat
      writeln;
      Babble (Reply); {output the response, breaking words appropriately}
      write ('==> ');
      readln (Putin);
      if length (Putin) > LINELEN
         then Putin := copy (Putin, 1, LINELEN); {cut down to avoid overflow}
      Remove (Putin, ''''); {removes apostrophes from input}
      SpacePunc (Putin, '?');
      SpacePunc (Putin, '!');
      SpacePunc (Putin, '.');
      SpacePunc (Putin, ',');
      UpCase (Putin);
      Putin := concat (' ', Putin, '  '); {makes parsing easier}
      Reply := 'PLEASE DON''T REPEAT YOURSELF!';
   until Putin <> OldInput;
end; {Dialog}

{==1====1====1====1====1====1====1====1====1====1====1====1====1====1==}

procedure FindKeyword (var Putin, Conj: LongStr; var KeyWords: KeyArray;
                       var KeyNo: integer);
   {Finds the last occurrance of the first keyword in Putin.  Returns
    Conj with the string from the end of that word on, and KeyNo with
    the keyword number.}

var Where: integer; {location of keyword in string}

{==2====2====2====2====2====2====2====2====2====2====2====2====2====2==}

function FindLast (Keyword, Line: LongStr): integer;
   {Returns the starting point of the last position of Keyword in Line}

var Earlier, Later: integer; {first & second positions of the things}

begin {FindLast}
   Later := 0;
   loop
      Earlier := Later;
      Later := pos (Keyword, Line); {first position}
   exit if Later = 0; {not found; Earlier has latest "known" position}
      Line [Later] := '~'; {so won't find it again}
   end;
   FindLast := Earlier;
end; {FindLast}

{==2====2====2====2====2====2====2====2====2====2====2====2====2====2==}

begin {FindKeyword}
   KeyNo := 0;
   repeat
      KeyNo := KeyNo + 1; {keyword number}
      Where := pos (KeyWords [KeyNo].Word, Putin); {where it's located}
   until ((KeyNo = KEYNUM) or (Where > 0));
   Where := FindLast (KeyWords [KeyNo].Word, Putin);
   if Where > 0 {if there was a keyword found}
      then Conj := copy (Putin, Where + length (KeyWords [KeyNo].Word),
                         length (Putin) - Where - 
                         length (KeyWords [KeyNo].Word) + 1)
      else Conj := Putin;
end; {FindKeyword}

{==1====1====1====1====1====1====1====1====1====1====1====1====1====1==}

procedure Conjugate (var Babble: LongStr; var ConjPairs: ConjSet);
   {Modifies Babble using ConjPairs to guide word substitutions}

var Word,           {Word # currently being substituted}
    Where: integer; {Where in Babble word is located}

begin {Conjugate}
   for Word := 1 to CONJNUM do
      with ConjPairs [Word] do
         loop
            Where := pos (Original, Babble);
         exit if Where = 0;
            delete (Babble, Where, length (Original)); {delete the old}
            insert (Replacement, Babble, Where);       {insert the new}
         end; {loop}
   while Babble [length (Babble)] in [' ', '!', '.', '?'] do
      delete (Babble, length (Babble), 1); {eliminate trailing spaces & punctuation}
   Babble := concat (' ', Babble, ' ');    {so will fit in final string well}
end; {Conjugate}

{==1====1====1====1====1====1====1====1====1====1====1====1====1====1==}

procedure MakeReply (var Conj, Reply: LongStr; KeyNo: integer;
                     var KeyWords: KeyArray);
   {Formulates Eliza's reply to the user, using KeyNo as an index to
    what keyword was used, and possibly Conj to form part of the
    sentence from the user's own words.}

var Response:  Index;  {points to the "cycle" of responses for the keyword}

begin {MakeReply}
   Response := KeyWords [KeyNo].Concept^; {now points to "cycle"}
   Reply := Response^.Response; {the reply, possibly incomplete}
   KeyWords [KeyNo].Concept^ := Response^.Next; {next response in cycle}
   if pos ('*', Reply) > 0 then begin           {need part of user's entry}
      insert (Conj, Reply, pos ('*', Reply));   {add the user's response}
      Reply [pos ('*', Reply)] := ' ';          {replace "*" with a space}
   end; {if}
   Remove (Reply, '  ');
   Remove (Reply, ' !');
   Remove (Reply, ' ?');
   Remove (Reply, ' .');
   Remove (Reply, ' ,');
   Remove (Reply, '~');
end; {MakeReply}

{==0====0====0====0====0====0====0====0====0====0====0====0====0====0==}
{==0====0====0====0====0====0====0====0====0====0====0====0====0====0==}

begin {MultEliza}
   Initialize (KeyWords, Reply, Terminate, ConjPairs);
   loop
      Dialog (Putin, OldInput, Reply);
   exit if pos ('SHUT UP', Putin) > 0; {exits program if user says "shut up"}
      FindKeyword (Putin, Conj, KeyWords, KeyNo);
      Conjugate (Conj, ConjPairs);
      MakeReply (Conj, Reply, KeyNo, KeyWords);
   end; {loop}
   writeln; writeln (Terminate);
   writeln; write ('Press <RETURN> to exit: ');
   readln (Junk);
   curs_off;
end. {MultEliza}