Алгоритм сжатия Lzg

valdimir Вс Апр 24, 2016 3:59 pm

Написал небольшой алгоритм сжатия в пределах 300 строк кода основанный на LZ77. Алгоритм байт ориентированный. Сжимает немного хуже, чем Zip. Может кому будет интересно.

Код:

Код:: ' lzg.bas Type Cep ' тип таблицы цепочек pred As UShort ' указатель на индекс предыдущей ячейки в цепочке sled As UShort ' указатель на индекс следующей ячейки в цепочке ukaz As ULong ' указатель на совпадение в предыдущем месте массива perv As Byte ' флаг, если =1 значит указатель пред. ссылается на таблицу поиска End Type Type Hesh ' тип хешей hesh2 As UShort ' хеш на 2 байта hesh3 As UShort ' хеш на 3 байта hesh4 As UShort ' хеш на 4 байта End Type Type Uchastok ' тип поиска блока в массиве байтов adres As ULong ' адрес начала dlina As ULong ' количество байтов End Type ' скорость упаковки/распаковки около 1,5 МБ/сек и 50 МБ/сек соответственно Dim Shared As UShort poiskx(),sh_zv() Dim Shared As Cep Ptr cep2,cep3,cep4 Function V_HESH(adres_ukaz As UByte Ptr) As Hesh ' вычисление хешей (2,3,4) для блока из 4 байтов ' на входе 1-байтный указатель на первый байт блока данных (на 4 байта) в исходном массиве Dim As UShort Ptr b1b2=adres_ukaz,b2b3=adres_ukaz+1,b3b4=adres_ukaz+2,b4b5=adres_ukaz+3 ' устанавливаем указатели на пары байтов блока Dim heshx As Hesh With heshx .hesh2 = *b1b2 ' хеш-2 .hesh3 = .hesh2 * 3 + *b2b3 ' вычисляем хеш-3 .hesh4 = .hesh3 * 3 + *b3b4 ' вычисляем хеш-4 End With Function=heshx End Function Function V_HESH_OBR(adres_ukaz As UByte Ptr) As Hesh' вычисление обратных хешей (2,3,4) для блока из 4 байтов ' на входе 1-байтный указатель на первый байт блока данных (5 байт) в исходном массиве ' Б-4 Б-3 Б-2 Б-1 | Б1 Б2 Б3 Б4 ; Указатель установлен на Б1; расчет от Б-1 до Б-4 Dim As UShort Ptr b2b1=adres_ukaz-1,b3b2=adres_ukaz-2,b4b3=adres_ukaz-3' устанавливаем указатели на пары байтов блока Dim heshx As Hesh ' Хеш вычисляется для блока (4 байта) до указателя не включая сам указатель With heshx .hesh2 = *b2b1 ' хеш-2 .hesh3 = *b3b2 * 3 + .hesh2 ' вычисляем хеш-3 .hesh4 = *b4b3 * 9 + .hesh3 ' вычисляем хеш-4 End With Function=heshx End Function Function SRAVNENIE (vh_mas As String,adres_pred As ULong,_ ukaz As ULong,dlina As ULong) As UShort ' возвращает длину совпавшей цепочки бат или "0" - если нет совпадения ' adres_pred - индекс начала сравнения в предыдущих байтах (до текущего указателя); ' ukaz - текущий указатель(индекс); dlina - количество сравниваемых байт Dim As Long Ptr p_pred=@vh_mas[adres_pred],p_tek=@vh_mas[ukaz] ' получаем указатели на 4-байтовые числа If dlina=3 Then ' проверка 3 байтного совпадения If *p_pred Shl 8 = *p_tek Shl 8 Then Return 3 Else Return 0 ' делаем сдвиг на 8 бит вправо (отбрасываем правый байт) Else ' длина совпаления >3 If *p_pred <> *p_tek Then Return 0 ' сверяем 4 байта, если не равны, то возвращаем "0" и выходим EndIf Dim As Integer k,i=ukaz-adres_pred,maks_dlina=Len(vh_mas)-ukaz:k=4' сверяем дальше если совпадение-4 If i<maks_dlina Then maks_dlina=i ' определяем максимально возможную длину совпадения For i=1 To maks_dlina\4-1 ' сверяем следующие 4 байта If p_pred[i] = p_tek[i] Then k+=4 Else Exit For ' если байты не равны, то возвращаем "счётик совпавших" Next For i=adres_pred+k To adres_pred+maks_dlina-1 ' сверяем следующие байты (побайтно) If vh_mas[i] = vh_mas[ukaz+k] Then k+=1 Else Exit For ' если байты не равны, то возвращаем "счётик совпавших" Next If k > 3 Then Return k Else Return 0 End Function Sub REDAKTIROVANIE_CEP(hesh As UShort,ukaz_mas As ULong,_ cepx As Cep Ptr, n_zveno As UShort,n_povt As UShort) ' Освобождение и Встраивание звена в таблицах цепочек; n_zveno - индекс редактируемого звена ' n_povt - номер таблицы для редактирования (2;3;4) / количество байт для которых рассчитан Хеш ' hesh -Хеш для прописки звена в таблицы Поиска poiskx(); cepx - таблица цепочек ' ---<<<<< ОСВОБОЖДЕНИЕ ЗВЕНА >>>>--- If cepx[n_zveno].perv Then ' если ссылка пред. указывает на таблицу поиска (единственное звено) poiskx(n_povt,cepx[n_zveno].pred)=0 ' обнуляем указатель поисковой таблицы Else ' если есть предыдущие звенья в цепочке cepx[cepx[n_zveno].pred].sled=0:cepx[n_zveno].perv=1' обнуляем указатель следующего в предыдущем EndIf ' ------------- КОНЕЦ Освобождения Звена ------------- Dim As UShort Ptr poiskx_hesh=@poiskx(n_povt,hesh)' ---<<<<< ВСТРАИВАНИЕ ЗВЕНА >>>>>--- cepx[n_zveno].pred=hesh ' в указатель пред. звена прописываем индек таблицы поиска If *poiskx_hesh Then ' если в таблице поиска по текущему хешу есть звено cepx[*poiskx_hesh].pred=n_zveno ' вставляем текущее звено в начало цепочки cepx[*poiskx_hesh].perv=0:cepx[n_zveno].sled=*poiskx_hesh Else cepx[n_zveno].sled=0 ' так как следующего звена нет, обнуляем указатель EndIf cepx[n_zveno].ukaz=ukaz_mas+1-n_povt ' адрес совпадения в массиве минус длина совп. так как обр.хеш *poiskx_hesh=n_zveno 'прописываем новое звено в таблицу ПОИСКА End Sub ' ------------- КОНЕЦ Встраивания Звена ------------- Sub DOB_CEP(vh_mas As String,ukaz As ULong,razmer As ULong) ' процедера добавления байтов в таблицы хешей и поиска (расчет хешей, управление звеньями цепочек) ' vh_mas - входной массив; ukaz - индекс Б-1-го байта обр.выборки; razmer - количество добавляемых байтов Dim hesh_obr As Hesh For i As ULong=ukaz To ukaz+razmer-1 sh_zv(4)+=1:sh_zv(3)+=1:sh_zv(2)+=1 ' увеличиваем значения счётчиков для след. добавлений If sh_zv(4)=0 Then sh_zv(4)=1 ' пропускаем "0" индекс If sh_zv(3)=8193 Then sh_zv(3)=1 ' если перешли верхнюю границу If sh_zv(2)=129 Then sh_zv(2)=1 ' если перешли верхнюю границу hesh_obr=V_HESH_OBR(@vh_mas[i]) ' вычисляем обратные хеши для блока байт REDAKTIROVANIE_CEP(hesh_obr.hesh4,i,cep4,sh_zv(4),4) ' добавляем Хеш-4 REDAKTIROVANIE_CEP(hesh_obr.hesh3,i,cep3,sh_zv(3),3) ' добавляем Хеш-3 REDAKTIROVANIE_CEP(hesh_obr.hesh2,i,cep2,sh_zv(2),2) ' добавляем Хеш-2 Next End Sub Function POISK (vh_mas As String,adres_poisk As ULong) As Uchastok 'если найдено, то функция возвращает адрес и ненулевую длину сопадения, если нет то .длина="0" 'adres_poisk - позиция Б1 (1-го байта) поиска Var heshx=V_HESH(@vh_mas[adres_poisk]) ' получаем прямые хеши по указанному адресу Dim As UShort poisk_ind:Dim As Uchastok sovpad,sovpad_maks With heshx poisk_ind=poiskx(4,.hesh4) ' получаем индекс 1-го звена из таблицы поиска по хешу-4 If poisk_ind Then ' если есть указатель в таблице поиска для хеша СОВПАДЕНИЯ-4 Do ' ищем самое длинное совпадение, прошедшее сверку sovpad.adres=cep4[poisk_ind].ukaz sovpad.dlina=SRAVNENIE(vh_mas,sovpad.adres,adres_poisk,4) ' определяем длину совпадения, если есть If sovpad_maks.dlina<sovpad.dlina Then sovpad_maks=sovpad poisk_ind=cep4[poisk_ind].sled ' получаем индекс следующего звена If poisk_ind=0 Then Exit Do ' если звено было последним, то выходим Loop If sovpad_maks.dlina Then Return sovpad_maks ' если найдено совпадение EndIf poisk_ind=poiskx(3,.hesh3) ' получаем индекс 1-го звена из таблицы поиска по хешу-3 If poisk_ind Then ' если есть указатель в таблице поиска для хеша СОВПАДЕНИЯ-3 Do ' ищем первое совпадение, прошедшее сверку sovpad.adres=cep3[poisk_ind].ukaz sovpad.dlina=SRAVNENIE(vh_mas,sovpad.adres,adres_poisk,3) ' определяем длину совпадения, если есть If sovpad.dlina Then Return sovpad ' если найдено совпадение (первое, прошедшее сверку) poisk_ind=cep3[poisk_ind].sled ' получаем индекс следующего звена If poisk_ind=0 Then Exit Do ' если звено было последним, то выходим Loop EndIf poisk_ind=poiskx(2,.hesh2)' получаем индекс 1-го звена из таблицы поиска по хешу-2 If poisk_ind Then ' если есть указатель в таблице поиска для хеша СОВПАДЕНИЯ-2 sovpad.adres=cep2[poisk_ind].ukaz ' ищем первое совпадение sovpad.dlina=2:Return sovpad ' определяем длину совпадения EndIf End With End Function Sub SBROS_PROPUSK(vh_mas As String,vih_mas As String,ukaz As ULong,ByRef ukaz_vih As ULong,_ ByRef razmer As ULong) ' сброс пропусков и добавление в цепочки Dim i As ULong, komanda(3) As UByte ' устанавливаем начальное значение указателя во вх.массиве Select Case razmer ' в зависимости от длины пропусков формируем команду Case Is<29 komanda(0)=1:komanda(1)=razmer Case 29 To 284 komanda(0)=2:komanda(1)=0:komanda(2)=razmer-29 'сначала записываются в массив старший байт Case Is>284 Dim As UShort razm=razmer-285 komanda(0)=3:komanda(1)=31:komanda(2)=razm Shr 8:komanda(3)=razm ' получаем байт сдвигом на 8 бит End Select For i=1 To komanda(0) ' записываем команду Пропуска в выходной массив vih_mas[ukaz_vih]=komanda(i):ukaz_vih+=1' двигаем указатель вых.массива Next For i=ukaz-razmer To ukaz-1 vih_mas[ukaz_vih]=vh_mas[i]:ukaz_vih+=1' копируем байты из вх.массива в вых.массив Next ' razmer=0 ' обнуляем значение пропусков End Sub Function UPAKOVKA(vh_mas As String) As String' функция возвращает "строка" - удачно и "" - ошибка ' процедура сжатия на входе сжимаемая строка, на выходе строка-результат If Len(vh_mas)=0 Then Return "" ' если на входе пустая строка Dim As ULong i,propusk,rast,rastoyanie,dln,dlina,ukaz,ukaz_vih,propusk_pred,vh_mas_maks=Len(vh_mas)-1 ReDim poiskx(2 To 4,65535),sh_zv(2 To 4) ' создаём таблицы для поиска 1-го звена совпадения (длина_совпадения, хеши); массив счётчиков использования Звеньев всех таблиц цепочек Dim As UByte komanda(6) ' таблица флагов поиска: если бит 2(3;4;5) установлен, значит есть совпадение в таблице 2(3;4;5) цепочек Dim As UByte Ptr lo_dlina=@dln,lo_rastoyanie=@rast,hi_rastoyanie=lo_rastoyanie+1,hi_dlina=lo_dlina+1 ' для выделения любого байта из 2-х байтовой переменной Var vih_mas = String(vh_mas_maks*1.05+10,0) ' устанавливаем размер выходного массива Dim As Uchastok sovpad ' результат поиска, в ней функция POISK возвращает адрес/длину_совпадения cep4=New Cep[65536]:cep3=New Cep[8193]:cep2=New Cep[129] ' создаём динамические таблицы цепочек с хешами vih_mas[0]=76:vih_mas[1]=122:vih_mas[2]=71:propusk=5:ukaz=5:ukaz_vih=7 ' записываем заголок для "LzG" сжатого массива; копируем первые 5 байтов исх. массива на выход DOB_CEP(vh_mas,4,1) ' расчитываем для первой 5-ки хеши Do ' komanda(0) - количество байт в команде; (1)--(5) - байты команды (1 - старший) sovpad=POISK(vh_mas,ukaz)' делаем поиск по таблицам хешей и запоминаем результат If propusk_pred>28 Then ' для улучшение сжатия плохо сжимаемого контента If propusk_pred>40 Then ' если предыдущая команда была пропуском определённого размера if sovpad.dlina<6 then sovpad.dlina=0 Else If sovpad.dlina<>2 Then sovpad.dlina=0 EndIf EndIf If sovpad.dlina Then' если было найдено совпадение If propusk Then ' если есть пропуски, то делаем их сброс SBROS_PROPUSK(vh_mas,vih_mas,ukaz,ukaz_vih,propusk) EndIf dlina=sovpad.dlina:rastoyanie=ukaz-sovpad.adres ' длина/расстояние до совпадения Select Case dlina ' создаём команду сжатия (сначала записываются в массив старший байт) Case 2 ' совпадение-2 komanda(0)=1:komanda(1)=rastoyanie+126 Case 3' совпадение-3= rast=rastoyanie-3:komanda(0)=2:komanda(1)=*hi_rastoyanie+32:komanda(2)=*lo_rastoyanie Case 4 ' совпадение-4 If rastoyanie<8196 Then ' короткое расстояние - команда 2 байта rast=rastoyanie-4:rast=rastoyanie-4:komanda(0)=2:komanda(1)=*hi_rastoyanie+64:komanda(2)=*lo_rastoyanie Else 'rastoyanie>8195 длинное расстояние - команда 3 байта rast=rastoyanie-4:komanda(0)=3:komanda(1)=96:komanda(2)=*hi_rastoyanie:komanda(3)=*lo_rastoyanie EndIf Case 5 To 35 rast=rastoyanie-5:komanda(0)=3:komanda(1)=92+dlina:komanda(2)=*hi_rastoyanie:komanda(3)=*lo_rastoyanie Case 36 To 291 rast=rastoyanie-5:komanda(0)=4:komanda(1)=29:komanda(2)=dlina-36 komanda(3)=*hi_rastoyanie:komanda(4)=*lo_rastoyanie Case Is > 291 dln=dlina-5:komanda(0)=5:komanda(1)=30:komanda(2)=*hi_dlina:komanda(3)=*lo_dlina rast=rastoyanie-5:komanda(4)=*hi_rastoyanie:komanda(5)=*lo_rastoyanie End Select For i=1 To komanda(0) ' записываем команду сжатия в выходной массив vih_mas[ukaz_vih]=komanda(i):ukaz_vih+=1 ' двигаем указатель вых. Next DOB_CEP(vh_mas,ukaz,dlina) ' добавляем совпадение в таблицы цепочек propusk_pred=0:ukaz+=dlina ' увеличиваем указатели вх.массива на величину совпадения Else ' если не было совпадений If propusk=65820 Then ' если достигли максимального значения пропусков, то делаем сброс SBROS_PROPUSK(vh_mas,vih_mas,ukaz,ukaz_vih,propusk) EndIf DOB_CEP(vh_mas,ukaz,1) ' добавляем блок хешей в таблицы цепочек propusk+=1:ukaz+=1:propusk_pred=propusk' увеличиваем количество пропусков (счётчик); перемещаем указатель чтения вх.массива на 1 позицию вперёд EndIf Loop Until ukaz+3>vh_mas_maks ' пока не дошли до конца массива dln=vh_mas_maks+1-ukaz If propusk+dln Then ' если есть пропуски, то делаем их сброс If propusk+dln>65820 Then ' если добавляемые пропуски не влезут в буфер пропусков SBROS_PROPUSK(vh_mas,vih_mas,ukaz,ukaz_vih,propusk) EndIf propusk+=dln SBROS_PROPUSK(vh_mas,vih_mas,vh_mas_maks+1,ukaz_vih,propusk) EndIf ' КОНЕЦ vh_mas_maks+=1:vih_mas[3]=vh_mas_maks Shr 24 ' записываем размер исходного массива vih_mas[4]=vh_mas_maks Shr 16 :vih_mas[5]=vh_mas_maks Shr 8:vih_mas[6]=vh_mas_maks Function=Left(vih_mas,ukaz_vih) ' ограничиваем выходной массив до актуального Delete [] cep4:Delete [] cep3:Delete [] cep2 ' освобождаем память End Function Function RASPAKOVKA(vh_mas As String) As String ' процедура распаковки на входе сжатая строка ' функция возвращает "строка" - если удачно и "" - если ошибка If Len(vh_mas)<8 OrElse Not(vh_mas[0]=76 And vh_mas[1]=122 And vh_mas[2]=71) Then Return "" ' если на входе мало байт или нет заголовка Dim As ULong i,k,propusk,povtor,rastoyanie,dlina,vih_mas_maks,ukaz_vih,ukaz=7,vh_mas_maks=Len(vh_mas)-1 ' главный указатель чтения исх.массива и указатель записи вых.массива Dim As UByte bait,komanda(6) vih_mas_maks=vh_mas[3]:vih_mas_maks=vih_mas_maks Shl 8 ' читаем 4 байта размера конечного массива vih_mas_maks+=vh_mas[4]:vih_mas_maks=vih_mas_maks Shl 8 vih_mas_maks+=vh_mas[5]:vih_mas_maks=vih_mas_maks Shl 8:vih_mas_maks+=vh_mas[6] Var vih_mas = String(vih_mas_maks,0):vih_mas_maks-=1 ' устанавливаем размер выходного массива Do bait=vh_mas[ukaz]:ukaz+=1 ' читаем очередной байт исходного массива Select Case bait ' декодируем заголовок команды Case 0 ' Пропуски-{26..281};; Команда 2 байта propusk=vh_mas[ukaz]+29:ukaz+=1 ' декодируем след.байт Case 1 To 28 ' Пропуски-{1..25}; Команда 1 байт propusk=bait ' декодируем тек.байт Case 29 ' Совпадения-{36..291}; Команда 4 байта povtor=vh_mas[ukaz]+36:rastoyanie=vh_mas[ukaz+1]:rastoyanie=rastoyanie Shl 8 ' читаем байт, корректируем и двигаем в старший разряд rastoyanie+=vh_mas[ukaz+2]+5:ukaz+=3' читаем и добавляем младший байт Case 30 ' Совпадения-{292..65536}; Команда 5 байт , декодируем оставшиеся 4 povtor=vh_mas[ukaz]:povtor=povtor Shl 8:povtor+=vh_mas[ukaz+1]+5 rastoyanie=vh_mas[ukaz+2]:rastoyanie=rastoyanie Shl 8 ' читаем байт, корректируем и двигаем в старший разряд rastoyanie+=vh_mas[ukaz+3]+5:ukaz+=4' читаем и добавляем младший байт Case 31 ' Пропуски-{282..65817}; Команда 3 байта propusk=vh_mas[ukaz]:propusk=propusk Shl 8 ' читаем старший байт команды и двигаем его на своё место propusk+=vh_mas[ukaz+1]+285:ukaz+=2 ' читаем и добавляем младший байт Case 32 To 63 ' Совпадения-3; Команда 2 байта rastoyanie=bait-32:rastoyanie=rastoyanie Shl 8 ' читаем байт, корректируем и двигаем в старший разряд rastoyanie+=vh_mas[ukaz]+3:ukaz+=1:povtor=3 ' читаем и добавляем младший байт Case 64 To 95 ' Совпадения-4; Команда 2 байта rastoyanie=bait-64:rastoyanie=rastoyanie Shl 8 ' читаем байт, корректируем и двигаем в старший разряд rastoyanie+=vh_mas[ukaz]+4:povtor=4:ukaz+=1' читаем и добавляем младший байт Case 96 To 127 ' Совпадения-{4..35}; Команда 3 байта povtor=bait-92:rastoyanie=vh_mas[ukaz]:rastoyanie=rastoyanie Shl 8 ' читаем байт, корректируем и двигаем в старший разряд rastoyanie+=vh_mas[ukaz+1]:ukaz+=2' читаем и добавляем младший байт If povtor=4 Then rastoyanie+=4 Else rastoyanie+=5 Case 128 To 255 ' Совпадения-2; Команда 1 байт rastoyanie=bait-126:povtor=2 End Select If propusk Then For i=1 To propusk ' копируем пропуски из вх. в вых. массив vih_mas[ukaz_vih]=vh_mas[ukaz]:ukaz+=1:ukaz_vih+=1 Next propusk=0 Else ' значит повтор For i=1 To povtor ' копируем предыдущие байты вых.массива в конец вых.массива vih_mas[ukaz_vih]=vih_mas[ukaz_vih-rastoyanie]:ukaz_vih+=1 Next povtor=0 EndIf Loop While ukaz<vh_mas_maks Function=vih_mas End Function

