Арифметическое кодирование

– М.: ДИАЛОГ-МИФИ, 2003. – 384 с.Данелян Т.Я. Учебно-методический комплекс «Общая теория информации для IT-специалистов»: учебное пособие / Данелян Т.Я., Спирьянов О.А. – М.: Русайнс, 2021. – 126 с. Идея арифметического кодирования. – [Электронный ресурс] – URL: https://algolist.manual.ru/compress/standard/arithm.php. – Режим доступа: 09.10.2022Лекции по курсу «Методы кодирования информации». – [Электронный ресурс] – URL:https://scask.ru/a_lect_cod.php. – Режим доступа: 09.10.2022Лидовский В. В. Теория информации: Учебное пособие. – М.: Компания Спутник+, 2004.Литвинская О. С. Основы теории передачи информации : учебное пособие / О. С. Литвинская, Н. И. Чернышев. – М.: КноРус, 2022. – 168 с. – URL: https://book.ru/books/944119. – Режим доступа: по подпискеМаскаева А. М. Основы теории информации: справочник : учебное пособие / А.М. Маскаева. – М.: ИНФРА-М, 2021. – 194 с.Осокин А. Н. Теория информации : учебное пособие для СПО / А. Н. Осокин, А. Н. Мальчуков. – Москва : Издательство Юрайт, 2019. – 205 с.Сжатиеинформациибезпотерь. Частьвторая. – [Электронный ресурс] – URL: https://habr.com/ru/post/142492/. – Режим доступа: 09.10.2022Принцип и реализация арифметического кодирования [воспроизведено] [Электронный ресурс] – URL: https://russianblogs.com/article/99141233612/. – Режим доступа: 09.10.2022ПРИЛОЖЕНИЕЛистинг программы ArithCodeProcedure program ArithCode;{ Адаптивное арифметическое кодирование на основе побитового Кодируем входной файл (infile) в _out.ar Декодируем входной файл (infile) в _ar.unp}{$APPTYPE CONSOLE}usesSysUtils;constBITS_IN_REGISTER = 16; { Количество битов в регистре } { Максимально возможное значение в регистре }TOP_VALUE = LongInt((1 shl BITS_IN_REGISTER)-1);{ Диапазоны }FIRST_QTR = ( TOP_VALUE div 4 + 1 ); HALF = ( 2 * FIRST_QTR ); THIRD_QTR = ( 3 * FIRST_QTR ); NO_OF_CHARS = 256; { Количество символов алфавита  }EOF_SYMBOL = ( NO_OF_CHARS + 1 );{ Символ конца файла  }NO_OF_SYMBOLS = ( NO_OF_CHARS + 1 ); { Всего символов в модели }MAX_FREQUENCY = $3FFF; { Максимум частоты для масштабирования - 16383}BufSize = $8000; { Размер буфера }EncRegime = 0; DecRegime = 1;Type{ Таблицы перекодировки }tIndex2Char = array [ 0 .. NO_OF_SYMBOLS - 1 ] of Byte; tChar2Index = array [ 0 .. NO_OF_CHARS ] of Integer;{ Таблицы частот }tFreq = array [ 0 .. NO_OF_SYMBOLS] of Integer; tBuf = array [ 1 .. BufSize ] of Byte; pBuf = ^tBuf; tDataFile = recordF :File; BlockSize :Integer; BlockCounter :Word; counter, FSize :LongInt; _EOF, error :Boolean; Buf : pBuf; //для поддержки битовых операцийend; tBitBuf = Word; tTime = recordHour, Min, Sec, Sec100 :Word;end; tFileName = String [79];Varindex_to_char : tIndex2Char; char_to_index : tChar2Index; cum_freq, freq : tFreq;{ Регистры границы подынтервалов и кода сообщения  }low, high, value:LongInt;{ Поддержка побитовых операций с файлами }bits_to_follow :LongInt; FC :LongInt;{ Переменные для работы с файлами и буфером }InFile, OutFile : tDataFile; BitBuf : tBitBuf; BitBufCounter :Byte; StartTime, FinTime : tTime;//---------------------------------------------------------------------------Procedure PrintNotExist ( Name : tFileName);{ Вывод сообщения о невозможности открыть файл (или его отсутствии) }beginWriteln ( 'Невозможно открыть файл или он отсутствует ', Name);end;Procedure PrintUsage;{ Вывод сообщения об использовании}beginWriteLn ( #13#10'Использование : ');end;Procedure FillMainBuf ( var DataFile : tDataFile);begin with DataFile do beginBlockRead ( F, Buf^, BufSize, BlockSize);if BlockSize = 0 then _EOF := true;end;end;Procedure WriteMainBuf ( var DataFile : tDataFile);varresult:Integer;begin with DataFile do beginBlockWrite ( F, Buf^, BlockSize, result);if result <> BlockSize then error := true;end;end;Procedure RdByte ( var DataFile : tDataFile; var RdData : Byte);begin with DataFile do begininc (BlockCounter); RdData := Buf^ [ BlockCounter ];if BlockCounter = BlockSize then beginFillMainBuf (DataFile); BlockCounter := 0; Counter := Counter + BlockSize;end;end;end;Procedure WrByte ( var DataFile : tDataFile; WrData : Byte);varp : ^Byte;begininc ( FC );with DataFile do begininc (BlockCounter); Buf^ [ BlockCounter ] := WrData;if BlockCounter = BlockSize then beginWriteMainBuf (DataFile); BlockCounter := 0;end end;end;Procedure WrBit (Bit :Byte);beginasmshr Bit, 1rcl BitBuf, 1end; dec (BitBufCounter);if BitBufCounter = 0 then beginWrByte ( OutFile, BitBuf); BitBufCounter := 16end;end;Procedure WrBits (WrData :Word; _size :Byte);vari :Byte;beginWrData := WrData shl (16 - _size);for i := 1 to _size do beginasmshl WrData, 1rcl BitBuf, 1dec BitBufCounterend;if BitBufCounter = 0 then beginWrByte ( OutFile, Hi (BitBuf)); WrByte ( OutFile, Lo (BitBuf)); BitBufCounter := 16end;end;end;Function RdBits( _size : Byte) :Word;varReturnValue :Word; i :Byte; a, b :Byte;beginReturnValue := 0;if BitBufCounter = 0 then beginRdByte(InFile, a); RdByte(InFile, b); BitBuf := (word (a) shl 8) or b; BitBufCounter := 16;end;for i := 1 to _size do beginasmshl BitBuf, 1rcl ReturnValue, 1dec BitBufCounterend;if BitBufCounter = 0 then beginRdByte(InFile, a); RdByte(InFile, b); BitBuf := (word (a) shl 8) or b; BitBufCounter := 16;end;end; RdBits := ReturnValue;end;{Вывод очередного блока в выходной файл}Procedure WrLastBytes;beginasm mov CL, BitBufCountershl BitBuf, CLend; WrByte ( OutFile, Hi (BitBuf) );if BitBufCounter < 8 thenWrByte ( OutFile, Lo (BitBuf) );end;{Заполнение данных о входном и выходном файлах, инициализация буфера}Procedure PrepareDataFiles ( InFileName, OutFileName : tFileName);begin with InFile do beginassign ( F, InFileName); reset ( F, 1); BlockCounter := 0; counter := 0; _EOF := false; error := false; FSize := FileSize (F);New(Buf);end;with OutFile do beginAssign(F, OutFileName); Rewrite(F, 1); BlockSize := BufSize; WriteLn(BlockSize); BlockCounter := 0; counter := 0; _EOF := false; error := false; GetMem ( Buf, BufSize);end; WriteLn ('Прогресс : ');end;{Вывод информации о соотношении сжатого и исходного файлов}Procedure PrintRatio ( Regime : Byte);varpercent :Real;beginWrite ( 'Сжатие : ');if Regime = EncRegime thenpercent := OutFile.FSize / InFile.FSizeelsepercent := InFile.FSize / OutFile.FSize; WriteLn ( percent * 100 : 4 : 1, '%'#13#10,'Размер входного файла  : ', InFile.FSize, #13#10,'Размер выходного файла  : ', OutFile.FSize);end;{Закрытие файла с очисткой буфера}Procedure DoneDataFiles;varTimeDiff :Real;begin with InFile do beginFreeMem ( Buf, BufSize); close (F);end;with OutFile do beginBlockSize := BlockCounter; WriteMainBuf (OutFile); Dispose ( Buf ); FSize := FileSize (F); close (F);end;with FinTime do beginGetTime;if (Hour = 0) and (StartTime.Hour = 23) then Hour := 24;{$q-}TimeDiff := Hour * 3600 + Min * 60 + Sec + Sec100 / 100 -(StartTime.Hour * 3600 + StartTime.Min * 60 + StartTime.Sec +StartTime.Sec100 / 100); WriteLn ( #13#10'Время : ', TimeDiff :6 : 2, ' c');end;end;//-----------------------------------------------------{ПРоцедуры и функции для побитового вывода}{Вывод указанного бита и отложенных ранее}Procedure output_bit_plus_follow ( bit : Integer);beginWrBits ( bit, 1 );if bits_to_follow > 0 then beginWrBits ( Byte ( not ( bit ) ), 1 ); dec ( bits_to_follow );end;while bits_to_follow > 0 do begin if bits_to_follow >= 16 then begin if bit = 1 then WrBits ( 0, 16 )else WrBits ( $FFFF, 16 ); bits_to_follow := bits_to_follow - 16;end else begin if bit = 1 then WrBits ( 0, bits_to_follow )else WrBits ( (1 shl bits_to_follow) - 1, bits_to_follow ); bits_to_follow := 0;end;end;end;{Очистка побитового вывода }Procedure done_encoding;begininc ( bits_to_follow );if (low < FIRST_QTR) thenoutput_bit_plus_follow (0)elseoutput_bit_plus_follow (1);end;//----------------------------------------------------{Подготовка к кодированию и декодированию}{Инициализация регистров границ и кода перед началом сжатия}Procedure start_encoding;beginlow := 0; high := TOP_VALUE; bits_to_follow := 0;end;{Инициализация регистров перед декодированием.Загрузка начала сжатого сообщения}Procedure start_decoding;vari :Integer;beginvalue:= RdBits ( 16 ); low := 0; high := TOP_VALUE;end;//--------------------------------------------------------------{Реализация алгоритма арифметического кодирования}{ Кодирование очередного символа }Procedure encode_symbol ( symbol : Integer);varrange :LongInt;begin// пересчет значений границrange := LongInt ((high - low) + 1); high := low + ((range * cum_freq [symbol - 1]) div cum_freq [0]) - 1; low := low + ((range * cum_freq [symbol]) div cum_freq [0]);//выдвигание очередных битовrepeat if (high < HALF) thenoutput_bit_plus_follow (0)else if (low >= HALF) then beginoutput_bit_plus_follow (1); dec ( low, HALF ); dec ( high, HALF );end else if (low >= FIRST_QTR) and (high < THIRD_QTR) then begininc ( bits_to_follow ); dec ( low, FIRST_QTR ); dec ( high, FIRST_QTR );end elsebreak;//сдвиг влево с "втягиванием" очередного бита low := low shl 1; high := high shl 1 + 1;until false;end;{Декодирование очередного символа }Function decode_symbol :Integer;varrange :LongInt; cum, symbol :Integer;begin//определение текущего масштабаrange := (high - low) + 1;// масштабирование значения в регистре кода cum := Integer(( ( LongInt (value - low) + 1) * cum_freq [0] - 1) div range);// поиск соответствующего символа в таблице частотsymbol := 1;while cum_freq [symbol] > cum do inc ( symbol );// пересчет границhigh := low + (range * cum_freq [symbol - 1]) div cum_freq [0] - 1; low := low + (range * cum_freq [symbol]) div cum_freq [0];// удаление очередного символа из входного потока repeat if (high < HALF) then else if (low >= HALF) then begindec ( value, HALF ); dec ( low, HALF ); dec ( high, HALF );end else if (low >= FIRST_QTR) and (high < THIRD_QTR) then begindec ( value, FIRST_QTR ); dec ( low, FIRST_QTR ); dec ( high, FIRST_QTR );end elsebreak;//сдвиг влево с втягиванием очередного бита low := low shl 1; high := high shl 1 + 1;value:= value shl 1 + RdBits ( 1 );until false; decode_symbol := symbol;end;//------------------------------------------------------------ {Реализация адаптивной модели}{Инициализация адаптивной модели}Procedure start_model;vari :Integer;begin for i := 0 to NO_OF_CHARS - 1 do beginchar_to_index [i] := i + 1; //Установка таблиц перекодировкиindex_to_char [i + 1] := i; // между исходными и рабочими символамиend;for i := 0 to NO_OF_SYMBOLS do beginfreq [i] := 1; //Установка значений счетчиковcum_freq [i] := NO_OF_SYMBOLS - i; //частот в 1 для всех символовend; freq[0]:= 0; //чтобы задать отличие от freq[1]end;{Обновление модели очередным символом}Procedure update_model ( symbol : Integer);vari, ch_i, ch_symbol, cum :Integer;begin//проверка на переполнение счетчика частоты }if (cum_freq [0] = MAX_FREQUENCY) then begincum := 0;// масштабирование частот при переполненииfor i := NO_OF_SYMBOLS downto 0 do beginfreq [i] := (freq [i] + 1) div 2; cum_freq [i] := cum; cum := cum + freq [i];end;end; i := symbol;while freq [i] = freq [i - 1] do dec ( i );//Обновление перекодировочных таблиц, если символ перемещаетсяif (i < symbol) then beginch_i := index_to_char [i]; ch_symbol := index_to_char [symbol]; index_to_char [i] := ch_symbol; index_to_char [symbol] := ch_i; char_to_index [ch_i] := symbol; char_to_index [ch_symbol] := i;end;//обновление значений в таблицах частотinc ( freq [i] );while (i > 0) do begindec ( i ); inc ( cum_freq [i] );end end;{Непосредственно адаптивное арифметическое кодирование}Procedure Encoding(InFileName, OutFileName : tFileName);varch, symbol :Integer; rdD :byte;beginWriteln('Кодирование...'); FC := 0;//считываение файлаPrepareDataFiles ( InFileName, OutFileName); BitBufCounter := 16; //размер буфераFillMainBuf (InFile); start_model; //начальные установки моделиstart_encoding; //начальные установки кодированияch:=0;repeat //проходим, пока не закодируем все символыrdD:=Byte(ch); //считываем символRdByte(InFile, rdD); //получаем его кодsymbol := char_to_index [rdD]; //выбираем из моделиencode_symbol (symbol); //кодируем символupdate_model (symbol); //обновляем модельuntil InFile._EOF; encode_symbol (EOF_SYMBOL); //кодируем конец файлаdone_encoding; //завершаем сбор последовательности битовif BitBufCounter <> 16 then WrLastBytes; DoneDataFiles; //Закрываем файлPrintRatio (EncRegime); //вывод информации о сжатии файлаend;{Непосредственно адаптивное арифметическое декодирование}Procedure Decoding ( InFileName, OutFileName : tFileName);varch, symbol :Integer;beginPrepareDataFiles ( InFileName, OutFileName ); BitBufCounter := 0; FillMainBuf (InFile);//считываем код из файлаstart_model; //подготовка моделиstart_decoding; //задание начальных установок декодированияrepeatsymbol := decode_symbol; //непосредственно декодированиеif (symbol = EOF_SYMBOL) thenbreak; ch := index_to_char [symbol];//вывод текущего символа в выходной файлWrByte(OutFile, Byte(ch)); update_model (symbol); //обновление модели после очередного шагаuntil false;if symbol <> EOF_SYMBOL thenWriteLn ( #13#10'Ошибка : не найден символ конца файла '); DoneDataFiles;//Закрытие файлаPrintRatio(DecRegime); //вывод информации о сжатии файлаend;//------------------------------------------------------------ { Процедура вызова кодирования/декодирования }Procedure StartAlg;var FileName :string; ParamCode :integer; myFile : TextFile; data :string;begin with StartTime doGetTime; Writeln('Введите имя файла (с расширением):'); Readln(FileName);if Length(FileName) > 0 then beginWriteln('Выберите операцию: 0 - кодирование, 1 - декодирование:'); Readln(ParamCode);if FileExists(FileName) then begin if ParamCode = 0 thenEncoding(FileName, '_out.ar')elseDecoding(FileName, '_ar.unp');end elsePrintNotExist(FileName)end elsePrintUsage;end;BEGINStartAlg; Readln;END.