{$A+,B-,D+,E+,F-,G-,I-,L+,N-,O-,R+,S+,V+,X-}
{$M 16384,0,655360}
{******************************************************}
{* Алгоритм уплотнения данных по методу *}
{* Хафмана. *}
{******************************************************}
Program Hafman;
Uses Crt,Dos,Printer;
Type  PCodElement = ^CodElement;
  CodElement = record
  NewLeft,NewRight,
  P0, P1 : PCodElement; {элемент входящий одновременно}
  LengthBiteChain : byte; { в массив , очередь и дерево }
  BiteChain : word;
  CounterEnter : word;
  Key : boolean;
  Index : byte;
  end;
  TCodeTable = array [0..255] of PCodElement;
Var  CurPoint,HelpPoint,
  LeftRange,RightRange : PCodElement;
  CodeTable : TCodeTable;
  Root : PCodElement;
  InputF, OutputF, InterF : file;
  TimeUnPakFile : longint;
  AttrUnPakFile : word;
  NumRead, NumWritten: Word;
  InBuf : array[0..10239] of byte;
  OutBuf : array[0..10239] of byte;
  BiteChain : word;
  CRC,
  CounterBite : byte;
  OutCounter : word;
  InCounter : word;
  OutWord : word;
  St : string;
  LengthOutFile, LengthArcFile : longint;
  Create : boolean;
  NormalWork : boolean;
  ErrorByte : byte;
  DeleteFile : boolean;
{-------------------------------------------------}
procedure ErrorMessage;
{ --- вывод сообщения об ошибке --- }
begin
 If ErrorByte <> 0 then
 begin
  Case ErrorByte of
  2 : Writeln('File not found ...');
  3 : Writeln('Path not found ...');
  5 : Writeln('Access denied ...');
  6 : Writeln('Invalid handle ...');
  8 : Writeln('Not enough memory ...');
  10 : Writeln('Invalid environment ...');
.
  11 : Writeln('Invalid format ...');
  18 : Writeln('No more files ...');
  else Writeln('Error #',ErrorByte,' ...');
  end;
  NormalWork:=False;
  ErrorByte:=0;
 end;
end;
procedure ResetFile;
{ --- открытие файла для архивации --- }
Var St : string;
begin
 Assign(InputF, ParamStr(3));
 Reset(InputF, 1);
 ErrorByte:=IOResult;
 ErrorMessage;
 If NormalWork then Writeln('Pak file : ',ParamStr(3),'...');
end;
procedure ResetArchiv;
{ --- открытие файла архива, или его создание --- }
begin
 St:=ParamStr(2);
 If Pos('.',St)<>0 then Delete(St,Pos('.',St),4);
 St:=St+'.vsg';
 Assign(OutputF, St);
 Reset(OutPutF,1);
 Create:=False;
 If IOResult=2 then
  begin
  Rewrite(OutputF, 1);
  Create:=True;
  end;
 If NormalWork then
  If Create then Writeln('Create archiv : ',St,'...')
  else Writeln('Open archiv : ',St,'...')
end;
procedure SearchNameInArchiv;
{ --- в дальнейшем - поиск имени файла в архиве --- }
begin
 Seek(OutputF,FileSize(OutputF));
 ErrorByte:=IOResult;
 ErrorMessage;
end;
procedure DisposeCodeTable;
{ --- уничтожение кодовой таблицы и очереди --- }
Var I : byte;
begin
 For I:=0 to 255 do Dispose(CodeTable[I]);
end;
procedure ClosePakFile;
{ --- закрытие архивируемого файла --- }
Var I : byte;
begin
 If DeleteFile then Erase(InputF);
.
 Close(InputF);
end;
procedure CloseArchiv;
{ --- закрытие архивного файла --- }
begin
 If FileSize(OutputF)=0 then Erase(OutputF);
 Close(OutputF);
end;
procedure InitCodeTable;
{ --- инициализация таблицы кодировки --- }
Var I : byte;
begin
 For I:=0 to 255 do
 begin
  New(CurPoint);
  CodeTable[I]:=CurPoint;
  With CodeTable[I]^ do
  begin
  P0:=Nil;
  P1:=Nil;
  LengthBiteChain:=0;
  BiteChain:=0;
  CounterEnter:=1;
  Key:=True;
  Index:=I;
  end;
 end;
 For I:=0 to 255 do
 begin
  If I>0 then CodeTable[I-1]^.NewRight:=CodeTable[I];
  If I<255 then CodeTable[I+1]^.NewLeft:=CodeTable[I];
 end;
 LeftRange:=CodeTable[0];
 RightRange:=CodeTable[255];
 CodeTable[0]^.NewLeft:=Nil;
 CodeTable[255]^.NewRight:=Nil;
