[FAZA]

Программа для N равного 1000 работает 7 секунд, надо 2. Входной текстовый файл большой 1МБ.

Код:

program Project2;



{$APPTYPE CONSOLE}
{$R+,Q+,I+}

uses
  SysUtils;
const a='а';
const Wmin =1000;
const ABC=['а'..'я', 'А'..'Я','ё','Ё'];

Function EqualWord(n:string; w: array of string; i:integer):boolean; //проверяет выходном массиве w есть ли такое слово n
var l:integer;
begin
  result:=true;
  for l:=1 to i do
    if ansilowercase(w[l])=ansilowercase(n) then result:=false;
end;

Function ShortestWord (w:string;z:array of string; k:integer):boolean; // Проверяет есть ли в массиве z cлова которые длиннее входного слова w
var i:integer;
begin
  Result:=false;
  if z[1]='' then result:=true;
  for i:=k downto 1 do
    if length(z[i])>length(w) then begin
      Result:=true;
      exit;
    end;
end;

Procedure InsertWord(w:string;var z:array of string; var k:integer); //  проверяем куда нам нужно вставить слово w и вставляет по неубыванию длины
var prev,d:string;
    i:integer;
begin
  prev:=w;
  for i:=k downto 1 do begin
    if length(z[i])<length(prev) then begin
      d:=z[i];
      z[i]:=prev;
      z[i+1]:=d;
    end;
  end;
end;

Function Letter(w:string;a:char):boolean; // Проверяет содержит ли слово два раза заданную букву
var  i,j   : integer;
begin
  j:=0;
  Result:=false;
  for i:=1 to length(w) do
    if w[i]=a then inc(j);
  If j=2 then result:=true;
end;
 {#34.Дан файл, содержащий русский текст. Найти в тексте N<=2000 самых коротких слов,
 содержащих 2 раза заданную букву. Записать найденные слова в текстовый файл в
 порядке неубывания длины. Все найденные слова должны быть разными!}
var
    i,j,k : integer;
    s:string;
    z: array [1..2000] of string;//массив найденных слов
    w: array [1..100] of string; //массив слов теущей строки
begin

  rewrite (output, 'output.txt');
  reset (input, 'input.txt');
  while not seekeof do begin
    readln(s);
    s:=s+' ';
    i:=1;
    j:=0;
    while i<=length(s) do begin
      if s[i] in ABC then begin
        inc(j);
        w[j]:='';
        while s[i] in ABC do begin
          w[j]:=w[j]+s[i];
          inc(i);
        end;
        inc(i);
      end
      else inc (i);
    end;
    k:=Wmin;
    for i:=1 to j do begin
      if (Letter(w[i],a)) and (EqualWord(w[i],z,k)) and (ShortestWord(w[i],z,k)) then InsertWord(w[i],z,k);
    end;
 end;
 for i:=1 to Wmin do
   If z[i]<>'' then writeln (z[i],' ');
end.