| mrVoodoo |
13.02.2009 20:55 |
вот она элиза, тупит сильно..
Код:
{$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.
elize.dat |
