Определить сколько раз слово встречается в файлах.

[McFrey]

Доброго времени суток уважаемые программисты.
Есть проблема....
Допустим есть некая структура вида:

Термин // doc_id
абра // 1
кадабра // 1
крибли // 2
крабли // 1
крабли // 1
бумс // 3

Это можно организовать записью или через TStringList. А вопрос вот в чем...
как определить какой термин сколько раз встречается в каком файле (в примере 3 файла и 5 терминов, в жизни txt файл размером 10mb)...
На выходе я хочу получить примерно такую штуку:
термин, id_doc, сколько раз
абра, 1, 1
кадабра, 1, 1
....
крабли, 1, 2

[BDA]

procedure TForm1.Button1Click(Sender: TObject);
var
  ts: tstringlist;
  i, count, tmp: integer;
begin
  ts := tstringlist.Create;
  ts.Text := Memo1.Text;
  ts.Sorted := true;
  count := 1;
  Memo2.Lines.BeginUpdate;
  Memo2.Clear;
  for i := 0 to ts.count - 2 do
    if ts[i] = ts[i + 1] then
      inc(count)
    else
    begin
      tmp := pos(' // ', ts[i]);
      Memo2.Lines.Append(copy(ts[i], 1, tmp) + ', ' + copy(ts[i], tmp + 4,
          length(ts[i]) - tmp - 3) + ', ' + inttostr(count));
      count := 1;
    end;
  if ts.count > 0 then
  begin
    i := ts.count - 1;
    tmp := pos(' // ', ts[i]);
    Memo2.Lines.Append(copy(ts[i], 1, tmp) + ', ' + copy(ts[i], tmp + 4,
        length(ts[i]) - tmp - 3) + ', ' + inttostr(count));
  end;
  Memo2.Lines.EndUpdate;
  ts.Free;
end;

На форме memo1 c текстом терминов, memo2 для вывода.

UPD
Пожалуйста

[McFrey]

BDA, от всей души благодарю!!! Работает как швейцарские цасы! Спасибо!!....

P.S. Тему не закрывайте, потому что могу еще где нибудь закосячить((
BDA, хотел на весы нажать (мелочь, а приятно) а не разрешает (добавьте отзыв кому нибудь еще...)...жаль, но словами скажу Спасибо!

BDA, А можно как то видоизменить структуру вашей программы, чтобы все писать в строку, т.е.
абра 1,2(это id документов) 4,8(это сколько раз повторяется в документе, соответственно 4 раза в 1-ом и 8 во 2-ом)....


Спасибо.

[BDA]

Надоело думать над ручной реализацией, поэтому:

uses Generics.Collections;
...
procedure TForm1.Button1Click(Sender: TObject);
var
  Dictionary: TDictionary < String, TDictionary < String, Integer >> ;
  Item: TDictionary<String, Integer>;
  i, tmp: Integer;
  a, b, s: string;
  Key1, Key2: string;
begin
  Dictionary := TDictionary < String, TDictionary < String, Integer >> .create;
  for i := 0 to Memo1.Lines.Count - 1 do
  begin
    s := Memo1.Lines[i];
    tmp := pos(' // ', s);
    a := copy(s, 1, tmp);
    b := copy(s, tmp + 4, length(s) - tmp - 3);
    if (Dictionary.TryGetValue(a, Item) = True) then
    begin
      if (Item.TryGetValue(b, tmp) = True) then
        Item.AddOrSetValue(b, tmp + 1)
      else
        Item.Add(b, 1);
    end
    else
    begin
      Item := TDictionary<String, Integer>.create;
      Item.Add(b, 1);
      Dictionary.Add(a, Item);
    end;
  end;
  Memo2.Lines.BeginUpdate;
  Memo2.Clear;
  for Key1 in Dictionary.Keys do
  begin
    a := '';
    b := '';
    for Key2 in Dictionary.Items[Key1].Keys do
    begin
      a := a + ',' + Key2;
      b := b + ',' + inttostr(Dictionary.Items[Key1].Items[Key2]);
    end;
    Memo2.Lines.Add(Key1 + ' ' + copy(a, 2, length(a) - 1) + ' ' + copy(b, 2,
        length(b) - 1));
  end;
  Memo2.Lines.EndUpdate;
  Dictionary.Free;
end;

Не уверен, что нет утечек.

[McFrey]

BDA, в Delphi 7 нет такой штуки Generics.Collections, верно?

[BDA]

Верно. Она появилась с дельфи 2009. В принципе, если хорошенько подумать и порисовать на бумажке алгоритм, то можно придумать способ, не задействующий словарь, просто нету времени думать
Более простой вариант (и более неэкономичный) - добавить второй проход по полученному списку и слить его еще раз.

[McFrey]

А условие для второго слития это равенство терминов между собой?

[Fantasy1133]

Мне очень помогла ваша программа. Но есть один нюанс, как добиться чтоб рядом с подсчитанными буквами были сами буквы, а не кавычки. Очень прошу помочь. Нужно для работы. Безымянный.jpg

[Fantasy1133]

Помоги пожалуйста

[BDA]

procedure TForm1.btn1Click(Sender: TObject);
var
  ts: tstringlist;
  i, count: integer;
begin
  ts := tstringlist.Create;
  ts.Text := Memo1.Text;
  ts.Sorted := true;
  count := 1;
  Memo2.Lines.BeginUpdate;
  Memo2.Clear;
  for i := 0 to ts.count - 2 do
    if ts[i] = ts[i + 1] then
      inc(count)
    else
    begin
      Memo2.Lines.Append(ts[i] + ' ' + inttostr(count));
      count := 1;
    end;
  if ts.count > 0 then
  begin
    i := ts.count - 1;
    Memo2.Lines.Append(ts[i] + ' ' + inttostr(count));
  end;
  Memo2.Lines.EndUpdate;
  ts.Free;
end;