Собственно, условие подобной задачи (олимпиадской) на форуме приводилось (решение - нет):
Привожу еще раз условие:
Дан текст, в котором встречаются слова, состоящие из букв русского и латинского алфавитов и цифр, знаки препинания, пробелы и переводы строк. Требуется найти количество вхождений каждого слова в этот текст Для каждого слова при выводе в скобках указать количество его вхождений в текст.
*************************************************************************
Понятно, что решение надо делать через двоичное дерево. Часть программы есть, но не допру, как дальше:
uses
crt;
type
{ссылка на узел дерева}
TFindTreePtr = ^TFindTreeNode;
TFindtreeNode = record
info: word;
count: integer;
left, right: TFindTreePtr;
end;
var
InFile: Text; {исходный файл}
FileName: string; {имя файла данных}
root: TFindTreePtr;
str: word; {текущий обрабатываемое слово}
ErrCode: integer; {код ошибки при открытии файла}
ask: char; {символ-отклик при выборе режима вывода}
procedure Search (c: string; var node: TFindTreePtr);
begin
if node=nil then begin
node:=New(TFindTreePtr);
node^.info:=c;
node^.count:=1;
node^.left:=nil; {новый лист}
node^.right:=nil;
end
else if c< node^.info then
Search (c,node^.left)
else if c>node^.info then
Search (c,node^.right)
else
node^.count := node^.count+1;
end;

type
  PTInfo = ^TInfo;

  TInfo = Record
     _word: String;
    _count: LongInt;
     _next: PTInfo;
  end;

  PTInfoList = ^TInfoList;

  TInfoList = object
    first, last: PTInfo;

    constructor Create(const file_name: String);
    procedure   Run;
    destructor  Free;

    procedure Push(const _word: String);
    procedure PushOrInc(const _word: String);

    procedure Print;
  end;


constructor TInfoList.Create(const file_name: String);
const
  limits = ['.', ',', ' ', '!', '?', ';', ':'];
var
  f: Text;
  i, back: Byte;
  s: String;

begin
  first := nil;
  last := nil;

  assign(f, file_name);

  {$I-}
  reset(f);
  {$I+}

  if IOResult <> 0 then begin
    writeln('can''t open file "' + file_name, '"');
    readln;
    halt(1);
  end;

  while not eof(f) do begin
    readln(f, s);

    i := 1;
    while (i <= length(s)) do begin
      while (i <= length(s)) and (s[i] in limits) do
        inc(i);

      if i <= length(s) then begin
        back := i;

        while (i <= length(s)) and not (s[i] in limits) do
          inc(i);

        PushOrInc(copy(s, back, i - back));
      end;

    end;
  end;
end;

destructor TInfoList.Free;
var
  T: PTInfo;
begin
  while first <> nil do begin
    T := first;
    first := first^._next;
    Dispose(T);
  end;
end;

procedure TInfoList.Push(const _word: String);
var
  T: PTInfo;
begin
  New(T);

  T^._word  := _word;
  T^._next  := nil;
  T^._count := 1;

  if first = nil then
    first := T
  else
    last^._next := T;

  last := T;
end;

procedure TInfoList.PushOrInc(const _word: String);
var
  T: PTInfo;
begin
  T := first;
  {$B-}
  while (T <> nil) and (T^._word <> _word) do
    T := T^._next;
  {$B+}
  if T <> nil then
    inc(T^._count)
  else
    Push(_word);
end;

procedure TInfoList.Print;
var
  T: PTInfo;
begin
  T := first;
  while first <> nil do begin
    writeln(first^._word, '(', first^._count, ')');
    first := first^._next;
  end;
  first := T;
end;

procedure TInfoList.Run;
begin
  Print;
end;

var
  info_list: PTInfoList;
begin
  New(info_list, Create('C:\test.txt'));

  info_list^.Run;

  Dispose(info_list, Free);
end.

Сообщение отредактировано: klem4 - 31.01.2008 22:22

Спасибо огромное! Буду разбираться

Мне это совсем непонятно. Ее нужно делать через trie.

Да, кстати, двоичных деревьев в решении я не использовал, обычный список ...

Winniepoohless,
вопрос на засыпку: слова 'Привет' и 'привет' считаются одинаковыми или разными?

klem4, к тебе тоже есть вопрос - почему не так:

procedure TInfoList.Print;
var T: PTInfo;
begin
  T := first;
  while T <> nil do
    with T^ begin
      writeln(_word, '(', _count, ')');
      T := _next;
    end;
end;

? Зачем лишние движения с first-ом делать?

Сообщение отредактировано: volvo - 31.01.2008 23:08

volvo, ага чо-то намудрил я мальца в этом месте ..

Да, "Привет" и "привет" считаются одинаковыми. И от этого не легче

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

Как это делать - ищи на форуме, была функция перевода строки в верхний рагистр, корректно работающая и с кириллицей, и с латиницей...

Насчет того, что через обычный список я увидел... Но никак не пойму, почему у меня ошибка вылазит при запуске программы - can't open file c:\test.txt

поищу. а через апкейс нельзя?

Посмотри вот в эти места в программе и разберись...

begin
  New(info_list, Create('C:\test.txt'));   <<===

  info_list^.Run;

  Dispose(info_list, Free);
end.

assign(f, file_name);

  {$I-}
  reset(f);
  {$I+}

  if IOResult <> 0 then begin
    writeln('can''t open file "' + file_name, '"');  <<===
    readln;
    halt(1);
  end; 

Может быть у тебя просто нет такого файла???

Название своего файла (для анализа) я вставляю после assign
А функция IOResult, вроде, просто проверяет правильность выполнения операции (если 0, то ок).
Но чего-то не идет...Можешь у себя попробовать,если вдруг захочется

Это не классификация ошибки... Что именно не идет? Что происходит? Что выводит программа? Файл существует? Он не заблокирован другим приложением? Вот я попробовал - все нормально открылось и отработало... Что я делаю не так?

Нельзя. Он работает только с латинскими символами, с русскими получишь проблему...

Добавлено через 1 мин.
Название своего файла надо передавать в Create (как это и сделано во втором посте), а не перековыривать всю программу, а потом говорить, "что-то не работает"...

Я разобрался, все заработало. Спасибо огромнейшее!!! Буду через функцию с преобразованием к верхнему регистру копаться