lhsz.pas

cipher 5.1。一个几乎包含了所有常见的加密算法的控件

  Inc(LH.Freq[A]);
  Inc(LH.FreqCum);
  X := LH.Parent[A];
  if X <> LH_Root then
  begin
    if LH.Left[X] <> A then LHUpdateFrequency(LH, A, LH.Left[X])
      else LHUpdateFrequency(LH, A, LH.Right[X]);
    repeat
      Y := LH.Parent[X];
      if LH.Left[Y] <> X then B := LH.Left[Y] else B := LH.Right[Y];
      if LH.Freq[A] >= LH.Freq[B] then
      begin
        LH.Parent[A] := Y;
        LH.Parent[B] := X;
        if LH.Left[Y] <> X then LH.Left[Y] := A else LH.Right[Y] := A;
        C := LH.Left[X];
        if C = A then
        begin
          LH.Left[X] := B;
          C := LH.Right[X];
        end else LH.Right[X] := B;
        LHUpdateFrequency(LH, B, C);
        A := B;
      end;
      A := LH.Parent[A];
      X := LH.Parent[A];
    until X = LH_Root;
  end;
end;

// deflation
{$IFDEF LHEncode}
procedure LHDeflate(LH: PLHData);
const
  LH_Found    = 1;
  LH_Full     = 2;
  LH_First    = 4;

  LH_ModeHuff = Integer($80000000);
  LH_ModeBIN  = $40000000;

  function LHHash(LH: PLHData; Index: Integer): Integer;
{$IFDEF UseASM}
  asm
         MOV    EAX,DWord Ptr [EAX].TLHData.Text[EDX]  // Text use overestimated Ringbuffer
         AND    EAX,0FFFFFFh
         MOV    ECX,EAX
         SHR    ECX,9
         XOR    EAX,ECX
         SHR    ECX,5
         XOR    EAX,ECX
         AND    EAX,LH_HashMask
  end;
{$ELSE}
  var
    I: Integer;
  begin
    I := PInteger(@LH.Text[Index])^ and $FFFFFF;
    Result := (I xor (I shr 9) xor (I shr 14)) and LH_HashMask;
  end;
{$ENDIF}

  procedure LHInitLZSS(LH: PLHData);
{$IFDEF UseASM}
  asm
         PUSH   EBX
         PUSH   EDI
         MOV    EBX,EAX

         XOR    EAX,EAX
         LEA    EDI,[EBX].TLHData.DataPos
         MOV    [EBX].TLHData.TextLen,EAX
         MOV    [EBX].TLHData.ResetPos,EAX
         MOV    ECX,10 + LH_MaxSize shr 2
         REP    STOSD

         MOV    EAX,LH_MinCopy
         MOV    [EBX].TLHData.TextPos,EAX
         MOV    [EBX].TLHData.NewPos,EAX

         MOV    [EBX].TLHData.CodeBitsCount,LH_CodeBits

         LEA    EDI,[EBX].TLHData.Head
         MOV    EAX,LH_nil
         MOV    ECX,LH_HashSize
         REP    STOSD

         POP    EDI
         POP    EBX
  end;
{$ELSE}
  var
    I: Integer;
  begin
    with LH^ do
    begin
      LHFill(@LH.DataPos, LH_MaxSize + 10 * 4);
      TextLen := 0;
      ResetPos := 0;
      CodeBitsCount := LH_CodeBits;
      TextPos := LH_MinCopy;
      NewPos := LH_MinCopy;
      for I := Low(Head) to High(Head) do Head[I] := LH_nil;
    end;
  end;
{$ENDIF}

  procedure LHInsertNode(LH: PLHData; N: Integer);
{$IFDEF UseASM}  { insert node to head of list }
  asm
         PUSH   EBX

         MOV    EBX,EAX
         CALL   LHHash               // EAX = Key

         MOV    ECX,DWord Ptr [EBX].TLHData.Head[EAX * 4]  // ECX = T
         MOV    DWord Ptr [EBX].TLHData.Head[EAX * 4],EDX
         MOV    DWord Ptr [EBX].TLHData.Prev[EDX * 4],LH_nil
         CMP    ECX,LH_nil
         JNZ    @@1

         MOV    DWord Ptr [EBX].TLHData.Tail[EAX * 4],EDX
         MOV    DWord Ptr [EBX].TLHdata.Next[EDX * 4],LH_nil
         JMP    @@2

