freepascal.ru

форум
http://lazarus.freepascal.ru/forum/

Сжатие данных по алгоритму LZW

http://lazarus.freepascal.ru/forum/viewtopic.php?f=30&t=9481

Страница 1 из 1

Сжатие данных по алгоритму LZW

СообщениеДобавлено: 29.10.2013 11:05:39
Tango
Unit CompressUnit;

Код: Выделить всё
Unit CompressUnit;

// Модуль LZW паковщика и распаковщика
// требует модуля FileBuffer
interface

uses SysUtils,
{$IFDEF MSWindows}
  Windows,
{$ENDIF}
{$IFDEF UNIX}
  Linux,
{$ENDIF}
  FileBuffer, ProgressUnit;

Procedure CompressProc(Var Data, Arc: TByteFile);
Procedure DecompressProc(Var Arc, Data: TByteFile);

Const
  MaxBits=16;
  MaxCode=65535;

  TopChar=255;
  ProgressStep=8192;
  ClearDictValue=256;
  FreezDict=ClearDictValue+1;
  StepWordLength=ClearDictValue+2;
  EndOfStream=ClearDictValue+3;

  Signature: Array [1..4] of Byte=($50, $41, $47, $21);

Var
  MaxWordSize: Byte;

implementation

Type
  DictR=Record
    Up, Left, Right, Code: Word;
    AddChar: Byte;
  End;

  TDecodeBuffer=Array of Byte;

Var
  Overflow: Boolean;
  BitSize, AddChar: Byte;
  CurMaxCode, DictPos, MaxDictSize: Word;
  DecodeBufferSize: Cardinal;
  Dict: Array of DictR;

  DecodeBuffer: TDecodeBuffer;

Function GetMaxDictSize(PowNum: Byte): Word;
const
  BaseNum=2;
var
  i: Byte;
  s: Cardinal;
begin
  s:=1;
  For i:=1 to PowNum do
    s:=s*BaseNum;
  GetMaxDictSize:=s-1;
end;

Procedure InitDict;
Begin
  MaxDictSize:=GetMaxDictSize(MaxWordSize);
  SetLength(Dict, MaxDictSize);
End;


// =========================Dictionary Begin==================================

Procedure AddNode(s: Word; C: Byte);
Var
  dc: Word;
Begin
  If DictPos<MaxDictSize then
  Begin
    If Dict[s].Up=ClearDictValue then
    Begin
      // Никого нет на этой ноде
      Dict[s].Up:=DictPos;
      Dict[DictPos].Up:=ClearDictValue;
      Dict[DictPos].Left:=ClearDictValue;
      Dict[DictPos].Right:=ClearDictValue;
      Dict[DictPos].Code:=s;
      Dict[DictPos].AddChar:=C;
    End
    Else
    Begin
      // Кто-то живёт тут
      If C>Dict[Dict[s].Up].AddChar then
      Begin
        // Смотрим куда податься
        // Вперёд
        dc:=Dict[s].Up;
        While Dict[dc].Right<>ClearDictValue do
          dc:=Dict[dc].Right;

        Dict[dc].Right:=DictPos;
        Dict[DictPos].Up:=ClearDictValue;
        Dict[DictPos].Left:=DictPos;
        Dict[DictPos].Right:=ClearDictValue;
        Dict[DictPos].Code:=s;
        Dict[DictPos].AddChar:=C;
      End
      Else
      Begin
        // Назад
        dc:=Dict[s].Up;
        While Dict[dc].Left<>ClearDictValue do
          dc:=Dict[dc].Left;

        Dict[dc].Left:=DictPos;
        Dict[DictPos].Up:=ClearDictValue;
        Dict[DictPos].Left:=ClearDictValue;
        Dict[DictPos].Right:=DictPos;
        Dict[DictPos].Code:=s;
        Dict[DictPos].AddChar:=C;
      End;
    End;
    Inc(DictPos);
  End;
End;

Function FindNode(s: Word; C: Byte): LongInt;
Var
  dc: Word;
Begin
  Result:= - 1;
  If Dict[s].Up<>ClearDictValue then
  Begin
    dc:=Dict[s].Up;
    If Dict[dc].AddChar<>C then
    Begin
      If Dict[dc].AddChar<C then
      Begin
        dc:=Dict[dc].Right;
        While dc<>ClearDictValue do
        Begin
          If Dict[dc].AddChar=C then
          Begin
            FindNode:=dc;
            Exit;
          End;
          dc:=Dict[dc].Right;
        End;
      End;
      If Dict[dc].AddChar>C then
      Begin
        dc:=Dict[dc].Left;
        While dc<>ClearDictValue do
        Begin
          If Dict[dc].AddChar=C then
          Begin
            FindNode:=dc;
            Exit;
          End;
          dc:=Dict[dc].Left;
        End;
      End;
    End
    Else
      FindNode:=dc;
  End;
