Поиск одинаковых строк в текстовом файле

Question

Имеется база вида (Где есть повторяющиеся строки):

+Результат
+Ошибка
+Результат
+Результат
+Результат
+Ошибка
......

Нужно посчитать все повторяющиеся строки что расположены в текстовом файле и вывести отчет в Memo1. Результат должен получится в Memo1 такой:

+Результат - 4 раза
+Ошибка - 2 раза

То есть посчитать все одинаковые строки что есть в текстовом файле и статистику вывести в Memo1.

Предоставленный код работает быстро но вот при размерах файла в 600 мегабайт выдает сообщение о нехватке памяти. Ну это и понятно потому как мы все грузим в память.

procedure TForm1.Button1Click(Sender: TObject);
var
  TS: TStringList;
  s, OneWord: string;
  i, Cnt: integer;
begin
  TS := TStringList.Create;
  TS.Delimiter := '+';
  TS.LoadFromFile('baza.txt');
  s := TS.Text;
  TS.DelimitedText := s;

  if TS.Count = 0 then
  begin
    ShowMessage('Вообще ни одного слова нет!');
    Exit;
  end;

  TS.Sort;

  Memo1.Lines.Clear; // подготовим место для формирования отчёта

  // собственно подсчёт
  OneWord := TS.Strings[0];
  Cnt := 1;
  for i := 1 to TS.Count - 1 do
    if AnsiUpperCase(TS.Strings[i]) = AnsiUpperCase(OneWord) then
      inc(Cnt)
    else
    begin
      Memo1.Lines.Append(OneWord + '+' + InttoStr(Cnt));
      OneWord := TS.Strings[i];
      Cnt := 1;
    end;

  // для последнего слова в списке вывод результата
  Memo1.Lines.Append(OneWord + '+' + InttoStr(Cnt));

  FreeAndNil(TS); // освободим память
end;

Пробовала оформить код через AssignFile - чтение построчно но у меня тут ошибки. Помогите исправить ?

var
  TS: TStringList;
  s,st: string;
  i, Cnt: integer;
  f1: TextFile;
begin
  Memo1.Lines.Clear; // подготовим место для формирования отчёта

  // Открываем диалог выбора файла
  if not OpenDialog1.Execute then
    exit
  else
    AssignFile(f1, OpenDialog1.FileName);
  reset(f1);

  TS := TStringList.Create;
  TS.Delimiter := '+';
  s := TS.Text;
  TS.DelimitedText := s;
  TS.Sort;

  if TS.Count = 0 then
  begin
    ShowMessage('Вообще ни одного слова нет!');
    exit;
  end;

  While not EOF(f1) do
  begin
    // Что бы программа не подвисала
    Application.ProcessMessages();
    readln(f1, st);
    TS.Add(st);

    // собственно подсчёт
    st := TS.Strings[0];
    Cnt := 1;
    for i := 1 to TS.Count - 1 do
      if AnsiUpperCase(TS.Strings[i]) = AnsiUpperCase(st) then
        inc(Cnt)
      else
      begin
        Memo1.Lines.Append(st + '-' + InttoStr(Cnt));
        st := TS.Strings[i];
        Cnt := 1;
      end;

    // для последнего слова в списке вывод результата
    Memo1.Lines.Append(st + '-' + InttoStr(Cnt));

    FreeAndNil(TS); // освободим память

  end;

  TS.Free;
  CloseFile(f1);

end;

Answer 1

var
  Dict: TDictionary<string, integer>;
  f: TextFile;
  s:string;
  cnt: Integer;
  A: TArray<TPair<string, integer>>;
  p: TPair<string, integer>;
begin
  Dict := TDictionary<string, integer>.Create;
  AssignFile(f, 'e:\s.txt');
  Reset(f);
  while not EOF(f) do begin
    Readln(f, s);
    Dict.TryGetValue(s, cnt);
    Dict.AddOrSetValue(s, cnt + 1);
  end;
  CloseFile(f);
//  for s in dict.Keys do
//    Memo1.Lines.Add(s + ': ' +Dict.Items[s].ToString);
  A:=  Dict.ToArray;
   TArray.Sort<TPair<string, Integer>>(A,
    TComparer<TPair<string, Integer>>.Construct(
      function (const L, R: TPair<string, Integer>): Integer
      begin
        Result := -CompareStr(L.Key, R.Key);
      end)
  );
  for p in A do
    Memo1.Lines.Add(p.Key + ': ' + p.Value.ToString);
  Dict.Free;

БЛОГ НА HUSL

Поиск одинаковых строк в текстовом файле

Ответы (1 шт):