Новичок
Джуниор
Регистрация: 20.01.2016
Сообщений: 2
|
Архиватор на основе кода Хаффмана(Pascal)
Надо сделать архиватор на основе кода хаффмана
Этот код кодирует, но не архивирует, преподаватель говорит доделать надо
Из 3 мб текста, делает 43 мб(PascalABC.NET)
Код:
type
AlfavitType = record
ch: char;
count: integer;
pr: boolean;
code:string;
end;
mas = array[,] of AlfavitType;
var
n: integer;
m: mas;
st:string;
procedure vv(var m: mas);
var
i: integer;
f: text;
Alfavit: string;
ch: char;
countChar: array of integer;
begin
AssignFile(f, 'Кочерга.txt');//связываем
reset(f);//открытие на чтение
Alfavit := '';//инициализиция строки
while not eof(f) do //начало цикла. Цикл выполняется,пока не считаются все символы из файла
begin
read(f, ch); //считывание символа в ch
if pos(ch, Alfavit) = 0 then //проверяем,был ли считан этот символ
Alfavit := Alfavit + ch;//если символ не был считан,то дописываем в Alfavit
end;
reset(f);
SetLength(countChar, Length(Alfavit) + 1);//формируем массив разрядностью в количество символов алфавита+1
for i := 0 to Length(Alfavit) do
countChar[i] := 0;//инициализация массива
while not eof(f) do
begin
read(f, ch);
inc(countChar[pos(ch, Alfavit)]);//увеличиваем частоту встречаемости каждого символа
inc(countChar[0]);//увеличиваем общее колличество символов
end;
n := Length(Alfavit); //присваиваем переменной количество символов алфавита
SetLength(m, n + 1,n);//формируем массив размерностью n+1 на n элементов
CloseFile(f);
for i := 1 to n do
begin
m[i,1].ch := Alfavit[i]; //символ
m[i,1].count := countChar[i];//количество в тексте
end;
end;
procedure out(m: mas);
var
i: integer;
begin
for i := 1 to n do
begin
writeln(m[i,1].ch, m[i,1].count:5, m[i,1].code:16);//Выводим символ, отводим 5 позиций на количество и 16 на код
end;
end;
procedure sort(var m: mas;z:integer);
var
buf: AlfavitType;
i, j, k, d: integer;
begin
d := 1; i := 0; //присвоение начальных значений
for k := n - 1 downto 1 do
begin
i := i + d;
for j := 1 to k do //цикл сортировки
begin
if (m[i,z].count - m[i + d,z].count) * d < 0 then //проверка на минимум при d=1 и на максимум при d=-1
begin buf := m[i,z]; m[i,z] := m[i + d,z]; m[i + d,z] := buf; end; //обмен значений
i := i + d;
end;
d := -d;
end;
end;
//формирование таблицы значений
procedure pryamo(var m:mas);
var i,j:integer;
begin
for j:=2 to n-1 do//идем по столбцам
begin
for i:=1 to n-j do//по строке
m[i,j].count:=m[i,j-1].count;//все кроме последнего списываем
m[n-j+1,j].count:=m[n-j+1,j-1].count+m[n-j+2,j-1].count;
m[n-j+1,j].pr:=true;
sort(m,j);
end;
end;
//формирование кодов символов
procedure obratno(var m:mas);
var i,j,q:integer;
begin
m[1,n-1].code:='0';//
m[2,n-1].code:='1';//Начальные коды для символов
for j:=n-2 downto 1 do
begin
for i:=1 to n-j+1 do
if not m[i,j+1].pr then m[i,j].code:=m[i,j+1].code//если не путем суммирования, то переносим значения
else begin for q:=i to n-j-1 do
m[q,j].code:=m[q+1,j+1].code;//иначе переносим со сдвигом
break;//прервали цикл
end;
m[n-j,j].code:=m[i,j+1].code+'0';
m[n-j+1,j].code:=m[i,j+1].code+'1';
for i:=i+1 to n-j+1 do//возобновили цикл
if m[i,j].code=' ' then
m[i,j].code:=m[i,j+1].code
end;
end;
procedure zero(var m:mas; var st:string);
var i,ma:integer;
begin
ma:=16;
st:='';
for i:=1 to n do
begin
if Length(m[i,1].code)<ma then
while Length(m[i,1].code)<ma do
m[i,1].code:=m[i,1].code+'0';//длинна должна быть = 16,если < добавляем 0
st:=st+m[i,1].ch;
end;
end;
procedure cod();
var f1,f2:text; i:integer; c:char;
begin
assign(f1,'Кочерга.txt');
reset(f1);
Assign(f2,'out_text.txt');
rewrite(f2);//открываем на запись
writeln(f2,n);//записываем количество символов алфавита и переходим на новую строку
for i:=1 to n do
writeln(f2,m[i,1].ch, m[i,1].code);//записываем символ и его код в файл
while not Eof(f1) do //цикл,пока не достигнут конец первого файла,то кодируем по одному символу,записывая во второй файл
begin
read(f1,c);
write(f2,m[pos(c,st),1].code);
end;
close(f1);
close(f2);
end;
begin
vv(m);
sort(m,1);
pryamo(m);
obratno(m);
zero(m,st);
out(m);
cod();
end.
Последний раз редактировалось serg_linkin1925; 20.01.2016 в 20:14.
|