[Back to MISC SWAG index] [Back to Main SWAG index] [Original]

    Program Eliza;

    { Command line:  Eliza_tp [path of Eliza.dat]

      The one command line parameter (optional) is the path where the file
      Eliza.dat can be found if not that file is not in the directory where
      Eliza_tp.exe is found.  }

    {$IFDEF Print}
    	Uses CRT, Printer;
    {$ELSE}
    	Uses CRT;
    {$ENDIF}

    Const
    	Key_Rec_headr_len = 12;
    	Reply_rec_headr_len = 5;

    Type
    	Key_Ptr   = ^Key_rec;							{Pointer to key record }
    	Reply_Ptr = ^Reply_rec;

    	Key_rec   = record                        { Key record stores the key phrase }
    					 Next_key_rec : Key_Ptr; 		{ 4 bytes }
    					 P_flag : byte;               { 1 byte  }
    					 Numb_Reply : integer;        { 2 bytes }
    					 Reply_list : Reply_Ptr;  	   { 4 bytes }
    					 Key_Str : String[16];	  	   { 1 byte (length) }
    				  end;                       		{ 12 bytes in header }

    	Reply_rec  = record                       { Reply record stores a response to the key phrase }
    						Next_reply_rec : Reply_Ptr; 	{ 4 bytes }
    						Reply_Str : String[120]; 		{ 1 byte (length) }
    					 end;                       		{ 5 bytes in header }

    	MaxStr = String[80];
    	Max_Dat_Len = String[120];

    Const
    	Top_Key : Key_Ptr = Nil; 						{ Initialize Pointer }
    	First_Key : Key_Ptr = Nil;						{ Initialize Pointer }
    	Curr_Key : Key_Ptr = Nil;						{ Initialize Pointer }
    	First_Reply : Reply_Ptr = Nil;				{ Initialize Pointer }
    	Curr_Reply : Reply_Ptr = Nil;					{ Initialize Pointer }
    	Number_Replies : Integer = 0;					{ Initialize count	}
    	P_Flag : Byte = 1;								{ Initialize }
    	FileName : String = 'Eliza.dat';				{ Name of data file  }

    Var
    	s	: Max_Dat_Len;
    	Input_String : MaxStr;
    	Rest_of_Input : MaxStr;
    	Old_Inp_Str : MaxStr;
    	Pronouns : Array[1..19,1..2] of String[12];
    	K_Last : Boolean;

    (*************************************************************************)

    Procedure Store_Key_Record(var Curr_Key : Key_ptr);

    { Store a key phrase into the threaded list of key phrases, to conserve memory
      the length of the key phrase is determined and only enough memory to store
      the phrase is obtained.              }

    Var
    	PktLen, Strlen : Integer;
    	Prev_Key : Key_ptr;

    Begin
    	Strlen := ord(s[0]);								{ Get Length of string}
    	PktLen := StrLen + Key_rec_headr_len;		{ Calculate size of packet }
    	Prev_Key := Curr_Key;							{ Save Pointer to previous }
    	GetMem(Curr_Key,PktLen);						{ Get Memory of PktLen Size }

    	If Top_Key = Nil then
    		begin
    			Top_Key := Curr_Key;						{ Base of threaded list }
    			First_Key := Curr_key;					{ First of this set of keys}
    			Prev_Key := Nil;							{ Initialize Prev_Key pointer }
    		end else
    			begin
    				if First_key = Nil then First_Key := Curr_key;	{ Start New Set of Keys}
    			end;

    	Curr_Key^.Key_Str := Copy(s,1,StrLen); { Copy string to packet }
    	Prev_Key^.Next_key_Rec := Curr_Key;
    	Curr_Key^.Next_key_Rec := Nil;
    	Curr_key^.Numb_Reply := 0;
    	Curr_key^.P_Flag := 1;
    	Curr_Key^.Reply_list := Nil;

    End;														{ End Store_Key_Record }

    (*************************************************************************)

    Procedure Store_Reply_Record(var Curr_Reply : Reply_ptr);

    { Key phrases are grouped together followed by replies to those phrases.
      For each group of key phrase there is one or more replies.  The possible
      replies to a key phrase are threaded to the packet on the threaded list of
      key phrases.

      key1
    	|
      \ /
      key2 ----> reply_a
    	|         |
    	|        \ /
    	|         reply_b
    	|         |
    	|        \ /
    	|         reply_c
    	|         |
    	|			\ /
    	|         etc.; thread of all replies to key1
      \ /
    	key3  ----> reply_d
    	|           |
    	|          \ /
    	|           etc.; thread of all replies to key2
      \ /
    	etc.; thread of all key phrase groups                    }

    Var
    	PktLen, Strlen : Integer;
    	Prev_Reply : Reply_ptr;

    Begin
    	Strlen := ord(s[0]);								{ Get Length of string}
    	PktLen := StrLen + Reply_rec_headr_len;	{ Calculate size of packet }
    	Prev_Reply := Curr_Reply;						{ Save Pointer to previous }
    	GetMem(Curr_Reply,PktLen);						{ Get Memory of PktLen Size }

    	If (Top_Key = Nil) or (First_Key = Nil) then
    		begin
    		Writeln('* * * E R R O R * * * Reply found before first key')
    		end else
    			begin
    				if First_Reply = Nil then First_Reply := Curr_Reply;	{ Start New Set of Keys}
    			end;

    	Curr_Reply^.Reply_Str := Copy(s,1,StrLen); { Copy string to packet }
    	Prev_Reply^.Next_Reply_Rec := Curr_Reply;
    	Curr_Reply^.Next_Reply_Rec := Nil;
    	Number_Replies := Number_Replies + 1;

    End;                                { End of Store_Reply_Record }

    (*************************************************************************)

    Procedure Thread_Reply;					{ Thread Replies to Keys }

    Var
    	Curr_Ptr : Key_Ptr;

    Begin
    	Curr_Ptr := First_Key;			{ Point to First Key }

    	While Curr_Ptr <> Nil do
    		Begin
    			Curr_Ptr^.Numb_Reply := Number_Replies;
    			Curr_Ptr^.Reply_list := First_Reply;
    			Curr_Ptr := Curr_Ptr^.Next_key_rec;
    			Curr_Ptr^.P_Flag := P_Flag;
    		End;

    	First_Reply := Nil;
    	Number_Replies := 0;
    	First_Key := Nil;

    End;

    (*************************************************************************)

    Procedure Input_data;

    { Reads the file Eliza.dat which contains the key phrases and the replies
      to those key phrases.  This file is an ASCII file.  Each key phrase must
      be immediately followed by all possible replies to the phrase. The field ID
      identies the "type" of the record. There four types, see case statement
      below, (note that an cross-hatch allows you to put whitespace and comments in
      the file.	}

    Var
    	InputFile : Text;
    	ID : char;
    	b : char;                        { Char to skip blank when reading }
    	IOCode, Len : Integer;
    	Path : String;

    Begin;
    	Path := ParamStr(1);					{ 1 parameter is expected: the path where
    												  Eliza.dat will be found }
    	FileName := Path + FileName;		{ Concatenate Path and File Name }

    {$IFDEF Test}
    	Writeln('Path = ',Path, '  File Name = ',FileName);
    {$ENDIF}

    	Assign(InputFile,FileName);	   { Assign input file name }
    	Reset(InputFile);						{ Prepare InputFile to be read }
    	IOCode := IOresult;					{ Save the return code }

    	if IOCode = 0 then
    	begin
    		While Not EOF(Inputfile) do		{ Read Until End of File }
    			begin
    				Readln(InputFile,s);			{ Read Data };
    				If IOResult <> 0 then Writeln('I/O Error, code = ',IOResult);
    				ID := s[1];
    				Len := Length(s);
    				If Len > 2 then s := Copy(s, 3, Len-2);
    				If s[1] <> ' ' Then s := ' ' + s;		{ add a leading blank }
    				If s[Length(s)] <> ' ' Then s := s + ' '; { add a trailing blank }
    				case ID of
    					'K' :  begin
    								If First_Reply <> Nil Then Thread_Reply;
    								Store_Key_Record(Curr_Key);		{ Call Procedure to store key }
    							 end;
    					'R' : Store_Reply_Record(Curr_Reply);	{ Call procedure to store reply }
    					'P' : P_Flag := 0;
    					'#' :
    				else
    					Writeln('Error reading Eliza.dat, invalid record ID');
    					Writeln('RECORD: ',s);
    				end;
    			end;   			{ End of while }

    		If IOResult <> 0 then Writeln('I/O Error, code = ',IOResult);
    		If First_Reply <> Nil Then Thread_Reply;
    	end;
    end;

    (*************************************************************************)

    Function UpCaseStr(s : MaxStr) : MaxStr;		{ Convert String to all uppper Case }
    Var
    	i,j : Integer;
    Begin
    	j := Ord(s[0]);
    	For i := 1 to j Do
    		s[i] := Upcase(s[i]);
    	UpCaseStr := s;
    End;

    (*************************************************************************)
    Procedure Replace_Pronouns(var Rest_of_Input : MaxStr);

    Const
    	Init : Boolean = True;

    Var
    	i, l, L1 ,Len : integer;
    	Str : MaxStr;

    Begin
    	If Init then
    		Begin
    			{ all pronouns in column 1 must     all pronouns in column 2 must
    					be UPPER CASE                      be lower case
    					-------------							  -------------
    					column 1 pronouns are replace by the column 2 entry    }

    			Pronouns[1,1] := 'MY SELF';  		Pronouns[1,2] := 'your self';
    			Pronouns[2,1] := 'YOURSELF';		Pronouns[2,2] := 'my self';
    			Pronouns[3,1] := 'YOURSELVES';	Pronouns[3,2] := 'ourselves';
    			Pronouns[4,1] := 'OURSELVES';		Pronouns[4,2] := 'yourselves';
    			Pronouns[5,1] := ' YOU ARE ';		Pronouns[5,2] := ' i am ';
    			Pronouns[6,1] := ' I AM ';			Pronouns[6,2] := ' you are ';
    			Pronouns[7,1] := ' WERE ';			Pronouns[7,2] := ' was ';
    			Pronouns[8,1] := ' WAS ';			Pronouns[8,2] := ' were ';
    			Pronouns[9,1] := ' YOUR ';			Pronouns[9,2] := ' my ';
    			Pronouns[10,1] := ' I''VE ';		Pronouns[10,2] := ' you''ve ';
    			Pronouns[11,1] := ' YOU''VE ';	Pronouns[11,2] := ' i''ve ';
    			Pronouns[12,1] := ' I''M';			Pronouns[12,2] := ' you''re ';
    			Pronouns[13,1] := ' YOU''RE ';	Pronouns[13,2] := ' i''m ';
    			Pronouns[14,1] := ' AM ';			Pronouns[14,2] := ' are ';
    			Pronouns[15,1] := ' ARE ';			Pronouns[15,2] := ' am ';
    			Pronouns[16,1] := ' I ';			Pronouns[16,2] := ' you ';
    			Pronouns[17,1] := ' YOU ';			Pronouns[17,2] := ' i ';
    			Pronouns[18,1] := ' ME ';			Pronouns[18,2] := ' you ';
    			Pronouns[19,1] := ' MY ';			Pronouns[19,2] := ' your ';

    		Init := False;
    	End;

    	For i := 1 to 19 Do
    	Begin
    		Len := Length(Pronouns[i,1]);
    		L := Pos(Pronouns[i,1],Rest_of_Input);

    		While L <> 0 Do
    			Begin
    					Delete(Rest_of_Input,L,Len);						{ Delete the Pronouns}
    					Insert(Pronouns[i,2],Rest_of_Input,L);
    					L := Pos(Pronouns[i,1],Rest_of_Input);
    			End;

    	 End;
        Delete(Str,1,1);
    	 Rest_of_Input := UpCaseStr(Rest_of_Input);
    End;

    (*************************************************************************)

    Procedure Find_key( Input_String : MaxStr;var Curr_Ptr : Key_Ptr; var K_Last : Boolean);	{ Find Keys }

    Var
    	Prev_Ptr : Key_Ptr;
    	L,Start,Len : Integer;

    Begin
    	L := 0;
    	Prev_Ptr := Nil;
    	Curr_Ptr := Top_Key;						{ Point to First Reply }

    	While (Curr_Ptr <> Nil) and (L = 0) do
    		Begin
    			L := Pos(Curr_Ptr^.Key_str,Input_String);
    			If L <> 0 then
    				Begin
    					Len := Length(Input_String) - L - 1;
    					Start := L + Length(Curr_Ptr^.Key_str); { copy rest of string, but not space }
    					Rest_of_Input := Copy(Input_String,Start,Len);
    					Prev_Ptr := Curr_Ptr;
    					Curr_Ptr := Nil;		 				{ Force exit from loop }
    				End else
    					Begin
    						Prev_Ptr := Curr_Ptr;
    						Curr_Ptr := Curr_Ptr^.Next_key_rec;
    					End;
    			End;			{ end of while }

    	If Curr_Ptr = Nil then Curr_Ptr := Prev_Ptr;
    	K_Last := False;
    	If (Pos(Curr_Ptr^.Key_Str,'Klast') <> 0) then K_Last := True;
    End;

    (*************************************************************************)

    Procedure Build_Reply(Input_String : MaxStr; var Numb_Replies : Integer; var P_Flag : Byte);

    Const
    	Ast : String[1] = '*';
    	Blank : String[1] = ' ';

    Var
    	I, Rand, L : Integer;
    	RRand : Real;
    	Curr_Reply_Ptr : Reply_Ptr;
    	Curr_Ptr : Key_Ptr;

    Begin
    	Rest_of_Input := Input_String;
    	RRand := Random;												{ Generate a Random number }

    	If P_Flag = 82 then Find_Key('KY', Curr_Ptr, K_Last)
    		Else If (RRand < 0.03) then Find_Key('KZ', Curr_Ptr, K_Last) 	{ 3% of the time pick KZ key }
    			Else Find_Key(Input_String, Curr_Ptr, K_Last);

    	Rand := Random(Curr_Ptr^.Numb_Reply);
    	Numb_Replies := Curr_Ptr^.Numb_Reply;
    	Curr_Reply_Ptr := Curr_Ptr^.Reply_list;

    { Loop to reply selected by random number }

    	If Rand <> 0 then
    		Begin
    			For I := 1 to Rand Do
    					Curr_Reply_Ptr := Curr_Reply_Ptr^.Next_Reply_Rec;
    		End;

    	s := Curr_Reply_Ptr^.Reply_str;	{ Save Reply }
    	If P_Flag = 82 then Rest_of_Input := Input_String;
    	L := Length(Rest_of_Input);
    	If L > 0 then
    		if (Rest_of_Input[L-1] = '?') or (Rest_of_Input[L-1] = '.') then
    			Delete(Rest_of_Input,L-1,1);               { Delete the punctuation }

    	{ Does the reply contain an asterisk? }
    	L := Pos(Ast,s);
    	If L <> 0 Then
    		Begin
    			Delete(s,L-1,2);				{ Delete the  * }
    			L := L - 1;						{ Adjust for deletions }
    			If ((Length(s) - L) >= 0) then
    				Begin
    					if (Rest_of_Input[1] <> ' ') then Rest_of_Input := ' ' + Rest_of_Input;
    					if (s[L] = ' ') then Delete(s,L,1);
    					Replace_Pronouns(Rest_of_Input);
    					if Rest_of_Input[Ord(Rest_of_Input[0])] = ' ' then
    							Delete(Rest_of_Input,Ord(Rest_of_Input[0]),1);
    					Insert(Rest_of_Input,s,L);
    					if (s[L+Length(Rest_of_Input)] <> '?') and
    						(s[L+Length(Rest_of_Input)] <> '.') and
    						(s[L+Length(Rest_of_Input)] <> '!') and
    						(s[L+Length(Rest_of_Input)] <> ' ') then
    					Insert(blank,s,L+Length(Rest_of_Input));      { if not punctuation then insert a blank }
    				End;
    		End;

    	P_Flag := Curr_ptr^.P_Flag;

    {$IFDEF Test}
    	Writeln(s);
    	Writeln('Found key ',Curr_Ptr^.Key_str,' in string ');
    	Writeln(Input_String,' at byte ',L);
    {$ENDIF}

    End;

    (*************************************************************************)
    {		MAIN Routine																		  }

    Const
    	P1 : Boolean = False;

    Var
    	Numb_Replies : Integer;
    	Old_s : MaxStr;
    	Save_Input_String : MaxStr;

    Begin
    	ClrScr;
    	Randomize;								{ Initialize Seed }

    {$IFDEF Test}
    	WriteLn(MemAvail, ' bytes available at start');
    	WriteLn('Largest Free Block ', MaxAvail, ' bytes at start');
    {$ENDIF}

    	Input_data;								{ Read Data and InitializeKey and Reply lists }
    	WriteLn('Hello, I''m your computerized psychiatrist. What is your problem?');

    	Repeat
    			Old_Inp_Str := Input_String;
    			Readln(Input_String);
    			Input_String := ' ' + UpCaseStr(Input_String) + ' ';
    			If Old_Inp_Str = Input_String then WriteLn('DON''T REPEAT YOURSELF')
    				else If (Pos('BYE',Input_String) = 0) and (Pos('GOODBY',Input_String) = 0) Then
    						  Begin
    							 Old_s := s;
    							 Build_Reply(Input_String, Numb_Replies, P_Flag);
    							 If (Numb_Replies > 1) and (s = Old_s) then
                            Build_Reply(Input_String, Numb_Replies, P_Flag);
    							 If (Random < 0.25) and (P_Flag <> 0) then
    								Begin
    									P1 := True;
    									Save_Input_String := Input_String;
    								End
    							 Else if (K_Last and P1) Then
    								Begin
    									P1 := False;
    									P_Flag := 82;
    									Build_Reply(Save_Input_String, Numb_Replies, P_Flag);
    								End;
    							 WriteLn(s);

    							 {$IFDEF Print}
    								Writeln(Lst,Input_String);
    								Writeln(Lst,s);
    							 {$ENDIF}

    						  End;
    	Until (Pos('BYE',Input_String) <> 0) or (Pos('GOODBY',Input_String) <> 0);

    	Writeln('Its been good talking with you. Whenver you feel a need to talk stop by again.');
    	Delay(1500);

    {$IFDEF Test}
    	WriteLn(MemAvail, ' bytes available at end');
    	WriteLn('Largest Free Block ', MaxAvail, ' bytes at end');
    {$ENDIF}

    End.

[Back to MISC SWAG index] [Back to Main SWAG index] [Original]