Алгоритм уплотнения данных по методу Хафмана
Материал из 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