End;

Procedure InitCoder;
Var
  i: Word;
Begin
  BitSize:=9;
  Overflow:=False;
  CurMaxCode:=GetMaxDictSize(BitSize);
  For i:=0 to MaxDictSize-1 do
  Begin
    Dict[i].Code:=0;
    Dict[i].AddChar:=0;

    Dict[i].Up:=ClearDictValue;
    Dict[i].Left:=ClearDictValue;
    Dict[i].Right:=ClearDictValue;
  End;
  For i:=0 to TopChar do
  Begin
    Dict[i].Code:=ClearDictValue;
    Dict[i].AddChar:=i;
  End;
  DictPos:=EndOfStream+1;
End;

// ======================Dictionary End=====================================

Procedure CompressProc(Var Data, Arc: TByteFile);
Var
  Code: Word;
  Index: LongInt;
Begin
  InitDict;

  BeginRead;
  BeginWrite;

  InitCoder;

  WriteMode:=1;

  Code:=GetBytes(Data);

  FSize:=GetFSize(Data);
  InitProgress(FSize);

  While DataPos<FSize do
  Begin
    AddChar:=GetBytes(Data);

    Index:=FindNode(Code, AddChar);
    If Index<> - 1 then
    Begin
      Code:=Index;
    End
    Else
    Begin
      If DictPos<MaxCode then
        AddNode(Code, AddChar)
      Else
        Overflow:=True and (not Freeze);

      If (Code>CurMaxCode)and(BitSize<MaxBits) then
      Begin
        BitWrite(Arc, StepWordLength, BitSize);
        Inc(BitSize);
        CurMaxCode:=GetMaxDictSize(BitSize);
      End;

      BitWrite(Arc, Code, BitSize);

      Code:=AddChar;

      If Overflow then
      Begin
        BitWrite(Arc, AddChar, BitSize);
        BitWrite(Arc, ClearDictValue, BitSize);
        InitCoder;
      End;
    End;

    SetProgress(DataPos);
  End;

  BitWrite(Arc, Code, BitSize);
  BitWrite(Arc, EndOfStream, BitSize);

  EndBitWrite(Arc);
  ResetBuffer(Arc);
End;

Procedure OutPutDecodeBuffer(Var F: TByteFile; Buff: TDecodeBuffer);
Var
  le, i: Cardinal;
Begin
  le:=Length(Buff);
  For i:=0 to le-1 do
    OutputBytes(F, Buff[i]);
End;

Procedure DecodeString(DeCode: Word);
Var
  dc: Word;
  ReversC, ForwC: Cardinal;
  DS: TDecodeBuffer;
Begin
  dc:=DeCode;
  DecodeBufferSize:=0;
  Repeat
    SetLength(DS, DecodeBufferSize+1);
    DS[DecodeBufferSize]:=Dict[dc].AddChar;
    dc:=Dict[dc].Code;
    Inc(DecodeBufferSize);
  Until dc=ClearDictValue;
  SetLength(DecodeBuffer, DecodeBufferSize);
  ReversC:=0;
  For ForwC:=DecodeBufferSize-1 downto 0 do
  Begin
    DecodeBuffer[ReversC]:=DS[ForwC];
    Inc(ReversC);
  End;
End;

Procedure DecompressProc(Var Arc, Data: TByteFile);
Var
  NewCode, OldCode: Word;
Begin
  InitDict;

  NewCode:=0;
  InitCoder;

  FSize:=GetFSize(Arc);
  InitProgress(FSize);

  OldCode:=BitRead(Arc, BitSize);
  OutputBytes(Data, OldCode);

  AddChar:=Byte(OldCode);

  While NewCode<>EndOfStream do
  Begin
    NewCode:=BitRead(Arc, BitSize);

    Case NewCode of
    EndOfStream:
    break;

    ClearDictValue:
    Begin
      InitCoder;
      OldCode:=BitRead(Arc, BitSize);
      AddChar:=Byte(OldCode);
      NewCode:=BitRead(Arc, BitSize);
    End;

    StepWordLength:
    Begin
      Inc(BitSize);
      CurMaxCode:=GetMaxDictSize(BitSize);
      NewCode:=BitRead(Arc, BitSize);
    End;
    End;

    If DictPos<=NewCode then
    Begin
      DecodeString(OldCode);
      Inc(DecodeBufferSize);
      SetLength(DecodeBuffer, DecodeBufferSize);
      DecodeBuffer[DecodeBufferSize-1]:=AddChar;
    End
    Else
      DecodeString(NewCode);

    OutPutDecodeBuffer(Data, DecodeBuffer);

    AddChar:=DecodeBuffer[0];

    AddNode(OldCode, AddChar);

    OldCode:=NewCode;

    SetProgress(DataPos);
  End;

  ResetBuffer(Data);
