Алгоритм уплотнения данных по методу Хафмана

Материал из DRKB


{$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;

{ --- поиск в очереди пары открытых по Key минимальных значений --- }
function SearchOpenCode: Boolean;
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;
  { cортировка по возрастанию числа вхождений }
  SortQueueByte;
  { сохранить заголовок архива в буфере }
  SaveBufHeader;
  { сохраняется FAT информация по файлу }
  SaveBufFATInfo;
  { сохранить массив частот вхождений в архивном файле }
  SaveBufCodeArray;
  { создание дерева частот }
  CreateTree;
  { cоздание кода сжатия }
  CreateCompressCode;
  { удаление дерева частот }
  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.


Source: http://algolist.manual.ru
ID: 04175