Обработка 1мб текста

[Macmeprag]

помогите пожалуйста нужно обработать 1мб текста за 1сек
"Дан файл, содержащий русский текст. Найти в тексте N<=2000 самых коротких слов, содержащих сочетание из трех алфавитно упорядоченных букв. Записать найденные слова в текстовый файл в порядке неубывания длины. Все найденные слова должны быть разными!"

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

uses
  SysUtils;
const
  Nmax=2000;
  Letters = ['А'..'Я','а'..'я','Ё','ё'];
  Separator = [#0..#255]-Letters;
type
  matrix = array[1..NMax] of ansistring;

function CompareWords(words : matrix;s : ansistring):boolean;
var
  i : integer;
begin
  result:=true;
  for i:=1 to NMax do
  if words[i]=s then begin
    result:=false;
    exit;
  end;
end;

function LettersOrder(s : ansistring):boolean;
var
  i : integer;
begin
  Result:=false;
  if Length(s)<3 then exit;
  for i:=Length(s) downto 1 do begin
    if i=2 then exit;
    if (s[i]>=s[i-1]) and (s[i-1]>=s[i-2]) then begin
      Result:=true;
      exit;
    end
  end;
end;

procedure Solve(var words : matrix);
var
  i,j : integer;
  s   : ansistring;
begin
  for i:=1 to NMax-1 do
    for j:=i+1 to NMax do
      if Length(words[i])>Length(words[j]) then  begin
        s:=words[i];
        words[i]:=words[j];
        words[j]:=s;
      end;
end;

procedure ReadData(var words : matrix);
var
  j         : integer;
  s         : ansistring;
  c         : ansichar;
  x         : boolean;
begin
  j:=1;
  x:=false;
  while not EoF do begin
    read(c);
    if c in Separator then begin
      if (s ='') then continue;
      if j>NMax then begin
        j := 1;
        x := true;
      end;
      if (LettersOrder(s)) and (CompareWords(words,s)) then begin
        if x and (Length(s)<Length(words[j])) then begin
          words[j]:=s;
          s:='';
          inc(j);
          continue;
        end;
        words[j]:=s;
        s:='';
        inc(j);
        continue;
      end;
      s:='';
      continue;
    end;
    s:=s+AnsiLowerCase(c);
  end;
end;

procedure PrintResult(var words:matrix);
var
  j : integer;
begin
  for j:=1 to NMax do begin
    if words[j]='' then continue;
    WriteLn(words[j]);
  end;
end;

var
  words   : matrix;
  t1,t2,t : real;

begin
  t1:=now;
  ReSet(input,'input.txt');
  ReWrite(output,'output.txt');
  ReadData(words);
  Solve(words);
  PrintResult(words);
  t2:=now;
  t:=t2-t1;
  WriteLn('Время выполнения:',t:10);
end.

с таким кодом для NMax=2000 как по условию выполняется 4.2 сек(
но есть еще и косяки((
1-й косяк в том что я что-то не оч понимаю как реализовать поиск самых коротких слов.
2-й косяк есть какой то косяк со словами, точнее откуда прога их берет, если взять NMax=10 то слова будут из разных концов текста..

[Macmeprag]

ну молодцы, никто не помог, раз с этим не можете помочь, может с поможете, как тут конкретно организовать бакет сорт?

[Serge_Bliznykov]

read(c);

вот так делать КАТЕГОРИЧЕСКИ не рекомендуется!
Как минимум, используйте SetTextBuf()
а лучше - использовать BlockRead

Хотя, раз уж Вы пишете под Delphi (используя типы данных, которых не было в Pascal), так используйте TStringList или TFileStream - скорость чтения возрастёт на порядок.

по поводу самого алгоритма ничего сказать не могу — тут думать надо

как тут конкретно организовать бакет сорт

Это Вы спрашиваете, как тему удалить?!
если да - то никак - только у модераторов есть такое право...

Удачи.

[Stilet]

Это Вы спрашиваете, как тему удалить?!

Не угадал.
вот что нужно: http://ru.wikipedia.org/wiki/%D0%91%...B2%D0%BA%D0%B0

[Macmeprag]

Это конечно все замечательно, только вот убрав сортировку вообще, я заметил что выиграть по времени можно только что-то около 5 сотых секунды)))
вот переработанный мой код..

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

uses
  SysUtils;
const
  Nmax=2000;
  Letters = ['А'..'Я','а'..'я','Ё','ё'];
  Separator = [#0..#255]-Letters;
type
  matrix = array[1..NMax] of ansistring;
  sequence = array [1..NMax] of integer;

function CompareWords(words : matrix;s : ansistring):boolean;
var
  i : integer;
begin
  result:=true;
  for i:=1 to NMax do
  if words[i]=s then begin
    result:=false;
    exit;
  end;
end;

function LettersOrder(s : ansistring):boolean;
var
  i : integer;
begin
  Result:=false;
  if Length(s)<3 then exit;
  for i:=Length(s) downto 1 do begin
    if i=2 then exit;
    if (s[i]>=s[i-1]) and (s[i-1]>=s[i-2]) then begin
      Result:=true;
      exit;
    end
  end;
end;

procedure Solve(var words : matrix; var lenarr : sequence);
var
  i,j,x : integer;
  s   : ansistring;
begin
  for i:=1 to NMax-1 do
    for j:=i+1 to NMax do
      if lenarr[i]>lenarr[j] then  begin
        s:=words[i];
        words[i]:=words[j];
        words[j]:=s;
        x := lenarr[i];
        lenarr[i] := lenarr[j];
        lenarr[j] := x;
      end;
end;

procedure ReadData(var words : matrix; var lenarr : sequence);
var
  j         : integer;
  s         : ansistring;
  c         : ansichar;
begin
  for j := 1 to NMax do lenarr[j] := 255;
  j := 0;
  while not EoF do begin
    read(c);
    if c in Separator then begin
      if (s ='') then continue;
      if j=NMax then j := 0;
      inc(j);
      if (Length(s)<lenarr[j]) and (LettersOrder(s))
      and (CompareWords(words,s)) then begin
        words[j]:=s;
        lenarr[j]:=length(s);
        s:='';
        continue;
      end;
      s:='';
      continue;
    end;
    s:=s+AnsiLowerCase(c);
  end;
end;

procedure PrintResult(var words:matrix);
var
  j : integer;
begin
  for j:=1 to NMax do begin
    if words[j]='' then continue;
    WriteLn(words[j]);
  end;
end;

var
  words   : matrix;
  lenarr  : sequence;
  t1,t2,t : real;

begin
  t1:=now;
  ReSet(input,'input.txt');
  ReWrite(output,'output.txt');
  ReadData(words, lenarr);
  Solve(words,lenarr);
  PrintResult(words);
  t2:=now;
  t:=t2-t1;
  WriteLn('Время выполнения:',t:10);
end.

вся проблема быстродействия в CompareWords..подскажите пожалуйста как уменьшить число ее вызовов или упростить её саму?
у меня программа сейчас за 1.4 сек прогоняется, у препода за 3.2, надо чтобы у него за 1.0((((
Очень нужна ваша помощь!

[Serge_Bliznykov]

Вы мой пост сознательно игнорируете?!
Прежде всего - откажитесь от чтения по одному символу или, хотя бы, добавьте SetTextBuf

p.s. Хотя, конечно, это не решит проблему оптимальности/неоптимальности самого алгоритма...

[Macmeprag]

Сообщение от Serge_Bliznykov

Вы мой пост сознательно игнорируете?!
Прежде всего - откажитесь от чтения по одному символу или, хотя бы, добавьте SetTextBuf

p.s. Хотя, конечно, это не решит проблему оптимальности/неоптимальности самого алгоритма...

Я Ваш пост не игнорирую, просто я не умею пользоваться такими методами, которые предлагаете, посимвольное считывание - самое быстрое что я могу.

[Serge_Bliznykov]

а написать SetTextBuf и нажать F1 - не догадались? Там и описание, и даже пример!


попробуйте добавть в Ваш код такие строчки (выделены цветом):

...
var
  words   : matrix;
  lenarr  : sequence;
  t1,t2,t : real;
  Buf: array[1..16384] of Char;
begin
  t1:=now;
  System.SetTextBuf(input, Buf);
  ReSet(input,'input.txt');
  ReWrite(output,'output.txt');
...

[Macmeprag]

как-то с ним ничего не изменилось)
Ф1 у меня кстати не работает)

[Serge_Bliznykov]

ну, чуть лучше так:

function LettersOrder(s : ansistring):boolean;
var
  i : integer;
begin
  Result:=false;
  if Length(s)<3 then exit;
  for i:=Length(s) downto 3 do begin
    if (s[i]>=s[i-1]) and (s[i-1]>=s[i-2]) then begin
      Result:=true;
      exit;
    end

и так:

function CompareWords(var  words : matrix;s : ansistring; Cnt : integer):boolean;
var
  i : integer;
begin
  result:=true;
  for i:=1 to Cnt  do
  if words[i]=s then begin
    result:=false;
    exit;
  end;
end;

а вызов, соответственно:

	
	
      (CompareWords(words,s, j-1)) then begin

но это всё у меня дало прирост скорости процентов 30-40...
Думаю, что для Вас этого маловато будет.
Думаю, что нужно менять сам алгоритм... (как - не знаю, ибо не олимпиец...)