@@1:     MOV    DWord Ptr [EBX].TLHData.Prev[ECX * 4],EDX
         MOV    DWord Ptr [EBX].TLHData.Next[EDX * 4],ECX

@@2:     POP    EBX
  end;
{$ELSE}
  var
    Key,T: Integer;
  begin
    Key := LHHash(LH, N);
    with LH^ do
    begin
      T := Head[Key];
      Head[Key] := N;
      Prev[N] := LH_nil;
      if T = LH_nil then
      begin
        Tail[Key] := N;
        Next[N] := LH_nil;
      end else
      begin
        Next[N] := T;
        Prev[T] := N;
      end;
    end;
  end;
{$ENDIF}

  procedure LHDeleteNode(LH: PLHData; N: Integer);
{$IFDEF UseASM} { Delete node from tail of list }
  asm
         PUSH   EBX
         MOV    EBX,EAX
         CALL   LHHash               // EAX = Key

         MOV    ECX,DWord Ptr [EBX].TLHData.Tail[EAX * 4]
         CMP    ECX,LH_Nil
         JE     @@0
         CMP    ECX,DWord Ptr [EBX].TLHData.Head[EAX * 4]
         JNE    @@1
@@0:     MOV    DWord Ptr [EBX].TLHData.Head[EAX * 4],LH_nil
         JMP    @@2

@@1:     MOV    ECX,DWord Ptr [EBX].TLHData.Prev[ECX * 4]
         MOV    DWord Ptr [EBX].TLHData.Tail[EAX * 4],ECX
         CMP    ECX,LH_nil
         JE     @@2
         MOV    DWord Ptr [EBX].TLHData.Next[ECX * 4],LH_nil

@@2:     POP    EBX
  end;
{$ELSE}
  var
    Key, T: Integer;
  begin
    Key := LHHash(LH, N);
    with LH^ do
    begin
      T := Tail[Key];
      if (T <> LH_nil) and (Head[Key] <> T) then
      begin
        T := Prev[T];
        Tail[Key] := T;
        if T <> LH_nil then Next[T] := LH_nil;
      end else Head[Key] := LH_nil;
    end;
  end;
{$ENDIF}

  procedure LHUpdateRange(LH: PLHData); forward;

  function LHMatch(LH: PLHData; SearchDepth: Boolean): Integer;
{ Find longest string matching lookahead buffer string }

    function LHCompare(LH: PLHData; N, K: Integer): Integer;
    var
      I: Integer;
    begin
      Result := 0;
      I := N;
      while (K <> N) and (I <> LH.TextPos) and (LH.Text[I] = LH.Text[K]) do
      begin
        Inc(I);
        Inc(K);
        Inc(Result);
        if Result >= LH_MaxCopy then Exit;
      end;
    end;

  var
    N,K,L,D,C,Depth: Integer;
  begin
    Result := 0;
    N := LH.NewPos;
    if SearchDepth then
    begin
      Depth := LH.SearchDepth;
      if Depth <= 0 then Exit;
      Inc(N);
      if N >= LH_MaxSize then N := 0;
    end else
    begin
      Depth := LH.SearchMax;
      LH.Distance := 0;
    end;

    K := LH.Head[LHHash(LH, N)];
    if K = LH_nil then Exit;

    C := LH.Text[N];
    repeat
      if C = LH.Text[K + Result] then
      begin
        L := LHCompare(LH, N, K);
        if (L >= LH_MinCopy) and (L > Result) then
        begin
          D := N - K - L;
          if D < 0 then Inc(D, LH_MaxSize);
          if not SearchDepth then LH.Distance := D;
          Result := L;
          if L >= LH_MaxCopy then Exit;
          C := LH.Text[L + N];
        end;
      end;
      Dec(Depth);
      if Depth <= 0 then Exit;
      K := LH.Next[K];
    until K = LH_nil;
  end;

