Исходный текст архиватора Huffman'a (реализация на языке Object Pascal)
Содержание:
Исходный текст архиватора (алгоритм Хаффмана)
unit Unit1;
interface
Uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ComCtrls;
(*
Windows,//модуль поддерживает работу приложения с системой Win
Messages,//модуль позволяет получать и обрабатывать сообщения Win(кнопка закрытия)
SysUtils,//позволяет работать с фундаментальными типами данными (выделение памяти
//под динамические переменные, работа с файл. перем., процедуры и
//функции для работы со строковыми переменными
Classes,//модуль в котором описываются некоторые классы Delphi (TStream)
Graphics,//классы, процедуры и функции относящиеся к графике Win
Controls,//здесь описаны классы TControl, TWinControl, TGraphicControl
//прародители компонентов управления TButton, TLabel, TMemo, TEdit
Forms,//модуль для создания и управления формами приложения
Dialogs,//модуль для организации диалога с пользователем
ExtCtrls,//содержит описание классов TImage, TBevel
jpeg,//содержит средства для вывода картинок в формате JPG на форму
StdCtrls,//содержит описание классов TEdit, TMemo
MPlayer;//содержит средства для проигрывания видео в формате avi
*)
type
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
OpenDialog1: TOpenDialog;
ProgressBar1: TProgressBar;
Label2: TLabel;
Label3: TLabel;
ProgressBar3: TProgressBar;
Label4: TLabel;
OpenDialog2: TOpenDialog;
Button2: TButton;
ProgressBar2: TProgressBar;
Label1: TLabel;
Memo2: TMemo;
Label5: TLabel;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
const
count=4096;
//две файловые переменные для чтения исходного файла и для
//записи архива
var
f_r,f_w: File;
implementation
{$R *.DFM}
Type
//тип дерева для динамической обработки статистики байтов
byte_=^byte_jachejka;
byte_jachejka=Record
//сам байт
byte_id: Byte;
//статистика байта
byte_st: Integer;
//последовательность битов, в которые преобразуется текущий
//байт после сжатия (в виде строки из "0" и "1")
byte_string: String;
//ссылки на левое и правое поддеревья (ветки)
left, right: Byte_;
End;
//массив со статистикой байтов, принимающих участие в
//файле
bytes_with_stat = Array [0..255] of byte_;
//объект, инкапсулирующий в себе:
// * массив байтов с их статистикой
// * количество байт, содержащихся в файле (встречающихся в файле
// хотя бы один раз)
// * процедура (метод) инициализации объекта
// * процедура для увеличения частоты i-го байта
// * метод чтения i-го байта и его статистики
// * метод чтения массива байтов со статистикой
TStat = Object
massiv: bytes_with_stat;
count_byte: Byte;
Procedure create;
Procedure inc(i: Byte);
Function Read_(i: Byte): Byte_;
Function Read_Bytes: bytes_with_stat;
End;
// * процедура (метод) инициализации объекта
Procedure TStat.create;
var
i: Byte;
Begin
count_byte:=255;
For i:=0 to count_byte do
Begin
new(massiv[i]);
massiv[i]^.byte_id:=i;
massiv[i]^.byte_st:=0;
massiv[i]^.left:=nil;
massiv[i]^.right:=nil;
Application.ProcessMessages;
End;
End;
// * процедура для увеличения частоты i-го байта
Procedure TStat.inc(i: Byte);
Begin
massiv[i]^.byte_st:=massiv[i]^.byte_st+1;
End;
// * метод чтения i-го байта и его статистики
Function TStat.Read_(i: Byte): Byte_;
Begin
Read_:=massiv[i];
End;
// * метод чтения массива байтов со статистикой
Function TStat.Read_Bytes: bytes_with_stat;
Begin
Read_Bytes:=massiv;
End;
Type
//объект, инкапсулирующий в себе:
// * имя и путь к архивируемому файлу
// * размер архивируемого файла
// * массив статистики частот байтов
// * дерево частот байтов
// * метод генерации по имени файла имени архива
// * метод генерации по имени архива имени исходного файла
File_=Object
Name: String;
Size: Integer;
Stat: TStat;
Derevo: Byte_;
Function ArcName: String;
Function FileSizeWOHead: Integer;
Function DeArcName: String;
End;
// * метод генерации по имени архива имени исходного файла
Function File_.DeArcName: String;
Var
i: Integer;
name_: String;
Begin
name_:=name;
if pos('.ups',name_)=0
Then
Begin
ShowMessage('Неправильное имя архива');
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('.ups',name_)-1);
If name_=''
Then
Begin
ShowMessage('Неправильное имя архива');
Application.Terminate;
End
Else
DeArcName:=name_;
End
Else
Begin
name_[i]:='.';
Delete(name_,pos('.ups',name_),4);
DeArcName:=name_;
End;
End;
End;
Function File_.FileSizeWOHead: Integer;
Begin
FileSizeWOHead:=FileSize(f_r)
-{размер исходного файла}4
-{количество оригинальных байт}1
-{количество байтов со статистикой}(Stat.count_byte+1)*5;
End;
// * метод генерации по имени файла имени архива
Function File_.ArcName: String;
Var
i: Integer;
name_: String;
Const
postfix='ups';
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
//ArcName:=Copy(Name,1,i)+postfix;
Name_[i]:='!';
ArcName:=Name_+'.'+postfix;
End;
End;
//процедура сортировки массива с байтами (сортировка производится
//по убыванию частоты байта
procedure sort_mass(var a: bytes_with_stat; length_mass: byte);
var
i,j: Byte;
b: byte_;
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]^.byte_st < a[i+1]^.byte_st
Then
Begin
b:=a[i]; a[i]:=a[i+1]; a[i+1]:=b;
End;
Application.ProcessMessages;
End;
Application.ProcessMessages;
End;
End;
//процедура удаления динамической структуры частотного дерева
//из памяти
Procedure DeleteDr(head: Byte_);
Begin
Application.ProcessMessages;
If head<>nil
Then
Begin
DeleteDr(head^.left);
DeleteDr(head^.right);
Dispose(head);
head:=nil;
End;
End;
//создание дерева частот для архивируемого файла
Procedure CreateDr(var head: byte_; massiv: bytes_with_stat;
last: byte);
var
b: byte_;
Begin
If last<>0
Then
Begin
sort_mass(massiv, last);
new(b);
b^.byte_st:=massiv[last-1]^.byte_st + massiv[last]^.byte_st;
b^.left:=massiv[last-1];
b^.right:=massiv[last];
massiv[last-1]:=b;
/////////////////
if last=1
Then
Begin
head:=b;
End
Else
Begin
CreateDr(head,massiv,last-1);
End;
End
Else
Head:=massiv[last];
Application.ProcessMessages;
End;
var
//экземпляр объекта для текущего сжимаемого файла
main_file: file_;
//процедура для полного анализа частот байтов встречающихся хотя бы
//один раз в исходном файле
procedure stat_file(fname: String);
var
f: file;
i,j: Integer;
buf: Array [1..count] of Byte;
countbuf, lastbuf: Integer;
Begin
AssignFile(f,fname);
Try
Reset(f,1);
Main_file.Stat.create;
Main_file.Size:=FileSize(f);
///////////////////////
countbuf:=FileSize(f) div count;
lastbuf:=FileSize(f) mod count;
////////////
form1.ProgressBar1.Max:=countbuf;
form1.ProgressBar1.Position:=0;
////////////
For i:=1 to countbuf do
Begin
BlockRead(f,buf,count);
for j:=1 to count do
Begin
Main_file.Stat.inc(buf[j]);
Application.ProcessMessages;
End;
Application.ProcessMessages;
form1.ProgressBar1.Position:=form1.ProgressBar1.Position+1;
End;
/////////////
If lastbuf<>0
Then
Begin
BlockRead(f,buf,lastbuf);
for j:=1 to lastbuf do
Begin
Main_file.Stat.inc(buf[j]);
Application.ProcessMessages;
End;
Application.ProcessMessages;
End;
CloseFile(f);
Except
ShowMessage('ошибка доступа к файлу!')
End;
End;
//функция для определения по последовательности сжатых битов
//исходного несжатого байта
Function Found(derevo: byte_; i: byte): Boolean;
Begin
Application.ProcessMessages;
if (derevo=nil)
Then
Found:=False
Else
Begin
if ((derevo^.left=nil) or (derevo^.right=nil))
and (derevo^.byte_id=i)
Then
Found:=True
Else
Found:=Found(derevo^.left, i) or Found(derevo^.right, i);
End;
End;
//функция для определения строкового представления сжатой последовательности
//битов для исходного байта i
Function Id_to_str_(derevo: byte_; i: Byte): String;
Begin
Application.ProcessMessages;
if derevo=nil
Then
id_to_str_:='+=='
Else
Begin
if Found(derevo^.left,i)
Then
id_to_str_:='0'+id_to_str_(derevo^.left,i)
Else
Begin
if Found(derevo^.right,i)
Then
id_to_str_:='1'+id_to_str_(derevo^.right,i)
Else
Begin
If (derevo^.left=nil) and (derevo^.right=nil)
and (derevo^.byte_id=i)
Then
id_to_str_:='+'
Else
id_to_str_:='';
End;
End;
End;
End;
//вспомогательная функция для определения строкового представления
//сжатой последовательности битов для исходного байта i (с учетом
//того экстремального случая, когда исходный файл состоит всего из одного
//и того же байта)
Function Id_to_Str(derevo: byte_; i: Byte): String;
var
s: String;
Begin
s:=Id_To_Str_(derevo, i);
If s='+'
Then
Id_to_Str:='0'
Else
Id_to_Str:=Copy(s,1,length(s)-1);
End;
//процедура записи сжатого потока битов в архив
Procedure Write_in_file(var buffer: String);
var
i,j: Integer;
k: Byte;
s: String;
a: Byte;
buf: Array[1..2*count] of byte;
Begin
i:=Length(buffer) div 8;
//////////////////////////
{Form1.ProgressBar2.Max:=i;
Form1.ProgressBar2.Position:=0;}
/////////////////////////
For j:=1 to i do
Begin
buf[j]:=0;
///////////////////////////
{Form1.ProgressBar2.Position:=Form1.ProgressBar2.Position+1;}
For k:=1 to 8 do
Begin
If buffer[(j-1)*8+k]='1'
Then
buf[j]:=buf[j] or (1 shl (8-k));
Application.ProcessMessages;
End;
Application.ProcessMessages;
End;
BlockWrite(f_w,buf,i);
Delete(buffer,1,i*8);
End;
//процедура для окончательной записи остаточной цепочки битов в архив
Procedure Write_in_file_(var buffer: String);
var
a,k: byte;
Begin
Write_in_file(buffer);
If length(buffer)>=8
Then
ShowMessage('ошибка в вычислении буфера')
Else
If Length(buffer)<>0
Then
Begin
a:=255;
for k:=1 to Length(buffer) do
If buffer[k]='0'
Then
a:=a xor (1 shl (8-k));
BlockWrite(f_w,a,1);
End;
End;
Type
Integer_=Array [1..4] of Byte;
//перевод целого числа в массив из четырех байт.
Procedure Int_to_Byte(i: Integer; var mass: Integer_);
var
a: Integer;
b: ^Integer_;
Begin
b:=@a;
a:=i;
mass:=b^;
End;
//перевод массива из четырех байт в целое число.
Procedure Byte_to_Int(mass: Integer_; var i: Integer);
var
a: ^Integer;
b: Integer_;
Begin
a:=@b;
b:=mass;
i:=a^;
End;
//процедура создания заголовка архива
Procedure Create_Head;
var
b: Integer_;
a: Integer;
i: Byte;
Begin
//Размер несжатого файла
Int_To_Byte(main_file.Size,b);
BlockWrite(f_w,b,4);
//Количество оригинальных байт
BlockWrite(f_w,main_file.Stat.count_byte,1);
//Байты со статистикой
For i:=0 to main_File.Stat.count_byte do
Begin
BlockWrite(f_w,main_File.Stat.massiv[i]^.byte_id,1);
Int_To_Byte(main_file.Stat.massiv[i]^.byte_st,b);
BlockWrite(f_w,b,4);
End;
End;
const
max_count=4096;
type
buffer_=object
b: Array [1..max_count] of Byte;
bcount: Integer;
count_global: Integer;
Procedure Create_buf;
Procedure Insert_byte(a: Byte);
Procedure Flush_buf;
End;
/////////////////////////////
Procedure buffer_.Create_buf;
Begin
bcount:=0;
count_global:=0;
End;
////////////////////////////////////////
Procedure buffer_.Insert_byte(a: Byte);
Begin
if count_global0
Then
BlockWrite(f_w,b,bcount);
End;
//создание деархивированного файла
Procedure Create_De_Arc;
var
i,j: Integer;
k: Byte;
//////////////
buf: Array [1..count] of Byte;
countbuf, lastbuf: Integer;
main_buffer: buffer_;
tek_ukaz: Byte_;
Begin
countbuf:=main_file.FileSizeWOHead div count;
lastbuf:=main_file.FileSizeWOHead mod count;
main_buffer.Create_buf;
tek_ukaz:=main_file.Derevo;
For i:=1 to countbuf do
Begin
BlockRead(f_r,buf,count);
for j:=1 to count do
Begin
for k:=1 to 8 do
Begin
If (buf[j] and (1 shl (8-k)))<>0
Then
tek_ukaz:=tek_ukaz^.right
Else
tek_ukaz:=tek_ukaz^.left;
if (tek_ukaz^.left=nil) or (tek_ukaz^.right=nil)
Then
Begin
main_buffer.Insert_byte(tek_ukaz^.byte_id);
tek_ukaz:=main_file.Derevo;
End;
Application.ProcessMessages;
End;
Application.ProcessMessages;
End;
End;
If lastbuf<>0
Then
Begin
BlockRead(f_r,buf,lastbuf);
for j:=1 to lastbuf do
Begin
for k:=1 to 8 do
Begin
If (buf[j] and (1 shl (8-k)))<>0
Then
tek_ukaz:=tek_ukaz^.right
Else
tek_ukaz:=tek_ukaz^.left;
if (tek_ukaz^.left=nil) or (tek_ukaz^.right=nil)
Then
Begin
main_buffer.Insert_byte(tek_ukaz^.byte_id);
tek_ukaz:=main_file.Derevo;
End;
Application.ProcessMessages;
End;
Application.ProcessMessages;
End;
End;
main_buffer.Flush_buf;
End;
//процедура чтения заголовка архива
Procedure Read_Head;
var
b: Integer_;
byte_st: Integer;
count_, byte_id, i, j: Byte;
Begin
try
//узнаем исходный размер файла
BlockRead(f_r,b,4);
Byte_to_Int(b,main_file.size);
{}{}{}
form1.label1.Caption:='size='+inttostr(main_file.size);
{}{}{}
//узнаем количество оригинальных байтов
BlockRead(f_r,count_,1);
{}{}{}
form1.label1.Caption:=form1.label1.Caption+#13+'colbyte='+inttostr(count_);
{}{}{}
main_file.Stat.create;
main_file.Stat.count_byte:=count_;
//загоняем частоты в массив
for i:=0 to main_file.Stat.count_byte do
Begin
BlockRead(f_r,byte_id,1);
main_file.Stat.massiv[i]^.byte_id:=byte_id;
BlockRead(f_r,b,4);
Byte_to_Int(b,byte_st);
main_file.Stat.massiv[i]^.byte_st:=byte_st;
{}{}{}
//form1.label1.Caption:=form1.label1.Caption+#13+'byte_id='+chr(byte_id)+#9+'byte_st='+inttostr(byte_st);
{}{}{}
End;
CreateDr(main_file.Derevo,main_file.stat.massiv,main_file.stat.count_byte);
/////////////
/////////////
/////////////
/////////////
form1.Memo2.text:=inttostr(main_file.Size)+#13#10;
with main_file do
for j:=0 to main_file.Stat.count_byte do
form1.Memo2.Text:=form1.Memo2.Text+IntToStr(j)+#9+IntToStr(stat.massiv[j]^.byte_st)
+#9+{Chr(stat.massiv[j]^.byte_id)+}'='+IntToStr(stat.massiv[j]^.byte_id)+#9+Id_to_str(derevo,stat.massiv[j]^.byte_id)+#13#10;
/////////////
/////////////
form1.ProgressBar2.Position:=0;
form1.ProgressBar2.Max:=main_file.size div 100;
/////////////
/////////////
Create_De_Arc;
//////////////
DeleteDr(main_file.Derevo);
except
ShowMessage('архив испорчен!');
//application.terminate;
End;
End;
//процедура извлечения архива
Procedure Extract_File;
Begin
AssignFile(f_r,main_file.Name);
AssignFile(f_w,main_file.DeArcName+' new');
try
reset(f_r,1);
rewrite(f_w,1);
Form1.ProgressBar2.Position:=0;
Form1.ProgressBar2.Max:=main_file.Size;
//процедура чтения шапки файла
read_head;
closefile(f_r);
closefile(f_w);
Form1.label5.Caption:='extracting complete!';
form1.Button1.Enabled:=True;
form1.Button2.Enabled:=True;
Except
ShowMessage('Ошибка распаковки файла');
End;
End;
//вспомогательная процедура для создания архива
Procedure Create_Arc;
var
buffer: String;
Array_St: Array [0..255] of String;
i,j: Integer;
//////////////
buf: Array [1..count] of Byte;
countbuf, lastbuf: Integer;
Begin
Form1.Label4.Caption:='Wait';
Application.ProcessMessages;
AssignFile(f_r,main_file.Name);
AssignFile(f_w,main_file.ArcName);
Try
Reset(f_r,1);
Rewrite(f_w,1);
For i:=0 to 255 Do Array_St[i]:='';
For i:=0 to Main_file.Stat.count_byte do
Begin
Array_St[Main_file.Stat.massiv[i]^.byte_id]:=
Main_file.Stat.massiv[i]^.byte_string;
Application.ProcessMessages;
End;
countbuf:=main_file.Size div count;
lastbuf:=main_file.Size mod count;
Buffer:='';
/////////////
Form1.ProgressBar3.max:=countbuf;
Form1.ProgressBar3.Position:=0;
/////////////
Create_Head;
/////////////
for i:=1 to countbuf do
Begin
BlockRead(f_r,buf,count);
//////////////////////
Form1.ProgressBar3.Position:=Form1.ProgressBar3.Position+1;
For j:=1 to count do
Begin
buffer:=buffer+Array_St[buf[j]];
If Length(buffer)>8*count
Then
Write_in_file(buffer);
Application.ProcessMessages;
End;
End;
If lastbuf<>0
Then
Begin
BlockRead(f_r,buf,lastbuf);
For j:=1 to lastbuf do
Begin
buffer:=buffer+Array_St[buf[j]];
If Length(buffer)>8*count
Then
Write_in_file(buffer);
Application.ProcessMessages;
End;
End;
Write_in_file_(buffer);
CloseFile(f_r);
CloseFile(f_w);
Form1.Label4.Caption:='O'' Kay!';
Except
ShowMessage('Ошибка создания архива');
End;
End;
//главная процедура для создания архивного файла
Procedure Create_File;
var
i, j: Byte;
//mass: Bytes_with_stat;
Begin
with form1 do
Begin
memo1.Text:='';
With main_file do
Begin
{сортировка массива байтов с частотами}
sort_mass(stat.massiv,stat.count_byte);
{поиск числа задействованных байтов}
i:=0;
While (i0) do
Begin
inc(i);
End;
//////////////////////
If Stat.massiv[i]^.byte_st=0
Then
i:=i-1;
//////////////////////
Stat.count_byte:=i;
{создание дерева частот}
CreateDR(Derevo,Stat.massiv,Stat.count_byte);
{вывод на экран отчета}
memo1.text:=inttostr(main_file.size)+#13#10;
for j:=0 to i do
Memo1.Text:=Memo1.Text+IntToStr(j)+#9+IntToStr(stat.massiv[j]^.byte_st)
+#9+{Chr(stat.massiv[j]^.byte_id)+}'='+IntToStr(stat.massiv[j]^.byte_id)+#9+Id_to_str(derevo,stat.massiv[j]^.byte_id)+#13#10;
{запоминаем результаты работы дерева}
for i:=0 to Stat.count_byte do
Stat.massiv[i]^.byte_string:=Id_to_str(Derevo,stat.massiv[i]^.byte_id);
//пишем сам файл
Create_Arc;
//Удаляем уже ненужное дерево
DeleteDr(Derevo);
//Инициализируем статистику файла
Main_file.Stat.create;
End;
End;
End;
procedure TForm1.Button1Click(Sender: TObject);
begin
If OpenDialog1.Execute
Then
Begin
main_file.Name:=OpenDialog1.FileName;
main_file.Stat.create;
stat_file(main_file.Name);
create_file;
End;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
If OpenDialog2.Execute
Then
Begin
Main_File.Name:=Form1.Opendialog2.FileName;
label5.Caption:='';
form1.Button1.Enabled:=false;
form1.Button2.Enabled:=false;
Extract_file;
End;
end;
end.
Главная страница.
