Программа

PROGRAM Proger(input,output);
CONST FileName='PROG';  { Имя текстового файла }
      QuantityChar=9;   { Максимальное количество символов в идентификаторе }
      { Множества символов входящих в идентификаторы: }
      Letter=['_','A'..'Z','a'..'z'];
      LetterNum=['0'..'9'];
      LetterWide=Letter+LetterNum;
TYPE WordType=array [1..QuantityChar] of char;  { Тип - слово }
     WordTreeType=^Word; { Тип - дерево слов }
     Word=record  { Тип - слово (элемент дерева) }
            W:WordType;    { Слово }
            Q:integer;  { Встречаемость слова в файле }
            Pred,Next:WordTreeType
            { Ссылки на предыдущее и последующее (по алфавиту) слова }
          end;
VAR F:text; { Файловая переменная }
    WordTree:WordTreeType;  { Дерево слов }
PROCEDURE UpCase(var Ch:Char);
  Begin                 { Поцедура преобразования строчных букв в прописные }
    if Ch in ['a'..'z'] then Ch:=Chr(Ord(Ch)+Ord('A')-Ord('a'))
  End;
PROCEDURE ReadWord(var F:text;var Buf:WordType);  { Процедура чтения слова }
  Var i:0..QuantityChar;  { Счетчик прочитанных символов }
      PredChar:Char;  { Предыдущий прочитанный символ }
      BufChar:Char; { Прочитанный символ }
  Begin
    while EOLn(F) and not EOF(F) do ReadLn(F); { "Сброс" пустых строк }
    BufChar:=' '; { Сброс значения прочитанного символа }
    PredChar:=' '; { Сброс значения предыдущего символа }
    Buf[1]:=' '; { Сброс первого символа в слове (установка отсутствия слова) }
    while not EOF(F) and (not (BufChar in Letter) and not (PredChar in LetterNum)) do
    begin { Цикл чтения файла до первого символа принадлежащего идентификатору }
      PredChar:=BufChar; { Сохранение предыдущего символа }
      Read(F,BufChar); { Чтение символа }
      if BufChar='{' then { Если начало коментария }
      begin
        while BufChar<>'}' do if EOLn(F) then ReadLn(F) else Read(F,BufChar);
        { то "сброс" символов до конца коментария }
        PredChar:=' ' { Сброс предыдущего символа }
      end;
      { То же для "альтернативного" коментария: }
      if (PredChar='(')and(BufChar='*') then
        while not ((PredChar='*')and(BufChar=')')) do
          if EOLn(F) then begin ReadLn(F); PredChar:=' ' end
                     else begin PredChar:=BufChar; Read(F,BufChar) end;
      { "Сброс" строковой константы: }
      if BufChar='''' then begin
                             BufChar:=' ';
                             while BufChar<>'''' do Read(F,BufChar);
                             PredChar:=' '
                           end
    end;
    if (BufChar in Letter) and not (PredChar in LetterNum) then
    begin { Прверка начала идентификатора }
      for i:=1 to QuantityChar do { Цикл чтения слова }
      begin
        Buf[i]:=BufChar; { Определение символа в слове }
        { Чтение символа (если нет конца слова ) }
        if not EOLn(F) and (BufChar<>' ')
          then Read(F,BufChar)
          else BufChar:=' '; { Сброс символа при достижении конца строки }
        if not (BufChar in (LetterWide+[' '])) then BufChar:=' '
        { "Сброс" прочитанного символа невходящего в идентификатор }
      end;
      for i:=1 to QuantityChar do UpCase(Buf[i])
                                        { Перевод строчных букв в прописные }
    end
  End;
FUNCTION CheckDifferent(W1,W2:WordType):integer; { Функция сравнения слов }
  Var i:1..QuantityChar; { Счетчик символов в слове }
  Begin
    i:=1; { Начальная установка счетчика }
    while (W1[i]=W2[i])and(i<QuantityChar) do i:=i+1;
                               { Цикл поиска первой пары различных символов }
    { Сравнение пары символов и определение зачения функции: }
    if W1[i]=W2[i]
    then CheckDifferent:=0
    else if W1[i]<W2[i]
         then CheckDifferent:=-1
         else CheckDifferent:=1
  End;
PROCEDURE InsertWord(var WordTree:WordTreeType;Buf:WordType);
                                           { Процедура вставки слова в дерево }
  Begin
    if WordTree=nil { Проверка наличия элемента дерева }
    then begin { Формирование нового элемента }
           New(WordTree); { Создание новой переменной }
           with WordTree^ do begin { Инициализация полей }
                               W:=Buf;
                               Q:=1;
                               Pred:=nil;
                               Next:=nil
                             end
         end
    else case CheckDifferent(Buf,WordTree^.W) of
         { Сравнение полученного слова со словом в дереве }
           -1:InsertWord(WordTree^.Pred,Buf); 
                { Переход в сторону предыдущих по алфавиту слов }
            0:WordTree^.Q:=WordTree^.Q+1;
                { Пересчет встречаемости данного слова }
            1:InsertWord(WordTree^.Next,Buf)
                { Переход в сторону слудующих по алфавиту слов }
          end
  End;
PROCEDURE ReadFile(var F:text;var WordTree:WordTreeType);
                            { Процедура чтения файла и создания дерева слов }
  Var Buf:WordType; { Буферная переменная для чтения слов }
  Begin
    Reset(F); { Открытие файла }
    while not EOF(F) do  { Цикл чтения файла }
    begin
      ReadWord(F,Buf);  { Чтение слова из файла }
      if Buf[1]<>' ' then InsertWord(WordTree,Buf)
                   { Если прочитанное - слово, то вставка слова в дерево  }
    end;
    Close(F) { Закрытие файла }
  End;
PROCEDURE DisposerTree(var L:WordTreeType); { Процедура удаления дерева }
  Begin
    if L<>nil then begin   { Если переменная существует, то }
                     { удаление поддеревьев: }
                     DisposerTree(L^.Pred);
                     DisposerTree(L^.Next);
                     Dispose(L); { удаление переменной }
                     L:=nil { преопределение ссылки }
                   end
  End;
PROCEDURE OutListWord(WordTree:WordTreeType); { Вывод дерева }
  Begin
   if WordTree<>nil then { Если элемент существует, то: }
     with WordTree^ do
     begin
       OutListWord(Pred); { Вывод поддерева с предыдущими словами }
       Write(W,Q:4,'   ');{ Вывод слова }
       OutListWord(Next)  { Вывод поддерева с последующими словами }
     end
  End;
BEGIN
  WriteLn; { Пропуск строки }
  WordTree:=nil;  { Сброс ссылки на дерево }
  Assign(F,FileName);  { Связывание файловой переменной с файлом }
  ReadFile(F,WordTree); { Чтение файла и создание дерева слов }
  OutListWord(WordTree);    { Вывод списка слов }
  WriteLn { Пропуск строки }
END.