PROGRAM Arhivator;
Uses Crt;
TYPE
  Tree=^PTree;
  PTree=Record
         Symbol:Byte;               {Кодируемый символ}
         Leng:Byte;                 {Длина кодовой последовательности}
         Bit:Byte;                  {Бит, соответствующий направл. ветви}
         Counter:Longint;           {Счётчик частоты вхождений}
         Code:Word;                 {Кодовая последовательность}
         Next,Prev:Tree;            {Указетели на элементы списка}
         Right,Left:Tree;           {Указатели на правую и левую ветвь дерева}
        End;
  ArrayTree=array[0..255] Of Tree;
VAR
  Root,pBegin,pNext,pEnd,Current,P:Tree;
  b:ArrayTree;
  HelpCode:Word;
  i,j,n,m,q,Buf:Byte;
  CountCode:Integer;
  s:Longint;
  f:File;
  r:Text;
  ch:Char;
  st:String;

Procedure Compression;
Begin
  {Инициализация массива узлов}
  For i:=0 To 255 Do
   begin
     New(b[i]);
     With b[i]^ Do
      begin
        Counter:=0;
        Symbol:=i;
        Bit:=0;
        Leng:=0;
        Code:=0;
        Right:=Nil;
        Left:=Nil;
      end;
   end;
  {Организация связи массива узлов}
  For i:=0 To 255 Do
   begin
     If i>0 Then b[i-1]^.Next:=b[i];
     If i<255 Then b[i+1]^.Prev:=b[i];
   end;
  b[0]^.Prev:=Nil;
  b[255]^.Next:=Nil;
  
  {Подсчёт частот вхождений байтов}
  While not(eof(f)) Do
   begin
     BlockRead(f,Buf,1);
     Inc(b[Buf]^.Counter);
   end;
  
  {Сотировка массива узлов}
  pBegin:=b[0];
  While pBegin<>Nil Do
   begin
     pNext:=pBegin;
     While pNext<>Nil Do
      begin
        If pBegin^.Counter>pNext^.Counter Then
         begin
           s:=pBegin^.Counter;
           n:=pBegin^.Symbol;
           m:=pBegin^.Bit;
           q:=pBegin^.Leng;
           HelpCode:=pBegin^.Code;
          
           pBegin^.Counter:=pNext^.Counter;
           pBegin^.Symbol:=pNext^.Symbol;
           pBegin^.Bit:=pNext^.Bit;
           pBegin^.Leng:=pNext^.Leng;
           pBegin^.Code:=pNext^.Code;
          
           pNext^.Counter:=s;
           pNext^.Symbol:=n;
           pNext^.Bit:=m;
           pNext^.Leng:=q;
           pNext^.Code:=HelpCode;
         end;
        pNext:=pNext^.Next;
      end;
     pBegin:=pBegin^.Next;
   end;
  
  {Нахождение ненулевых значений счётчика в массиве}
  pBegin:=b[0];
  While pBegin<>Nil Do
   If pBegin^.Counter=0 Then
    begin
      pBegin:=pBegin^.Next;
      pNext:=pBegin;
    end
   Else
    begin
      pNext:=pBegin;
      Break;
    end;

  {Создание кодового дерева}
  pEnd:=b[255];
  While (pNext<>Nil) and (pNext^.Next<>Nil) Do
   begin
     New(Root);
     With Root^ Do
      begin
        Right:=pNext^.Next;
        Left:=pNext;
        Counter:=pNext^.Counter+pNext^.Next^.Counter;
        Symbol:=0;
        Bit:=0;
        Leng:=0;
        Code:=0;
      end;
     Root^.Right^.Bit:=1;
     Root^.Left^.Bit:=0;
     Current:=pNext;
     While (Current^.Counter<Root^.Counter) and (Current<>Nil) Do
      Current:=Current^.Next;
     If Current=Nil Then
      begin
        Root^.Prev:=pEnd;
        pEnd^.Next:=Root;
        Root^.Next:=Nil;
        pEnd:=Root;
      end
     Else
      begin
        Root^.Prev:=Current^.Prev;
        Current^.Prev:=Root;
        Root^.Next:=Current;
        If Root^.Prev<>Nil Then Root^.Prev^.Next:=Root;
      end;
     pNext:=pNext^.Next^.Next;
   end;

End;

BEGIN
ClrScr;
Writeln('Для архивации файла нажмите ''a''.');
Writeln('Для распаковки файла нажмите ''r''.');
Writeln('Для отмены нажмите любую клавишу.');
ch:=Readkey;
Case ch Of
   #97:Begin
         Writeln('Введите полный путь и имя файла:');
         Readln(st);
         Assign(f,st);
         Reset(f,1);
         If FileSize(f)=0 Then Writeln('Файл пуст!!!')
          Else
           Begin
             Assign(r,'D:\Kopiya.TXT');
             Rewrite(r);
             Writeln(r,st);
            
             Compression;
            
             Close(r);
           End;
         Close(f);
       End;
  Else Halt;
End;
Readln;
END.