Реализация на Delphi алгоритма сжатия Шеннона
Листинг программы с комментариями
unit Shannon;
interface
Uses
Forms, Dialogs;
const
Count=4096;
ArchExt='she';
dot='.';
//две файловые переменные для чтения исходного файла и для
//записи архива
var
FileToRead,FileToWrite: File;
Str1:String='';
// Процедуры для работы с файлом
// Первая - кодирование файла
procedure RunEncodeShan(FileName_: string);
// Вторая - декодирование файла
procedure RunDecodeShan(FileName_: string);
implementation
Type
//тип элемета для динамической обработки статистики байтов
TByte=^PByte;
PByte=Record
//Символ (один из символв ASCII)
Symbol: Byte;
//статистика символа
SymbolStat: Integer;
//последовательность битов, в которые преобразуется текущий
//элемент после работы древа (Кодовое слово) (в виде строки из "0" и "1")
CodWord: String;
//ссылки на левое и правое поддеревья (ветки)
left, right: TByte;
End;
//массив из символов со статистикой , т.е. частотой появления их
//в архивируемом файле
BytesWithStat = Array [0..255] of TByte;
//объект, включающий в себя:
// массив элементов содержащий в себе количество элементов,
// встречающихся в файле хотя бы один раз
// процедура инициализации объекта
// процедура для увеличения частоты i-го элемента
TStat =Object
massiv: BytesWithStat;
CountByte: byte;
Procedure Create;//процера инициализации обьекта
Procedure Inc(i: Byte);
End;
//процедура инициализации объекта вызввается из
Procedure TStat.Create;
var
i: Byte;
Begin
CountByte:=255;
For i:=0 to CountByte do
Begin
New(massiv[i]);//создаём динамическую переменную
//и устанавливаем указатель на неё
massiv[i]^.Symbol:=i;
massiv[i]^.SymbolStat:=0;
massiv[i]^.left:=nil;
massiv[i]^.right:=nil;
Application.ProcessMessages;//Высвобождаем ресурсы
//чтобы приложение не казалось зависшим, иначе все ресуры процессора
//будт задействованы на обработку кода приложения
End;
End;
// процедура для для вычисления частот появления
// i-го элемента в сжимаемом файле. Вызывается из
Procedure TStat.Inc(i: Byte);
Begin
massiv[i]^.SymbolStat:=massiv[i]^.SymbolStat+1;
End;
Type
//объект включающий в себя:
//имя и путь к архивируемому файлу
//размер архивируемого файла
//массив статистики частот байтов
//дерево частот байтов
//функцию генерации по имени файла имени архива
//функцию генерации по имени архива имени исходного файла
//функцию для определения размера файла без заголовка
//иными словами возвращающую смещение в архивном файле
//откуда начинаются сжатые данные
File_=Object
Name: String;
Size: Integer;
Stat: TStat;
Tree: TByte;
Function ArcName: String;
Function DeArcName: String;
Function FileSizeWOHead: Integer;
End;
// генерация по имени файла имени архива
Function File_.ArcName: String;
Var
i: Integer;
name_: String;
Const
PostFix=ArchExt;
Begin
name_:=name;
i:=Length(Name_);
While (i>0) And not(Name_[i] in ['/','\','.']) Do
Begin
Dec(i);
Application.ProcessMessages;
End;
If (i=0) or (Name_[i] in ['/','\'])
Then
ArcName:=Name_+'.'+PostFix
Else
If Name_[i]='.'
Then
Begin
Name_[i]:='.';
//Name_[i]:='!';
ArcName:=Name_+'.'+PostFix;
End;
End;
// генерация по имени архива имени исходного файла
Function File_.DeArcName: String;
Var
i: Integer;
Name_: String;
Begin
Name_:=Name;
if pos(dot+ArchExt,Name_)=0
Then
Begin
ShowMessage('Неправильное имя архива,'#13#10'оно должно заканчиваться на ".'+ArchExt+'"');
Application.Terminate;
End
Else
Begin
i:=Length(Name_);
While (i>0) And (Name_[i]<>'!') Do
Begin
Dec(i);
Application.ProcessMessages;
End;
If i=0
Then
Begin
Name_:=copy(Name_,1,pos(dot+ArchExt,Name_)-1);
If Name_=''
Then
Begin
ShowMessage('Неправильное имя архива');
Application.Terminate;
End
Else
DeArcName:=Name_;
End
Else
Begin
Name_[i]:='.';
Delete(Name_,pos(dot+ArchExt,Name_),4);
DeArcName:=Name_;
End;
End;
End;
Function File_.FileSizeWOHead: Integer;
Begin
FileSizeWOHead:=FileSize(FileToRead)-4-1-
(Stat.CountByte+1)*5;
//размер исходного файла записывается в 4 байтах
//количество оригинальных байт записывается в 1байте
//количество байтов со статистикой - величина массива
End;
//процедура сортировки массива с байтами (сортировка производится
//по убыванию частоты байта
procedure SortMassiv(var a: BytesWithStat; length_mass: byte);
var
i,j: Byte;
b: TByte;
Begin
if length_mass<>0
Then
for j:=0 to length_mass-1 do
Begin
for i:=0 to length_mass-1 do
Begin
If a[i]^.SymbolStat < a[i+1]^.SymbolStat
Then
Begin
b:=a[i]; a[i]:=a[i+1]; a[i+1]:=b;
End;
Application.ProcessMessages;
End;
Application.ProcessMessages;
End;
End;
{Процедура построения древа частот Shennon}
procedure CreateTree(var Root: TByte;massiv: BytesWithStat;
last: byte);
//процедуа деления группы
procedure DivGroup(i1, i2: byte);
{процедура создания кодовых слов. Вызывается после того как отработала процедура деления массива на группы. В полученном первом массиве мы ко всем одовым словам добавляем символ '0' во втором символ единицы}
procedure CreateCodWord(i1, i2: byte;Value:string);
var
i:integer;
begin
for i:=i1 to i2 do
massiv[i]^.CodWord:=massiv[i]^.CodWord+Value;
end;
//Процедуа деления массива
var
k, i : byte;
c, oldc, s, g1, g2 :Single;
begin
//Пограничное условие, чтобы рекурсия у нас
// не была бесконечной
if (i1<i2) then
begin
s := 0;
for i := i1 to i2 do
s := s + massiv[i]^.SymbolStat;//Суммируем статистику частот
//появления символов в файле
k := i1; //Далее инициализируем переменные
g1 := 0;
g2 := s;
c := g2 - g1;
{Алгоритм: Переменные i1 и i2 это индексы начального и соответственно конечного элемента массива в k будем вырабатывать индекс пограничного элемента массива по которому мы его будем делить. с переменная в кторой будет хранится разность между g2 и g1. Потребуется для определения k. Сначала суммируем статистику появления символов в файле (Она как ни странно будет равна размеру файла =: т.е. количеству байт в нём)). Далее инициализируем переменные.
Затем цикл в котором происходит следующее к g1 нулевая статистика прибавляем статстику massiv[k] элемента массива massiv[k], а из g2 вычитаем ту же статистику. Далее oldc:=c это нам надо для определения дошли мы до значения k где статистика обойх частей массива равна. c := abs(g2-g1) именно по модулю иначе у нас не выполнится условие (c >= oldc) в том случае когда (g2<g1). Далее проверяется условие c > oldc, если оно верно то мы уменьшаем k на единицу, если не то оставляем k какое есть это и будет значение элемента в котором сумм статистик масивов примерно равны. Далее просто рекурсивно вызываем Эту же процедуру пока массивы полностью не разделятся на одиночные элементы или листья }
repeat
g1 := g1 + massiv[k]^.SymbolStat;
g2 := g2 - massiv[k]^.SymbolStat;
oldc := c;
c := abs(g2-g1);
Inc(k);
until (c >= oldc) or (k = i2);
if c > oldc then
begin
Dec(k); //вырабатываем значение k2
end;
CreateCodWord(i1, k-1,'0'); //Заполняем первый массив
//элементами
CreateCodWord(k, i2,'1'); //Заполняем второй массив
//элементами
DivGroup(i1, k-1);//снова вызываем процедуру
//деления массива (первой части)
DivGroup(k, i2);// вызываем процедуру
end;
end;
begin
DivGroup(0,last);
end;
var
//экземпляр объекта для текущего сжимаемого файла
MainFile: file_;
//процедура для полного анализа частот байтов встречающихся хотя бы
//один раз в исходном файле
procedure StatFile(Fname: String);
var
f: file; //переменная типа file в неё будем писать
i,j: Integer;
buf: Array [1..count] of Byte;//массив=4кБ содержащий в
//себе часть архивируемого файла до 4кБ делается это для ускорения
//работы програмы
countbuf, lastbuf: Integer;//countbuf переменная которая показывает
//какое целое количество буферов=4кБ содержится в исходном файле
//для анализа частот символов встречающих в исходнлм файле
//lastbuf остаток байт которые неободимо будет проанализировать
Begin
AssignFile(f,fname);//связываем файловую переменню f
//с архивируемым файлом
Try
Reset(f,1);//открываем файл
MainFile.Stat.create;//вызываем метод инициализации объекта
//для архивируемого файла
MainFile.Size:=FileSize(f);//метод определения размера
// архивируемого файла
///////////////////////
countbuf:=FileSize(f) div count;//столько целых буферов
//по 4096 байт содержится в исходном файле
lastbuf:=FileSize(f) mod count; // остаток (последий буфер)разница
//в байтах до 4096
////////////
For i:=1 to countbuf do
Begin
BlockRead(f,buf,count);
for j:=1 to count do
Begin
MainFile.Stat.inc(buf[j]);
Application.ProcessMessages;
End;
Application.ProcessMessages;
End;
/////////////
If lastbuf<>0 //просчитываем статистику для оставшихся
//байт
Then
Begin
BlockRead(f,buf,lastbuf);
for j:=1 to lastbuf do
Begin
MainFile.Stat.inc(buf[j]);
Application.ProcessMessages;
End;
Application.ProcessMessages;
End;
CloseFile(f);
Except
ShowMessage('ошибка доступа к файлу!')
End;
End;
//процедура записи сжатого потока битов в архив
Procedure WriteInFile(var buffer: String);
var
i,j: Integer;
k: Byte;
buf: Array[1..2*count] of byte;
Begin
i:=Length(buffer) div 8; // узнаем сколько получится
//байт в каждой последовательности
//////////////////////////
For j:=1 to i do // работаем с байтами
Begin
buf[j]:=0;// обнуляем тот элемент мссива в
//который будем писать
///////////////////////////
For k:=1 to 8 do //работаем с битами
{находим в строке тот элемент который будем записывать в виде последовательности бит (будем просматривать с (j-1) элемента строки buffer восемь элментов за ним тем самым сформируется строка из восьми '0' и '1'. Эту строку мы будем преобразовывать в байт, который должен будет содержать такуюже последовательность бит)}
Begin
If buffer[(j-1)*8+k]='1'
Then
{Преобразование будем производить с помощью операции битового сдвига влево shl и логической опереоции или (or). Делается это так поверяется условие buffer[(j-1)*8+k]='1' если в выделенной строке из восьми символов (мы просматриваем её по циклу от первого элемента до восьмого), элемент, индекс которого равен счётчику цикла к, равен единице, то к соответствующему биту (номер которого в байте равен переменной цикла к) будет применена операция or (0 or 1=1) т.е. это бит примет значение 1. Если в строке будет ноль то и соответствующий бит будет равен нулю. (нам его не требуется устанавливать т.к. в начале работы с каждым байтом мы его обнуляем)}
buf[j]:=buf[j] or (1 shl (8-k));
Application.ProcessMessages;
End;
Application.ProcessMessages;
End;
BlockWrite(FileToWrite,buf,i);
Delete(buffer,1,i*8);
End;
//процедура для окончательной записи остаточной цепочки битов в архив
Procedure WriteInFile_(var buffer: String);