End;

end.


А вот и сам FileBuffer

Код: Выделить всё
Unit FileBuffer;
{$I DefineType.pas}
// Модуль буферизированного ввода/вывода, реально ускаряет файловые
// операции из за ввода/вывода в память, а только потом, как буфер
// переполнится, в файл.

interface

uses
{$IFDEF StreamType}
  Classes,
{$ENDIF}
  SysUtils;

Type
{$IFDEF StreamType}
  TByteFile=TStream;
{$ENDIF}
{$IFDEF FileType}
  TByteFile=File of Byte;
{$ENDIF}
Procedure BeginRead;
Procedure BeginWrite;

Procedure OpenFile(var F: TByteFile; FileName:String);
Procedure CloseFile(var F: TByteFile);
Function GetFSize(Var F: TByteFile): Int64;
Function SeekBuffer(Var F: TByteFile; SeekPos: Int64): Byte;
Function GetBytes(var F: TByteFile): Byte;
Procedure ResetBuffer(Var F: TByteFile);
Procedure OutputBytes(Var F: TByteFile; B: Byte);
Procedure BitWrite(Var F: TByteFile; Num: Word; NumBits: Byte);
Function BitRead(Var F: TByteFile; NumBits: Byte): Word;
Procedure EndBitWrite(Var F: TByteFile);

Function ReadDWord(Var F: TByteFile): Cardinal;
Function ReadWord(Var F: TByteFile): Word;

Procedure WriteDWord(Var F: TByteFile; DW: Cardinal);
Procedure WriteWord(Var F: TByteFile; W: Word);

Var
  ArcFile, DataFile: TByteFile;
  WriteMode: Byte;
  ArcSize, DataPos, FSize: Int64;

implementation

Const
  BufLength=1024*1024;

Var
  ReadCounterBit, WriteCounterBit: Byte;
  BufsCount, OutBufPos, ReadBitsBuffer, WriteBitsBuffer: Cardinal;

  FPos: Int64;

  DWordRec: Record LowLo, LowHi, HiLo, HiHi: Byte;
End;

DWordData:
Cardinal Absolute DWordRec;

WordRec:
Record Low, Hi: Byte;
End;

WordData:
Cardinal Absolute WordRec;

InBuffer:Array of Byte;
OutBuffer:Array of Byte;

Procedure OpenFile(var F: TByteFile; FileName:String);
Begin
{$IFDEF StreamType}
  F:=TFileStream.Create(FileName, fmCreate);
{$ENDIF}
{$IFDEF FileType}
  AssignFile(F, FileName);
  ReWrite(F);
{$ENDIF}
End;


Procedure CloseFile(var F: TByteFile);
Begin
{$IFDEF StreamType}
  F.Free;
{$ENDIF}
{$IFDEF FileType}
  CloseFile(F);
{$ENDIF}
End;


Procedure GetBuff(var F: TByteFile);
Var
  CountBytes: Cardinal;
Begin
  If FSize>=FPos then
  Begin
    If BufsCount=0 then
      FPos:=0;
{$IFDEF FileType}
    Seek(F, (DataPos div BufLength)*BufLength);
    BlockRead(F, InBuffer[0], BufLength, CountBytes);
{$ENDIF}
{$IFDEF StreamType}
    F.Seek((DataPos div BufLength)*BufLength, 0);
    CountBytes:=F.Read(InBuffer[0], BufLength);
{$ENDIF}
    Inc(FPos, CountBytes);
    BufsCount:=((FPos-1)div BufLength)+1;
  End;
End;

Function GetBytes(var F: TByteFile): Byte;
Begin
  GetBytes:=0;
  If BufsCount=0 then
  Begin
    GetBuff(F);
    DataPos:=0;
  End;
  If ((DataPos div BufLength)+1)<>BufsCount then
    GetBuff(F);
  If DataPos<=FSize then
  Begin
    GetBytes:=InBuffer[DataPos-((BufsCount-1)*BufLength)];
    Inc(DataPos);
  End;
