Написать прогу со списками и текстовыми файлами - Pascal

program alf1;
uses
  crt;
type
  TSlovo = string[40];
  PNode = ^Node;
  Node  = record           //элемент списка
  Slovo  : TSlovo;       //слово
  Povtor : word;       //количество повторений
  Next   : PNode;      //ссылкa следующий элемент списка
  end;
//процедура добавляет слово в список  
procedure AddQue(var First, Last : PNode; Slovo : TSlovo);
var PElem : PNode;
begin
  if Slovo = '' then exit;
  New(PElem);
  PElem^.Slovo  := Slovo;
  PElem^.Povtor := 1;
  PElem^.Next   := nil;
  if First = nil then
   begin
    First := PElem;
    Last  := First;
   end
  else
   begin
    Last^.Next := PElem;
    Last       := PElem;
   end;
end;  
//Сортировка из фака
procedure SortBublLink(nach:PNode);
var
  tmp,pered,pered1,pocle,rab:PNode; {все рабочие ссылки}
begin
  rab:=nach; {становимся на вершину стека}
  while rab<>nil do{пока не конец стека делать}
  begin
    tmp:=rab^.next; {переходим к следующему за сортируемым элементу}
    while tmp<>nil do {пока не конец стека делать}
    begin
      if tmp^.Slovo<rab^.Slovo then {если следует произвести замену, то}
      begin
        pered:=nach; {становимся в вершину стека}
        pered1:=nach; {становимся в вершину стека}
        if rab<>nach then {если мы не стоим на изменяемом элементе, то}
          while pered^.next<>rab do pered:=pered^.next; {станем на элементе перед изменяемым}
        while pered1^.next<>tmp do pered1:=pered1^.next; {станем на элементе перед изменяемым, который находится за
        первым изменяемым}
        pocle:=tmp^.next; {запоминаем адрес элемента после второго изменяемого}
        if rab^.next=tmp then {если элементы "соседи", то}
        begin
          tmp^.next:=rab; {меняем ссылки, тут если не понятно рисуйте на листочке}
          rab^.next:=pocle
        end
        else {в случае если элементы не соседи, то}
        begin
          tmp^.next:=rab^.next;{меняем ссылки, тут если не понятно рисуйте на листочке}
          rab^.next:=pocle;
        end;
        if pered1<>rab then{советую просмотреть на листочке}
          pered1^.next:=rab;
        if rab<>nach then{советую просмотреть на листочке}
          pered^.next:=tmp
        else{всё советую просмотреть на листочке}
          nach:=tmp;
        pered1:=tmp;{советую просмотреть на листочке}
        tmp:=rab;{советую просмотреть на листочке}
        rab:=pered1;{советую просмотреть на листочке}
      end;
      tmp:=tmp^.next; {переходим на следующий элемент}
    end;
    rab:=rab^.next;{переходим на следующий элемент}
  end;
end;
//Процедура удаления элемента списка - тоже с фака
Procedure DelElem(var stek1:PNode;tmp:PNode);
var
  tmpi:PNode;
begin
  if (stek1=nil) or (tmp=nil) then {если стек пуст или указатель никуда не указывает, то выходим}
    exit;
  if tmp=stek1 then {если мы удаляем элемент который является вершиной стека, то}
  begin
    stek1:=tmp^.next;{следует перенести вершину и}
    FreeMem(tmp,SizeOf(PNode)); {высвободить память из под элемента}
  end
  else {в случае, если удаляемый элемент не вершина стека, то}
  begin
    tmpi:=stek1; {ставим указатель на вершину стека}
    while tmpi^.next<>tmp do {доходим до элемента стоящего "перед" тем, который нам следует удалить}
      tmpi:=tmpi^.next;
    tmpi^.next:=tmp^.next; {указатель элемента переносим на следующий элемент за удаляемым}
    FreeMem(tmp,sizeof(PNode)); {удаляем элемент}
  end;
end; 
var
  znaki_prep : set of char = ['.',',','!','?','(',')',':',';','-']; //знаки препинания
  t, new_t : text;
  s        : string;
  slovo    : TSlovo;
  First, Last, PElem : PNode;
begin 
  clrscr;
  write('Имя файла : '); readln(s);
  assign(t,s);
  {$i-} 
  reset(t);
  {$I+}  
  If IOResult <> 0 then begin
    writeln('Файл не найден.');
    exit;
  end;
  First := nil; Last := nil;  //инициация списка
  while not eof(t) do begin
   readln(t,s);   
   while pos(' ',s)<>0 do begin  //пока в строке есть пробелы
    slovo := copy(s,1,pos(' ',s)-1);  //первое слово в строке
    while (slovo[length(slovo)] in znaki_prep) and (slovo <> '') do //удаляем знаки препинания 
     slovo := copy(slovo,1,length(slovo)-1);                        //вконце слова
    while (slovo[1] in znaki_prep) and (slovo <> '') do             //тоже в начале слова
     slovo := copy(slovo,2,length(slovo));
    AddQue(First, Last, slovo);                                //записываем слово в список
    s := copy(s,pos(' ',s)+1,length(s)-length(slovo)-1);       //удаляем слово из строки
   end;
   while (s[length(s)] in znaki_prep) and (s<>'') do  //удаляем знаки 
     s := copy(s,1,length(s)-1);                      //препинания
   while (s[1] in znaki_prep) and (s<>'') do          //в начале и
     s := copy(s,2,length(s));                        //конце строки
   AddQue(First, Last, s);                      //записываем строку в список
  end;
  assign(new_t,'TextFile.txt');
  rewrite(new_t);
  SortBublLink(First);          //сортируем список
  PElem := First;
  while PElem^.Next<>nil do begin
    if PElem^.Slovo=PElem^.Next^.Slovo then begin                //поля Slovo 2-х рядом стоящих элем равны 
    PElem^.Next^.Povtor := PElem^.Next^.Povtor + PElem^.Povtor;  //увеличиваем знач поля Povtor 2-го элемента 
    DelElem(First,PElem);                                        //удаляем 1-ый элемент
    end;
    PElem := PElem^.Next;
  end;
  PElem := First;
  while PElem<>nil do begin   //выводим получившийся список в файл
    writeln(new_t,PElem^.Slovo:40,PElem^.Povtor:7);
    PElem := PElem^.Next;
  end;
  close(t);
  close(new_t);
  writeln('Файл TextFile.txt создан.');
  readln;  
end.