end;
procedure SortQueueByte;
{ --- пузырьковая сортировка по возрастанию --- }
Var Pr1,Pr2 : PCodElement;
begin
 CurPoint:=LeftRange;
 While CurPoint <> RightRange do
 begin
  If CurPoint^.CounterEnter > CurPoint^.NewRight^.CounterEnter then
  begin
  HelpPoint:=CurPoint^.NewRight;
  HelpPoint^.NewLeft:=CurPoint^.NewLeft;
  CurPoint^.NewLeft:=HelpPoint;
  If HelpPoint^.NewRight<>Nil then HelpPoint^.NewRight^.NewLeft:=CurPoint;
  CurPoint^.NewRight:=HelpPoint^.NewRight;
  HelpPoint^.NewRight:=CurPoint;
  If HelpPoint^.NewLeft<>Nil then HelpPoint^.NewLeft^.NewRight:=HelpPoint;
  If CurPoint=LeftRange then LeftRange:=HelpPoint;
  If HelpPoint=RightRange then RightRange:=CurPoint;
  CurPoint:=CurPoint^.NewLeft;
.
  If CurPoint = LeftRange then CurPoint:=CurPoint^.NewRight
  else CurPoint:=CurPoint^.NewLeft;
  end
  else CurPoint:=CurPoint^.NewRight;
 end;
end;
procedure CounterNumberEnter;
{ --- подсчет частот вхождений байтов в блоке --- }
Var C : word;
begin
 For C:=0 to NumRead-1 do
 Inc(CodeTable[(InBuf[C])]^.CounterEnter);
end;
function SearchOpenCode : boolean;
{ --- поиск в очереди пары открытых по Key минимальных значений --- }
begin
 CurPoint:=LeftRange;
 HelpPoint:=LeftRange;
 HelpPoint:=HelpPoint^.NewRight;
 While not CurPoint^.Key do
 CurPoint:=CurPoint^.NewRight;
 While (not (HelpPoint=RightRange)) and (not HelpPoint^.Key) do
 begin
  HelpPoint:=HelpPoint^.NewRight;
  If (HelpPoint=CurPoint) and (HelpPoint<>RightRange) then
  HelpPoint:=HelpPoint^.NewRight;
 end;
 If HelpPoint=CurPoint then SearchOpenCode:=False else SearchOpenCode:=True;
end;
procedure CreateTree;
{ --- создание дерева частот вхождения --- }
begin
 While SearchOpenCode do
 begin
  New(Root);
  With Root^ do
  begin
  P0:=CurPoint;
  P1:=HelpPoint;
  LengthBiteChain:=0;
  BiteChain:=0;
  CounterEnter:=P0^.CounterEnter + P1^.CounterEnter;
  Key:=True;
  P0^.Key:=False;
  P1^.Key:=False;
  end;
  HelpPoint:=LeftRange;
  While (HelpPoint^.CounterEnter < Root^.CounterEnter) and
  (HelpPoint<>Nil) do HelpPoint:=HelpPoint^.NewRight;
  If HelpPoint=Nil then { добавление в конец }
  begin
  Root^.NewLeft:=RightRange;
  RightRange^.NewRight:=Root;
  Root^.NewRight:=Nil;
  RightRange:=Root;
  end
.
  else
  begin { вставка перед HelpPoint }
  Root^.NewLeft:=HelpPoint^.NewLeft;
  HelpPoint^.NewLeft:=Root;
  Root^.NewRight:=HelpPoint;
  If Root^.NewLeft<>Nil then Root^.NewLeft^.NewRight:=Root;
  end;
 end;
end;
procedure ViewTree( P : PCodElement );
{ --- просмотр дерева частот и присваивание кодировочных цепей листьям --- }
Var Mask,I : word;
begin
 Inc(CounterBite);
 If P^.P0<>Nil then ViewTree( P^.P0 );
 If P^.P1<>Nil then
 begin
  Mask:=(1 SHL (16-CounterBite));
  BiteChain:=BiteChain OR Mask;
  ViewTree( P^.P1 );
  Mask:=(1 SHL (16-CounterBite));
  BiteChain:=BiteChain XOR Mask;
 end;
 If (P^.P0=Nil) and (P^.P1=Nil) then
 begin
  P^.BiteChain:=BiteChain;
  P^.LengthBiteChain:=CounterBite-1;
 end;
 Dec(CounterBite);
end;
procedure CreateCompressCode;
{ --- обнуление переменных и запуск просмотра дерева с вершины --- }
begin
 BiteChain:=0;
 CounterBite:=0;
 Root^.Key:=False;
 ViewTree(Root);
