Форум программистов
 
Регистрация на форуме тут, о проблемах пишите сюда - alarforum@yandex.ru, проверяйте папку спам! Обязательно пройдите активизацию e-mail, а тут можно восстановить пароль

Купить рекламу на форуме 15-35 тыс рублей в месяц

Вернуться   Форум программистов > Delphi программирование > Паскаль, Turbo Pascal, PascalABC.NET
Регистрация

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

           Online-курс Java с оплатой после трудоустройства. Каждый выпускник получает предложение о работе
           И зарплату на 30% выше ожидаемой, подробнее на сайте академии, ссылка - https://clck.ru/fCqwP

Ответ
 
Опции темы Поиск в этой теме
Старый 21.06.2022, 09:29   #1
kontemar
Новичок
Джуниор
 
Регистрация: 23.08.2012
Сообщений: 1
По умолчанию Алгоритм Хаффмана для сжатия данных

Есть код, который должен сжимать данные по алгоритму Хаффмана, но почему-то на выходе выдает совсем не тот результат, который должен. Берется слово из файла, затем преобразуется в последовательность чисел, считаются частоты, с которыми появляются те или иные буквы, после чего выводится результат, и соответственно меняется размер файла, но цифры не соответствуют. Помогите, пожалуйста понять в чем ошибка или упростите мой код, желательно с комментариями, чтобы знать в чем ошибка.
Код:
uses crt;
type
  mas=array[1..100]of real;
  var tex:text;
      s:array[1..10000]of char;
      sum,tmp:real;
      i,j,n:byte;
      a,kl:array[1..100]of integer;
      p:array[1..100]of real;
      c:array[1..50,1..50] of 0..1;
      kol:integer;
      bol:boolean;
  function delen(b,e:byte):byte;
  var i,m:byte;
      sb,se,d:real;
  begin
   sb:=0;
         for i:=b to e-1 do
             sb:=sb+p[i];
    se:=p[e];
    m:=e;
    repeat
         d:=sb-se;
         m:=m-1;
         sb:=sb-p[m];
         se:=se+p[m];
    until abs(sb-se)>=d;
    delen:=m; 
  end;
  procedure haffman(b,e,k:byte);
  var m,i:byte;
  begin
     if e>b then
      begin
           inc(k);
           m:=delen(b,e);
           for i:=b to e do
               if i>m then begin c[i,k]:=1; inc(kl[i]); end
               else begin c[i,k]:=0; inc(kl[i]); end;
           haffman(b,m,k);
           haffman(m+1,e,k);
      end;
  end;
  procedure fail;
  var t,l:boolean;
      d:integer;
      i,j,h,k:integer; 
  begin
   k:=1;
   n:=0;
   kol:=0;
   assign(tex,'222.txt');
   reset(tex);
   while not Eoln(tex)do 
     begin
      inc(kol);
      read(tex,s[kol]);
     end;
  writeln('Кол-во символов:',kol);
   while not Eoln(tex) do
     for i:=1 to kol do read(tex,s[i]);
   for i:=1 to kol do
   begin
     for j:=i to kol do
       begin
        t:=true;
        for h:=1 to i-1 do
          if (s[i]=s[i-h]) then
                                begin
                                 t:=false;
                                 break;
                                end
                             else t:=true;
    if (s[i]=s[j])and(t=true) then  a[k]:=a[k]+1; 
   end; 
   inc(k);
  end;
  close(tex);
  for i:=1 to kol do  write(s[i],' '); 
  writeln; 
  for k:=1 to kol do   write(a[k],' ');
  for k:=1 to kol do
     if a[k]<>0 then n:=n+1;
  i:=1;
  for k:=1 to kol do
    if a[k]<>0 then
     begin
      a[i]:=a[k];
      inc(i);
     end; 
  while  l do
   begin
    l:=false;
    for i:=1 to n-1 do
     if a[i]<a[i+1] then
      begin
       d:=a[i+1];
       a[i+1]:=a[i];
       a[i]:=d;
       l:=true;
      end;
   end;
  writeln;
  end;
  begin 
  clrscr;
  fail; 
  sum:=0;
  for i:=1 to n do
    begin
     p[i]:=a[i]/kol;
     sum:=sum+p[i];
    end; 
  repeat
     bol:=false;
     for i:=1 to n-1 do
          if p[i]<p[i+1] then
                         begin
                         bol:=true;
                         tmp:=p[i];
                         p[i]:=p[i+1];
                         p[i+1]:=tmp;    
                         end;
until bol=false;
  for i:=1 to n do writeln('p[',i:2,']=  ',p[i]:4:3);
   writeln; 
   writeln('Зашифрованное слово: ');
      haffman(1,n,0);
      for i:=1 to n do
       begin
          for j:=1 to kl[i] do write(c[i,j]);
           writeln;
       end;
  readkey;
  end.
http://it-informs.ru
kontemar вне форума Ответить с цитированием
Старый 21.06.2022, 15:03   #2
macomics
Форумчанин
 
Регистрация: 17.04.2022
Сообщений: 467
По умолчанию

Цитата:
Сообщение от kontemar Посмотреть сообщение
Код:
assign(tex,'222.txt');
   reset(tex);
   while not Eoln(tex)do 
     begin
      inc(kol);
      read(tex,s[kol]);
     end;
  writeln('Кол-во символов:',kol);
   while not Eoln(tex) do
Вы же и так уже в конце строки, второй while просто не сработает
Не проще прочитать ReadLn всю строку и затем уже выполнять сцепление строк.

Ужасно написано в целом.
Цитата:
Сообщение от kontemar Посмотреть сообщение
Код:
if (s[i]=s[i-h]) then
                                begin
                                 t:=false;
                                 break;
                                end
                             else t:=true;
Зачем здесь else?

Цитата:
Сообщение от kontemar Посмотреть сообщение
Код:
for i:=1 to kol do
   begin
     for j:=i to kol do
       begin
        t:=true;
        for h:=1 to i-1 do
          if (s[i]=s[i-h]) then
                                begin
                                 t:=false;
                                 break;
                                end
                             else t:=true;
    if (s[i]=s[j])and(t=true) then  a[k]:=a[k]+1; 
   end; 
   inc(k);
  end;
Пытаюсь понять что вы вообще в целом здесь считаете. Если вложенный for начинается c i, тогда условие как минимум 1 раз проверит каждый символ на равенство с самим собой (if s[i]=s[i]...)
В остальных случаях это выглядит как проверка на появление символа менее 2-х раз (если бы не for j := i ).
Вообще if s[i]=s[j] стоит проверить сразу на входе в цикл for до запуска вложенного цикла по h. Тогда вы избавитесь от лишних проходов цикла по h.

Последний раз редактировалось macomics; 21.06.2022 в 15:50.
macomics вне форума Ответить с цитированием
Ответ

           Интенсив по Python: Работа с API и фреймворками 24-26 ИЮНЯ 2022. Знаете Python, но хотите расширить свои навыки?
           Slurm подготовили для вас особенный продукт! Оставить заявку по ссылке - https://slurm.club/3MeqNEk

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

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


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Алгоритм сжатия Хаффмана (найти ошибки), Pascal WestCoast Фриланс 0 16.01.2014 20:28
Алгоритм сжатия LZW dollemika Помощь студентам 11 20.06.2012 07:40
Алгоритм сжатия jpeg VARCHUN Помощь студентам 0 08.05.2012 17:01
Алгоритм сжатия Хаффмана onryo Общие вопросы Delphi 0 10.04.2011 16:08
Алгоритм сжатия+ zlib Воин-Леший Общие вопросы Delphi 1 09.12.2007 15:05