вот она элиза, тупит сильно.. Code: {$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
