{$M 16384,0,655360}
Program Eliza_AI; {Released to the Public Domain 4/22/93 by Ed T. Toton III}

{	This is a pascal implementation of the ever popular Eliza program.	}
{ I realize that this version is a bit larger and more complicated than	}
{ it needs to be, but it has some interesting features. You will want to   }
{ note that since the actual communication routine returns the output	  }
{ by way of a string, you can add whatever interface you like. Right now   }
{ it is simply using standard DOS I/O channels, thus allowing it to work   }
{ through many BBS's, and on basically any system.						 }
{																		  }
{	Please distribute freely. Enjoy!									  }
{																		  }

uses dos;

const
 maxxx	  =60;
 max_keys   =400;

type
 cluster_type=array[1..max_keys,1..2] of integer;
 keyword_type=array[1..max_keys] of string[20];
 response_type=array[1..600] of string[79];
 strl		=string;

var
 in_str,outstr:strl;
 i,j,k,l,n,m,x:integer;
 quit:boolean;
 last_char:char;
 maxx:byte;
 name,questn:string;
 cluster:^cluster_type;
 keyword:^keyword_type;
 responses:^response_type;
 num_keys:integer;
 regs:registers;


function ltrim(s1:string):string;
var	  {removes spaces on left side of a string}
 i:integer;
begin
 while (length(s1)>0) and ((copy(s1,1,1)=' ') or (copy(s1,1,1)=#8)) do
   s1:=copy(s1,2,length(s1)-1);
 ltrim:=s1;
end;


function rtrim(s1:string):string;
var	  {removes spaces on right side of a string}
 i:integer;
begin
 while (length(s1)>0) and ((copy(s1,length(s1),1)=' ') or (copy(s1,length(s1),1)=#8)) do
   s1:=copy(s1,1,length(s1)-1);
 rtrim:=s1;
end;


function btrim(s1:string):string;
begin	{removes spaces on both sides of a string}
 btrim:=ltrim(rtrim(s1));
end;


function lstr(s1:string; l:integer):string;
begin	{returns left end of string, length l}
 if length(s1)<=l then lstr:=s1
				  else lstr:=copy(s1,1,l);
end;


function rstr(s1:string; l:integer):string;
begin	{returns right end of string, length l}
 if length(s1)<=l then rstr:=s1
				  else rstr:=copy(s1,length(s1)-l+1,l);
end;


procedure getkey(var c:char);
begin	 {read a single key from DOS}
 with regs do
   begin
	ax:=$0800;
	msdos(regs);
	c:=chr(ax and $00ff);
   end;
end;


procedure prompt(i:strl);
var	   {output string one character at a time}
 c:integer;
begin
 for c:=1 to length(i) do
   write(i[c]);
end;


procedure nl;
begin	 {carriage return+line feed}
 prompt(chr(13)+chr(10)); x:=1;
end;


function timer:real;
var	  {Time of day in seconds}
 h,m,s,t:word;
begin
 GetTime(h,m,s,t);
 timer:=h*3600+m*60+s+t/100;
end;


Function ucase(s:string):string;
var	  {turn a string to all CAPS}
 i:integer;
begin
 if length(s)>=1 then
   for i:=1 to length(s) do
	s[i]:=upcase(s[i]);
 ucase:=s;
end;


Function lcase(s:string):string;
var	  {turn a string to all lower case}
 i:integer;
begin
 if length(s)>=1 then
   for i:=1 to length(s) do
	if (ord(s[i])>=65) and (ord(s[i])<=90) then s[i]:=chr(ord(s[i])+32);
 lcase:=s;
end;


procedure _input(var i:strl; ml:integer; up,echo,x:boolean);
var	   {read in a string from keyboard. ml=Max-Length
										   up=uppercase input
										   echo=show to screen what's typed?
										   x=show only X's, for passwords etc}
  cp:integer;
  c:char;
  r:real;
begin
	 r:=timer;
	 cp:=1;
	 repeat
	  getkey(c);
	  if c=#1 then r:=timer;
	  if up then c:=upcase(c);
	  if (c>=' ') and (c<chr(127)) then
	   if cp<=ml then
		begin
		 i[cp]:=c;
		 cp:=cp+1;
		 if echo then
		  if not x then prompt(c)
			 else prompt('X');
		end
	   else
	  else
	   case ord(c) of
		 8:if cp>1 then
			begin
			 c:=chr(8);
			 if echo then prompt(#8#32#8);
			 cp:=cp-1;
			end;
		24:while cp<>1 do
			begin
			 cp:=cp-1;
			 if echo then prompt(#8#32#8);
			end;
	   end;
	 until (c=#13) or (c=#14);
	 i[0]:=chr(cp-1);
end;



procedure print(s:string);
		  {print a string using word-wrap}
var
 i,j,k,l,n:integer;
 lo:longint;
begin
	i:=1; l:=0; k:=i;
	repeat
	 j:=0; k:=i;
	 repeat
	  inc(k); inc(j);
	 until (k>length(s)) or (s[k]=#32);
	 lo:=maxx; lo:=lo-x; lo:=lo-1;
	 if j>lo then
	   begin
		 nl; x:=1;
	   end;
	 for n:=i to i+j-1 do
	  begin
	   if (last_char in ['-','.',',','?','!',';',':']) and
		  (s[n] in ['a'..'z']) and (n=1) then s[n]:=chr(ord(s[n])-32);
	   if (x<>1) or (s[n]<>#32) then prompt(s[n]);
	   inc(x);
	   if s[n]<>' ' then last_char:=s[n];
	  end;
	 i:=i+j;
	until i>=length(s);
	prompt(' '); inc(x);
end;




function get_input:strl;
		 {Get a sentence, keep doing so until something is actually typed}
var
 s:strl;
begin
 repeat
   prompt('>');
   _input(s,75,false,true,false); nl;
   get_input:=s; s:=btrim(s);
 until s<>'';
end;



procedure reverse(var s:strl);
		  {conjugate a string}
var
 i,k:integer;
begin
 i:=0;
 while i<length(s) do
  begin
   inc(i);
   if ucase(copy(s,i,5))=' I''M '		then begin s:=lstr(s,i-1)+' you''re'	+rstr(s,length(s)-(i+1)); inc(i); end;
   if ucase(copy(s,i,6))=' I AM '		then begin s:=lstr(s,i-1)+' you are'	+rstr(s,length(s)-(i+2)); inc(i); end;
   if ucase(copy(s,i,8))=' YOU''RE '	 then begin s:=lstr(s,i-1)+' I''m'	   +rstr(s,length(s)-(i+4)); inc(i); end;
   if ucase(copy(s,i,9))=' YOU ARE '	 then begin s:=lstr(s,i-1)+' I am'	   +rstr(s,length(s)-(i+5)); inc(i); end;
   if ucase(copy(s,i,6))=' AM I '		then begin s:=lstr(s,i-1)+' are you'	+rstr(s,length(s)-(i+2)); inc(i); end;
   if ucase(copy(s,i,9))=' AREN''T I '   then begin s:=lstr(s,i-1)+' aren''t you'+rstr(s,length(s)-(i+5)); inc(i); end;
   if ucase(copy(s,i,9))=' ARE YOU '	 then begin s:=lstr(s,i-1)+' am I'	   +rstr(s,length(s)-(i+5)); inc(i); end;
   if ucase(copy(s,i,12))=' AREN''T YOU 'then begin s:=lstr(s,i-1)+' aren''t I'  +rstr(s,length(s)-(i+8)); inc(i); end;
   if ucase(copy(s,i,3))=' I '		   then begin s:=lstr(s,i-1)+' you'		+rstr(s,length(s)-(i-1)); inc(i); end;
   if ucase(copy(s,i,5))=' YOU '		 then begin s:=lstr(s,i-1)+' me'		 +rstr(s,length(s)-(i+1)); inc(i); end;
   if ucase(copy(s,i,4))=' ME '		  then begin s:=lstr(s,i-1)+' you'		+rstr(s,length(s)-(i+0)); inc(i); end;
  end;
end;




procedure load_stuff;
		  {load the keywords and responses}
var
 f:text;
 s1,s2:string;
 i,j,k,l,n:integer;
begin
 num_keys:=0;
 for i:=1 to max_keys do
  for k:=1 to 2 do
   cluster^[i,k]:=0;
 assign(f,'Eliza.dat');
 reset(f); i:=0; j:=0; k:=0; l:=0;
 while not eof(f) do
  begin
   inc(i);
   repeat
	readln(f,s1);
	s1:=btrim(ucase(s1));
	if s1<>'!' then
	 begin inc(j); keyword^[j]:=s1; cluster^[j,1]:=k+1; inc(num_keys); end;
   until s1='!';
   repeat
	readln(f,s1);
	s1:=btrim(ucase(s1));
	if s1<>'.' then
	 begin inc(k); responses^[k]:=s1; end;
   until s1='.';
   for n:=l+1 to j do
	cluster^[n,2]:=k;
   l:=j;
  end;
 close(f);
end;



function clip(s:strl; l:integer):strl;
		 {remove l characters from left end of a string}
begin
 clip:=rstr(s,length(s)-l);
end;



Procedure punctuate(var s:strl);
		  {check for punctuation, if none then add it}
begin
 if not (s[ord(s[0])] in ['.','?','!']) then s:=s+'.';
 s:=s+' ';
end;




function find_word(s1,s2:string):boolean;
		 {find word s1 in string s2}
var
 i,j,k,l,n,m:integer;
 ok:boolean;
begin
 s2:=btrim(ucase(s2)); s1:=btrim(ucase(s1));
 ok:=false;
 if s1=s2 then ok:=true;
 if (lstr(s1,length(s2))=s2) and (not (s1[length(s2)+1] in ['A'..'Z','a'..'z'])) then ok:=true;
 if (rstr(s1,length(s2))=s2) and (not (s1[length(s1)-length(s2)] in ['A'..'Z','a'..'z'])) then ok:=true;
 i:=1;
 if not ok then
  while i<length(s1)-length(s2)-1 do
   begin
	inc(i);
	if (copy(s1,i,length(s2))=s2) and
	   (not (s1[i-1] in ['A'..'Z','a'..'z'])) and
	   (not (s1[i+length(s2)] in ['A'..'Z','a'..'z']))
	   then ok:=true;
   end;
 find_word:=ok;
end;



function findstr(s1,s2:string):integer;
		 {find string s1 in string s2, and return position}
var
 i,j,k,l:integer;
begin
 if length(s1)>length(s2) then
  begin findstr:=0; exit; end;
 for i:=1 to length(s2)-length(s1)+1 do
  begin
   if (ucase(copy(s2,i,length(s1)))=ucase(s1)) and
	  ((i=1) or (not (s2[i-1] in ['A'..'Z','a'..'z']))) and
	  ((i>length(s2)-length(s1)) or (not (s2[i+length(s1)] in ['A'..'Z','a'..'z']))) then
	begin findstr:=i; exit; end;
  end;
 findstr:=0;
end;



procedure eliza(var os:strl);
		  {Eliza herself!}
var
 i,k,j,l,n:integer;
 s1,s2:strl;
 {ss:strl;}
begin
 repeat
  if (in_str[ord(in_str[0])] in [',','.','?','!','/',':',';']) then
	 in_str[0]:=chr(ord(in_str[0])-1);
 until not (in_str[ord(in_str[0])] in [',','.','?','!','/',':',';']);
 i:=0; k:=0; j:=0; l:=0; n:=1;
 while (i<num_keys) and (k=0) do
  begin
   inc(i);
   k:=findstr(keyword^[i],in_str);
  end;
 s1:=ucase(rstr(in_str,length(in_str)-k-length(keyword^[i])));
 reverse(s1);
 i:=random(cluster^[i,2]-cluster^[i,1]+1)+cluster^[i,1];
 s2:=responses^[i];
 if rstr(s2,1)='*' then s2:=lstr(s2,length(s2)-1)+' '+s1;
 {s2:=case_fix(lcase(s2));}
 if (ucase(lstr(s2,5))='WOULD') or (ucase(lstr(s2,5))='COULD') or
	(ucase(lstr(s2,3))='DID')   or (ucase(lstr(s2,3))='WHY')   or
	(ucase(lstr(s2,4))='WHAT')  or (ucase(lstr(s2,4))='WHEN')  or
	(ucase(lstr(s2,5))='WHERE') or (ucase(lstr(s2,5))='WOULD') or
	(ucase(lstr(s2,2))='DO')	or (ucase(lstr(s2,2))='IS')	or
	(ucase(lstr(s2,4))='HAVE')  or (ucase(lstr(s2,6))='SHOULD') then
	s2:=s2+'?';
 os:=s2;
end;



procedure get_response;
		  {get a response}
begin
 x:=1; in_str:=btrim(in_str);
 outstr:='I don''t fully understand. ';
 if in_str='' then begin outstr:='Speak up.'; exit; end;
 eliza(outstr); {outstr:=btrim(outstr);}
 punctuate(outstr);
end;



procedure do_response;
begin
 prompt('- '); x:=3;
 get_response; print(outstr); nl;
end;



procedure init;
begin
 if maxavail<40000 then
  begin
   writeln('Insufficient memory, need ',40000-maxavail,' more bytes.');
   halt(1);
  end;
 new(cluster); new(keyword); new(responses);
 nl; writeln('----ELIZA---- 1993, Ed T. Toton III');
 nl; nl; x:=1; maxx:=50;
 print('Hold on one moment while I do something. I''ll be right back. ');
 load_stuff; print('I''m back. ');
 nl; nl; quit:=false;
 x:=1; maxx:=maxxx;
 x:=1; nl; nl;
 print('- Greetings! Whenever you wish to leave, simply say "BYE". '
	  +'But first, what do you want to talk about? Or maybe you '+
	  'should tell me a little about yourself first?');
end;



procedure shutdown;
begin
 nl; print('- Goodbye! See you later!'); nl; x:=1;
 maxx:=57; nl;
end;



begin	{MAIN}
 init;
 repeat
  nl; nl; 
  in_str:=get_input;
  nl; in_str:=btrim(in_str);  nl;
  if (ucase(in_str)='BYE') or (upcase(in_str[1])='Q') then quit:=true
   else
	do_response; 
 until quit; x:=1;
 shutdown;
end.