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

Previous  Top  Next

    
 

 

Code:

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

 

 

http://algolist.manual.ru

©Drkb::04175