[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]