{$IFDEF LHCrypt}
  procedure LHCrypt(LH: PLHData; Size: Integer);
  var
    S: Byte;
    B: PByte;
  begin
    B := @LH.Code;
    if LH.Flag and LH_First = 0 then
    begin
      Inc(B);
      Dec(Size);
      LH.Flag := LH.Flag or LH_First;
    end;
    while Size > 0 do
    begin
      Dec(Size);
      Inc(LH.PC4_I);
      S := LH.PC4_T[LH.PC4_I];
      Inc(LH.PC4_J, S);
      LH.PC4_T[LH.PC4_I] := LH.PC4_T[LH.PC4_J] xor LH.PC4_F;
      LH.PC4_T[LH.PC4_J] := S - LH.PC4_F;
      B^ := (B^ + LH.PC4_F) xor LH.PC4_T[(LH.PC4_T[LH.PC4_I] + S) and $FF];
      LH.PC4_F := B^;
      Inc(B);
    end;
  end;
{$ENDIF}
  function LHWrite(LH: PLHData): Boolean;
  begin
    if LH.State >= LH_Ready then
    begin
      LH.CodeBitsCount := LH_CodeBits;
      PInteger(@LH.Code[LH.CodePos])^ := LH.CodeBits;
      Inc(LH.CodePos, SizeOf(LH.CodeBits));
      Inc(LH.CodeBytes, SizeOf(LH.CodeBits));
      LH.CodeBits := 0;
      if LH.CodePos >= SizeOf(LH.Code) then
      begin
{        if LH.DataBytes - LH.LastBytes < LH.CodePos then
          Inc(LH.OverBytes, LH.CodePos - (LH.DataBytes - LH.LastBytes));
        LH.LastBytes := LH.DataBytes;}
{$IFDEF LHCrypt}
        if LH.PC4_P <> 0 then LHCrypt(LH, LH.CodePos);
{$ENDIF}
        if LH.Write(LH.Code, LH.CodePos) <> LH.CodePos then
          LH.State := LH_ErrWrite;
        LH.CodePos := 0;
      end;
    end;
    Result := LH.State >= LH_Ready;
  end;

  procedure LHWriteCode(LH: PLHData; Value, Bits: Integer);
{$IFDEF UseASM}
  asm
         PUSH  EBX
         PUSH  EDI
         MOV   EBX,EAX
         MOV   EDI,ECX
         MOV   EAX,[EBX].TLHData.CodeBits
         MOV   ECX,[EBX].TLHData.CodeBitsCount

@@1:     SHR   EDX,1
         RCR   EAX,1
         DEC   ECX
         JZ    @@3
@@2:     DEC   EDI
         JNZ   @@1
         MOV   [EBX].TLHData.CodeBits,EAX
         MOV   [EBX].TLHData.CodeBitsCount,ECX

         POP   EDI
         POP   EBX
         RET

@@3:     PUSH  EDX
         MOV   [EBX].TLHData.CodeBits,EAX
         MOV   EAX,EBX
         CALL  LHWrite
         MOV   ECX,[EBX].TLHData.CodeBitsCount
         POP   EDX
         JMP   @@2
  end;
{$ELSE}
  begin
    while Bits > 0 do
    begin
      LH.CodeBits := (LH.CodeBits shr 1) or (Value and 1) shl (LH_CodeBits -1);
      Value := Value shr 1;
      Dec(LH.CodeBitsCount);
      if (LH.CodeBitsCount = 0) and not LHWrite(LH) then Exit;
      Dec(Bits);
    end;
  end;
{$ENDIF}

  procedure LHCompress(LH: PLHData; Code: Integer);
  var
    A,S,T: Integer;
    K: array[0..63] of Boolean;
  begin
    S := 0;
    A := Code + LH.RangeMax;
    repeat
      T := LH.Parent[A];
      K[S] := LH.Right[T] = A;
      A := T;
      Inc(S);
    until A = LH_Root;
    repeat
      Dec(S);
      LH.CodeBits := LH.CodeBits shr 1 or Byte(K[S]) shl (LH_CodeBits -1);
      Dec(LH.CodeBitsCount);
      if (LH.CodeBitsCount = 0) and not LHWrite(LH) then Exit;
    until S = 0;
    LHUpdateModel(LH, Code);
  end;

  procedure LHUpdateRange(LH: PLHData);
  begin
    if LH.RangeCopy < LH_CopyRanges then
    begin
      LHCompress(LH, LH_Special);
      LHWriteCode(LH, LH_SpecialINC, LH_SpecialBITS);
      Inc(LH.RangeCopy);
      LH.RangeMax  := LH_FirstCode + (LH.RangeCopy * LH_CodesPerRange);
      LH.RangeDist := LH.Range[LH.RangeCopy];
    end;
  end;

  procedure LHFlush(LH: PLHData);
  var
    I: Integer;
  begin
    if LH.CodeBitsCount > 0 then
    begin
      PInteger(@LH.Code[LH.CodePos])^ := LH.CodeBits shr LH.CodeBitsCount;
      I := (LH_CodeBits + 7 - LH.CodeBitsCount) div 8;
      Inc(LH.CodePos, I);
      Inc(LH.CodeBytes, I);
      LH.CodeBitsCount := LH_CodeBits;
      LH.CodeBits := 0;
    end;
    if LH.CodePos > 0 then
    begin
{$IFDEF LHCrypt}
      if LH.PC4_P <> 0 then LHCrypt(LH, LH.CodePos);
{$ENDIF}
      if LH.Write(LH.Code, LH.CodePos) <> LH.CodePos then
        LH.State := LH_ErrWrite;
    end;
  end;

  function LHRead(LH: PLHData): Boolean;
  var
    I: Integer;
  begin
    LH.DataPos := 0;
    I := SizeOf(LH.Data);
    if (LH.InputSize >= 0) and (LH.InputSize < LH.DataSize) then I := LH.InputSize;
    if I > 0 then LH.DataSize := LH.Read(LH.Data, I)
      else LH.DataSize := I;
    if LH.DataSize = 0 then LH.State := LH_Finish else
      if LH.DataSize < 0 then LH.State := LH_ErrRead else
      begin
        if LH.InputSize > 0 then Dec(LH.InputSize, LH.DataSize);
        LH.CRC := LHUpdateCRC(LH, LH.Data, LH.DataSize);
      end;
    Result := LH.State >= LH_Ready;
  end;

