Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > IT форум > Помощь студентам
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 20.01.2016, 20:10   #1
serg_linkin1925
Новичок
Джуниор
 
Регистрация: 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.
serg_linkin1925 вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
PascalABCNet архиватор на основе кода Хаффмана a_clarke Помощь студентам 0 10.10.2015 22:23
Архиватор Хаффмана zetrix Софт 17 15.03.2014 13:45
Архиватор на основе своего алгоритма шифрования FOXKILLER1 Фриланс 3 12.03.2013 18:23
Архиватор Хаффмана на Delphi Natka.Elka Помощь студентам 0 08.12.2011 18:46
Архиватор методом Хаффмана на Delphi Natka.Elka Помощь студентам 5 07.12.2011 20:05