end;
procedure DeleteTree;
{ --- удаление дерева --- }
Var P : PCodElement;
begin
 CurPoint:=LeftRange;
 While CurPoint<>Nil do
 begin
  If (CurPoint^.P0<>Nil) and (CurPoint^.P1<>Nil) then
  begin
  If CurPoint^.NewLeft <> Nil then
  CurPoint^.NewLeft^.NewRight:=CurPoint^.NewRight;
  If CurPoint^.NewRight <> Nil then
  CurPoint^.NewRight^.NewLeft:=CurPoint^.NewLeft;
  If CurPoint=LeftRange then LeftRange:=CurPoint^.NewRight;
  If CurPoint=RightRange then RightRange:=CurPoint^.NewLeft;
  P:=CurPoint;
  CurPoint:=P^.NewRight;
  Dispose(P);
  end
.
  else CurPoint:=CurPoint^.NewRight;
 end;
end;
procedure SaveBufHeader;
{ --- запись в буфер заголовка архива --- }
Type
  ByteField = array[0..6] of byte;
Const
  Header : ByteField = ( $56, $53, $31, $00, $00, $00, $00 );
begin
 If Create then
 begin
  Move(Header,OutBuf[0],7);
  OutCounter:=7;
 end
 else
 begin
  Move(Header[3],OutBuf[0],4);
  OutCounter:=4;
 end;
end;
procedure SaveBufFATInfo;
{ --- запись в буфер всей информации по файлу --- }
Var I : byte;
  St : PathStr;
  R : SearchRec;
begin
 St:=ParamStr(3);
 For I:=0 to Length(St)+1 do
 begin
  OutBuf[OutCounter]:=byte(Ord(St[I]));
  Inc(OutCounter);
 end;
 FindFirst(St,$00,R);
 Dec(OutCounter);
 Move(R.Time,OutBuf[OutCounter],4);
 OutCounter:=OutCounter+4;
 OutBuf[OutCounter]:=R.Attr;
 Move(R.Size,OutBuf[OutCounter+1],4);
 OutCounter:=OutCounter+5;
end;
procedure SaveBufCodeArray;
{ --- сохранить массив частот вхождений в архивном файле --- }
Var I : byte;
begin
 For I:=0 to 255 do
 begin
  OutBuf[OutCounter]:=Hi(CodeTable[I]^.CounterEnter);
  Inc(OutCounter);
  OutBuf[OutCounter]:=Lo(CodeTable[I]^.CounterEnter);
  Inc(OutCounter);
 end;
end;
.
procedure CreateCodeArchiv;
{ --- создание кода сжатия --- }
begin
 InitCodeTable; { инициализация кодовой таблицы }
 CounterNumberEnter; { подсчет числа вхождений байт в блок }
 SortQueueByte; { cортировка по возрастанию числа вхождений }
 SaveBufHeader; { сохранить заголовок архива в буфере }
 SaveBufFATInfo; { сохраняется FAT информация по файлу }
 SaveBufCodeArray; { сохранить массив частот вхождений в архивном файле }
 CreateTree; { создание дерева частот }
 CreateCompressCode; { cоздание кода сжатия }
 DeleteTree; { удаление дерева частот }
end;
procedure PakOneByte;
{ --- сжатие и пересылка в выходной буфер одного байта --- }
Var Mask : word;
  Tail : boolean;
begin
 CRC:=CRC XOR InBuf[InCounter];
 Mask:=CodeTable[InBuf[InCounter]]^.BiteChain SHR CounterBite;
 OutWord:=OutWord OR Mask;
 CounterBite:=CounterBite+CodeTable[InBuf[InCounter]]^.LengthBiteChain;
 If CounterBite>15 then Tail:=True else Tail:=False;
 While CounterBite>7 do
 begin
  OutBuf[OutCounter]:=Hi(OutWord);
  Inc(OutCounter);
  If OutCounter=(SizeOf(OutBuf)-4) then
  begin
  BlockWrite(OutputF,OutBuf,OutCounter,NumWritten);
  OutCounter:=0;
  end;
  CounterBite:=CounterBite-8;
  If CounterBite<>0 then OutWord:=OutWord SHL 8 else OutWord:=0;
 end;
 If Tail then
 begin
  Mask:=CodeTable[InBuf[InCounter]]^.BiteChain SHL
  (CodeTable[InBuf[InCounter]]^.LengthBiteChain-CounterBite);
  OutWord:=OutWord OR Mask;
 end;
 Inc(InCounter);
 If (InCounter=(SizeOf(InBuf))) or (InCounter=NumRead) then
 begin
  InCounter:=0;
  BlockRead(InputF,InBuf,SizeOf(InBuf),NumRead);
 end;
end;
procedure PakFile;
{ --- процедура непосредственного сжатия файла --- }
begin
 ResetFile;
 SearchNameInArchiv;
 If NormalWork then
 begin
  BlockRead(InputF,InBuf,SizeOf(InBuf),NumRead);
  OutWord:=0;