Примеры использования:

Код:: #Include "lzg.bas" ' Сжатие строки Dim As String mas2,mas="abracadabra abracadabra abracadabra abracadabra" ?:?" UPAKOVKA = "; mas2=UPAKOVKA(mas):?"OK" ?" RASPAKOVKA = "; Var mas3=RASPAKOVKA(mas2):?"OK" ?:? " razmer_ishodn = ";Len(mas) ?" razmer_upak = ";Len(mas2) ?:?" SRAVNENIE="; If mas=mas3 Then ?"DA" Else ?"NET" Sleep

Код:: #Include "lzg.bas" Dim As String mas,mas2 ' Сжатие файла Var file="c:\file" Open file For Binary Access Read As 1 mas=Space(Lof(1)) Get #1,,mas Close 1 Var tm=Timer ?:?" UPAKOVKA = "; ' упаковка mas2=UPAKOVKA(mas):?Using "##.### sek";(Timer-tm):tm=Timer ?" RASPAKOVKA = "; ' распаковка Var mas3=RASPAKOVKA(mas2):?Using "##.### sek";(Timer-tm) ?:? " Razmer Ishodn = ";Len(mas) ?" Razmer Upak = ";Len(mas2) ?:?" SRAVNENIE = "; ' сравниваем распакованный и исходный массивы If mas=mas3 Then ?"DA" Else ?"NET" mas="" : mas3="" Open file & ".lzg" For Binary Access write Lock write As 1 Put #1,,mas2 ' записываем упакованный массив в файл Close 1 mas2="" Sleep