var
  I, C: Integer;
label
  Skip, Huffman, Finish;
begin
  if LH.State = LH_Init then
  begin
    LHInitCRC(LH);
    LHInitLZSS(LH);
    LHInitHuffman(LH);

    LH.RangeCopy  := 12;
    LH.RangeMax   := LH_FirstCode + (LH.RangeCopy * LH_CodesPerRange);
    LH.RangeDist  := LH.Range[LH.RangeCopy];

    if not LHRead(LH) or (LH.DataSize <= 0) then
    begin
      LH.State := LH_ErrRead;
      Exit;
    end;
    LH.State := LH_Working;

{$IFDEF LHCrypt}
    if LH.PC4_P <> 0 then
    begin
      I := RandSeed; Randomize; C := Random(MaxInt); RandSeed := I;
      for I := 0 to LH.DataSize -1 do
        C := (C + LH.Data[I] * 257) mod MaxInt +1;
      LHWriteCode(LH, 1, 1);
      LHWriteCode(LH, C, 8);
      LHWriteCode(LH, LH.PC4_P xor C, 8);
    end else LHWriteCode(LH, 0, 1);
{$ELSE}
    LHWriteCode(LH, 0, 1);
{$ENDIF}
  { Compress first few characters using Huffman }
    for I := 0 to LH_MinCopy -1 do
    begin
      C := LH.Data[LH.DataPos];
      Inc(LH.DataPos);
      LHCompress(LH, C);
      Inc(LH.DataBytes);
      LH.Text[I] := C;
      if LH.DataPos >= LH.DataSize then
      begin
        if not LHRead(LH) then Exit;
        if LH.State = LH_Finish then goto Finish;
      end;
    end;

  { Preload next few characters into lookahead buffer }
    if LH.State = LH_Working then
      for I := 0 to LH_MaxCopy -1 do
      begin
        C := LH.Data[LH.DataPos];
        Inc(LH.DataPos);
        LH.Text[LH.TextPos] := C;
        if LH.TextPos <= LH_MaxCopy then LH.Text[LH_MaxSize + LH.TextPos] := C;
        Inc(LH.TextPos);
        Inc(LH.DataBytes);
        if LH.DataPos >= LH.DataSize then
        begin
          if not LHRead(LH) then Exit;
          if LH.State = LH_Finish then Break;
        end;
      end;
    if (LH.Mode and LH_Binary <> 0) or (LH.Mode and LH_TypeMask <> LH_Text) then
    begin
      C := 0;
      for I := 0 to LH_MaxCopy + LH_MinCopy do
        if LH.Text[I] > 0 then Inc(C);
      if C > 2 then LH.Mode := LH.Mode or LH_ModeBIN;
    end;
    if LH.Mode and LH_ModeMask = LH_Max then
    begin
      LH.SearchMax   := MaxInt;
      LH.SearchDepth := MaxInt;
    end else
    begin
      if LH.Mode and LH_ModeMask = LH_Auto then
      begin
        LH.SearchMax   := LH_Normal * 4;
        LH.SearchDepth := LH_Normal * 2;
      end else