пробовала решить... но что-то не получается....
program Project2;
uses
SysUtils;
const E='F:\Documents and Settings\Àííà\Ðàáî÷èé ñòîë\file.txt';
type
TWords = array[1 .. 100] of string[100];
TDelimiter = set of Char;
var F,F1:Text;
i,count:Word;
words:TWords;
a,l,k,max:byte;
s:string;
function GetWords(s: string; var mas: TWords; delimiters: TDelimiter): Byte;
var i, p: Byte;
begin
for i := 1 to Length(s) do
if s[i] in delimiters then s[i] := #32;
repeat
p := Pos(' ', s);
if p > 0 then Delete(s, p, 1);
until p = 0;
if s[1] = ' ' then
Delete(s, 1, 1);
If s[Length(s)] = ' ' then
Delete(s, Length(s), 1);
i := 0;
repeat
p := Pos(' ', s); Inc(i);
if p > 0 then begin
mas[i] := Copy(s, 1, Pred(p)); Delete(s, 1, p)
end
else mas[i] := s;
until p = 0;
GetWords := i;
end;
begin
Assign(F,E);
{$I-} Reset(F); {$I+}
If IOResult <> 0 Then
Writeln('Fajl ne moget byt otkryt...')
Else
Begin
max:=1;
k:=1;
while not Eof(F) do
begin
readln(F,s[k]);
count:=GetWords(s,words,[]);
if count>max then
begin
max:=count;
l:=k;
end;
Inc(k);
end;
a:=k;
Rewrite(F1);
for i:=1 to a do
begin
count:=GetWords(s[i],words,[]);
if max=count then
writeln(F1,s[i]);
end;
Close(F);
Close(F1);
End;
readln;
end.