End;

Procedure ResetBuffer(Var F: TByteFile);
Begin
  If WriteMode=1 then
{$IFDEF StreamType}
    F.Write(OutBuffer[0], OutBufPos);
{$ENDIF}
{$IFDEF FileType}
    BlockWrite(F, OutBuffer[0], OutBufPos);
{$ENDIF}
  OutBufPos:=0;
End;

Procedure OutputBytes(Var F: TByteFile; B: Byte);
Begin
  OutBuffer[OutBufPos]:=B;
  Inc(ArcSize);
  Inc(OutBufPos);
  If OutBufPos=BufLength then
    ResetBuffer(F);
End;

// ======================Bit read==========================================

Function BitRead(Var F: TByteFile; NumBits: Byte): Word;
var
  B: Word;
begin
  { Пока в буфере не хватает бит - читаем их из файла }
  While ReadCounterBit<NumBits do
  Begin
    B:=GetBytes(F);
    ReadBitsBuffer:=ReadBitsBuffer or(B shl ReadCounterBit);
    { Добавляем его в буфер }
    Inc(ReadCounterBit, 8);
  End;
  BitRead:=Word(ReadBitsBuffer and((1 shl NumBits)-1));
  { Получаем из буфера нужное кол-во бит }
  ReadBitsBuffer:=ReadBitsBuffer shr NumBits;
  { Отчищаем буфер от выданных бит }
  Dec(ReadCounterBit, NumBits);
end;

// ======================Bit read End======================================
// ======================Bit Write=========================================

Procedure BitWrite(Var F: TByteFile; Num: Word; NumBits: Byte);
Var
  B: Byte;
  BitBuffer: Cardinal;
begin
  If WriteMode=1 then
  Begin
  BitBuffer:=Num;
  WriteBitsBuffer:=WriteBitsBuffer or(BitBuffer shl WriteCounterBit);
  { Добавляем в буфер новые биты }
  Inc(WriteCounterBit, NumBits);
  While (WriteCounterBit>=8) do
  Begin
    B:=Byte(WriteBitsBuffer and $FF); { Получаем первый байт из буфера }
    OutputBytes(F, B);
    WriteBitsBuffer:=WriteBitsBuffer shr 8;
    { Отчищам буфер от записанных бит }
    Dec(WriteCounterBit, 8);
  End;
  End;
end;

Procedure EndBitWrite(Var F: TByteFile);
Var
  B: Byte;
begin
  If WriteMode=1 then
  Begin
  If (WriteCounterBit>0) then
  Begin
    B:=WriteBitsBuffer;
    OutputBytes(F, B);
    WriteCounterBit:=0;
    WriteBitsBuffer:=0;
  End;
  BufsCount:=0;
  FPos:=0;
  End;
end;

// ====================Bit Write End=======================================

Function SeekBuffer(Var F: TByteFile; SeekPos: Int64): Byte;
Var
  B: Byte;
  OldPos: Int64;
Begin
  If (((BufsCount-1)*BufLength)<=SeekPos)and(((BufsCount)*BufLength)>=SeekPos) then
    Result:=InBuffer[SeekPos-((BufsCount-1)*BufLength)]
  Else
  Begin
    // не повезло не попали в буфер

{$IFDEF StreamType}
    OldPos:=F.Position;
    F.Seek(SeekPos, 0);
    F.Read(B, 1);
    F.Seek(OldPos, 0);
{$ENDIF}
{$IFDEF FileType}
    OldPos:=FilePos(F);
    Seek(F, SeekPos);
    BlockRead(F, B, 1);
    Seek(F, OldPos);
{$ENDIF}
    Result:=B;
  End;
End;

Procedure WriteWord(Var F: TByteFile; W: Word);
Begin
  WordData:=W;
  BitWrite(F, WordRec.Low, 8);
  BitWrite(F, WordRec.Hi, 8);
End;

Procedure WriteDWord(Var F: TByteFile; DW: Cardinal);
Begin
  DWordData:=DW;
  BitWrite(F, DWordRec.LowLo, 8);
  BitWrite(F, DWordRec.LowHi, 8);
  BitWrite(F, DWordRec.HiLo, 8);
  BitWrite(F, DWordRec.HiHi, 8);
End;

