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

{$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
Category:Алгоритмы
Category:Сжатие данных