.
  CounterBite:=0;
  OutCounter:=0;
  InCounter:=0;
  CRC:=0;
  CreateCodeArchiv;
  While (NumRead<>0) do PakOneByte;
  OutBuf[OutCounter]:=Hi(OutWord);
  Inc(OutCounter);
  OutBuf[OutCounter]:=CRC;
  Inc(OutCounter);
  BlockWrite(OutputF,OutBuf,OutCounter,NumWritten);
  DisposeCodeTable;
  ClosePakFile;
 end;
end;
procedure ResetUnPakFiles;
{ --- открытие файла для распаковки --- }
begin
 InCounter:=7;
 St:='';
 repeat
 St[InCounter-7]:=Chr(InBuf[InCounter]);
 Inc(InCounter);
 until InCounter=InBuf[7]+8;
 Assign(InterF,St);
 Rewrite(InterF,1);
 ErrorByte:=IOResult;
 ErrorMessage;
 If NormalWork then
 begin
  WriteLn('UnPak file : ',St,'...');
  Move(InBuf[InCounter],TimeUnPakFile,4);
  InCounter:=InCounter+4;
  AttrUnPakFile:=InBuf[InCounter];
  Inc(InCounter);
  Move(InBuf[InCounter],LengthArcFile,4);
  InCounter:=InCounter+4;
 end;
end;
procedure CloseUnPakFile;
{ --- закрытие файла для распаковки --- }
begin
 If not NormalWork then Erase(InterF)
 else
  begin
  SetFAttr(InterF,AttrUnPakFile);
  SetFTime(InterF,TimeUnPakFile);
  end;
 Close(InterF);
end;
procedure RestoryCodeTable;
{ --- воссоздание кодовой таблицы по архивному файлу --- }
Var I : byte;
begin
 InitCodeTable;
 For I:=0 to 255 do
.
 begin
  CodeTable[I]^.CounterEnter:=InBuf[InCounter];
  CodeTable[I]^.CounterEnter:=CodeTable[I]^.CounterEnter SHL 8;
  Inc(InCounter);
  CodeTable[I]^.CounterEnter:=CodeTable[I]^.CounterEnter+InBuf[InCounter];
  Inc(InCounter);
 end;
end;
procedure UnPakByte( P : PCodElement );
{ --- распаковка одного байта --- }
Var Mask : word;
begin
 If (P^.P0=Nil) and (P^.P1=Nil) then
 begin
  OutBuf[OutCounter]:=P^.Index;
  Inc(OutCounter);
  Inc(LengthOutFile);
  If OutCounter = (SizeOf(OutBuf)-1) then
  begin
  BlockWrite(InterF,OutBuf,OutCounter,NumWritten);
  OutCounter:=0;
  end;
 end
 else
 begin
  Inc(CounterBite);
  If CounterBite=9 then
  begin
  Inc(InCounter);
  If InCounter = (SizeOf(InBuf)) then
  begin
  InCounter:=0;
  BlockRead(OutputF,InBuf,SizeOf(InBuf),NumRead);
  end;
  CounterBite:=1;
  end;
  Mask:=InBuf[InCounter];
  Mask:=Mask SHL (CounterBite-1);
  Mask:=Mask OR $FF7F; { установка всех битов кроме старшего }
  If Mask=$FFFF then UnPakByte(P^.P1)
  else UnPakByte(P^.P0);
 end;
end;
procedure UnPakFile;
{ --- распаковка одного файла --- }
begin
 BlockRead(OutputF,InBuf,SizeOf(InBuf),NumRead);
 ErrorByte:=IOResult;
 ErrorMessage;
 If NormalWork then ResetUnPakFiles;
 If NormalWork then
 begin
  RestoryCodeTable;
  SortQueueByte;
  CreateTree; { создание дерева частот }
  CreateCompressCode;
  CounterBite:=0;
.
  OutCounter:=0;
  LengthOutFile:=0;
  While LengthOutFile<LengthArcFile do
  UnPakByte(Root);
  BlockWrite(InterF,OutBuf,OutCounter,NumWritten);
  DeleteTree;
  DisposeCodeTable;
 end;
 CloseUnPakFile;
end;
{ ------------------------- main text ------------------------- }
begin
 DeleteFile:=False;
 NormalWork:=True;
 ErrorByte:=0;
 WriteLn;
 WriteLn('ArcHaf version 1.0 (c) Copyright VVS Soft Group, 1992.');
 ResetArchiv;
 If NormalWork then
 begin
  St:=ParamStr(1);
  Case St[1] of
  'a','A' : PakFile;
  'm','M' : begin
  DeleteFile:=True;
  PakFile;
  end;
  'e','E' : UnPakFile;
  else ;
  end;
 end;
 CloseArchiv;
end.