Function ReadWord(Var F: TByteFile): Word;
Begin
  WordRec.Low:=BitRead(F, 8);
  WordRec.Hi:=BitRead(F, 8);
  Result:=WordData;
End;

Function ReadDWord(Var F: TByteFile): Cardinal;
Begin
  DWordRec.LowLo:=BitRead(F, 8);
  DWordRec.LowHi:=BitRead(F, 8);
  DWordRec.HiLo:=BitRead(F, 8);
  DWordRec.HiHi:=BitRead(F, 8);
  Result:=DWordData;
End;

/// /////////////////////////////////////////////////////////////////

Procedure BeginRead;
Begin
  BufsCount:=0;
  FPos:=0;
  ReadBitsBuffer:=0;
  ReadCounterBit:=0;
End;

Procedure BeginWrite;
Begin
  WriteCounterBit:=0;
  WriteBitsBuffer:=0;
End;

Function GetFSize(Var F: TByteFile): Int64;
Begin
{$IFDEF StreamType}
  Result:=F.Size;
{$ENDIF}
{$IFDEF FileType}
  Result:=FileSize(F);
{$ENDIF}
  FSize:=Result;
End;

Begin
  SetLength(OutBuffer, BufLength+1);
  SetLength(InBuffer, BufLength+1);
End.




Компрессировать и декомпрессировать так:

Код: Выделить всё
      CompressProc(DataFile, ArcFile, False, False);
      DeCompressProc(ArcFile, DataFile);


причём файлы или потоки DataFile, ArcFile должны быть уже открыты.
И закрывать вы их тоже сами должны.
Кстати, скоростью компрессии Вы будете довольны.

Re: Сжатие данных по алгоритму LZW

СообщениеДобавлено: 29.10.2013 18:02:17
SeZuka
Tango писал(а):Кстати, скоростью компрессии Вы будете довольны.

А степенью сжатия?

Re: Сжатие данных по алгоритму LZW

СообщениеДобавлено: 30.10.2013 10:31:21
Tango
SeZuka писал(а):
Tango писал(а):Кстати, скоростью компрессии Вы будете довольны.

А степенью сжатия?

Приемлемая.

Книга Дугласа Адамса - Путеводитель по галактике, для путешествующих автостопом (.txt) 269621 байт
сжимается до  125331 байт. за 32ms.

Предложите свою реализацию алгоритма. Я видел и другие, но они были не так быстры.

Re: Сжатие данных по алгоритму LZW

СообщениеДобавлено: 30.10.2013 12:42:13
vada
JPG Или MPEG попробуйте сжать. Больше исходного получится? :)

Re: Сжатие данных по алгоритму LZW

СообщениеДобавлено: 30.10.2013 13:25:46
SeZuka
Tango писал(а):Предложите свою реализацию алгоритма.

Изобретал компрессионный велосипед пару месяцев назад, некоторые реализации работают быстрее вашего, некоторые сильнее жмут, но там алгоритмы совсем другие, арифметическое кодирование, LZ77, и еще куча всего напридуманного. В итоге удалось лишь приблизиться к Дефлату по степени сжатия, а до LZMA так уж слишком далеко, а по скорости, так вообще до них как до луны пешком. В итоге решил для себя пользоваться Deflate сжатием из модуля paszlib, и жмет хорошо и скорость отменная и изобретать ничего не надо :)

Re: Сжатие данных по алгоритму LZW

СообщениеДобавлено: 30.10.2013 14:13:06
Tango
Zlым libom ещё не пользовался, попробую.
А вообще это же раздел алгоритмов, вот я и привёл свой способ реализации классики.

Добавлено спустя 5 минут 38 секунд:
SeZuka писал(а):
Tango писал(а):Предложите свою реализацию алгоритма.

.. а по скорости, так вообще до них как до луны пешком...


Зато этот по скорости самый быстрый. :D

Re: Сжатие данных по алгоритму LZW

СообщениеДобавлено: 30.10.2013 14:40:01
debi12345
А пароли и шифрование ? (файл целиком, или поблочно)
А то ради оных приходится формировать файл и скармливать оный консольной "7z".

Re: Сжатие данных по алгоритму LZW

СообщениеДобавлено: 30.10.2013 14:47:26
Tango
Вах, какие пароли, а сжатие это и есть шифрование, вот пришлю я вам файл сделанные по такому способу, попробуйте расколите.
Часовой пояс: UTC + 3 часа [ Летнее время ]
Страница 1 из 1
Powered by phpBB® Forum Software © phpBB Group
http://www.phpbb.com/