压缩算法.bas

新魔剑压缩机。采用新的压缩算法对文件压缩。

Attribute VB_Name = "压缩算法"
Option Explicit
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (ByRef Ptr() As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Public RePlaceLim As Byte, Pro As Single, Cancel As Boolean, FileName As String

Private Type RePlaceCode
  DicCode(1 To 2) As Byte
  AscCode As Byte
End Type

Private Const ReadLen As Long = 65535

Private Function Compare(Arr() As Byte, i As Long, j As Long) As Byte
On Error GoTo Err
For Compare = 3 To 19
  If Arr(i + Compare) <> Arr(j + Compare) Then Exit Function
Next
Err:
Compare = Compare - 1
End Function


Private Sub ClearArray(Arr() As Byte, Pos As Long)
Dim t As Long
ReDim Arr(Pos To Pos)
Call CopyMemory(t, ByVal VarPtrArray(Arr), 4)
Call CopyMemory(ByVal t + 16, 0&, 4)
End Sub

Private Sub SwapArray(a() As Byte, b() As Byte)
Dim t As Long
Call CopyMemory(t, ByVal VarPtrArray(a), 4)
Call CopyMemory(ByVal VarPtrArray(a), ByVal VarPtrArray(b), 4)
Call CopyMemory(ByVal VarPtrArray(b), t, 4)
End Sub

Private Sub PointCode(SouData() As Byte, DesData() As Byte)

Const RePlaceLim As Byte = 4
Static TempData() As Byte
Static PointTable(0 To 16777215) As Long
Static i As Long, j As Long, k As Long 'i左界,j右界,k浮标
Dim PointCol(1 To 16383) As Integer 'int(65535/4)=16383
Dim PointPos As Long, DesPos As Long, TempPos As Long
Dim l As Byte, r As Byte, t As Long   'l标记
Dim RealLen As Long
Dim AscCol(0 To 255) As Boolean, AscCount As Byte

If UBound(SouData) - LBound(SouData) + 1 = 0 Then
  Erase TempData, PointTable
  i = 0
Else
  If i = 0 Then
    i = 1
    k = 1
    Call ClearArray(DesData, 1)
  End If
  ReDim Preserve TempData(i To UBound(SouData))
  Call CopyMemory(TempData(k), SouData(k), UBound(SouData) - k + 1)

  Do
    If UBound(SouData) - k + 1 > ReadLen Then RealLen = ReadLen Else RealLen = UBound(SouData) - k + 1 '确定读取大小
    j = k + RealLen - 1

    DesPos = UBound(DesData) + 1
    TempPos = DesPos

    ReDim Preserve DesData(LBound(DesData) To TempPos + RealLen + 3)
    Erase AscCol 'Asc集合

    AscCount = 255 'Asc未出现数初始化
    '确定标记l
    For t = k To j
     If AscCol(TempData(t)) = False Then '纪录Asc集合
        AscCol(TempData(t)) = True
        AscCount = AscCount - 1
      End If
      If AscCount = 0 Then Exit For
    Next
    If t < j Then j = t
    For l = 0 To 255
      If AscCol(l) = False Then Exit For
    Next
    DesData(DesPos) = l

    PointPos = 0
    DesPos = DesPos + 2

    For k = k To j - 2
      t = PointTable(TempData(k) * 65536 Or TempData(k + 1) * 256& Or TempData(k + 2))
      DesPos = DesPos + 1
      If k - t <= 4095 And t > 0 Then
        r = Compare(TempData, k, t)
        If r >= RePlaceLim Then
          PointPos = PointPos + 1
          If ((r - 4) * 4096& Or (k - t)) > 32767 Then
          PointCol(PointPos) = ((r - 4) * 4096& Or (k - t)) - 65536
          Else
          PointCol(PointPos) = (r - 4) * 4096& Or (k - t)
          End If
          DesData(DesPos) = l
          If k + r - 1 < j - 2 Then t = k + r - 1 Else t = j - 2
          For t = k To t
            PointTable(TempData(t) * 65536 Or TempData(t + 1) * 256& Or TempData(t + 2)) = t
          Next
          k = k + r - 1
        Else
          PointTable(TempData(k) * 65536 Or TempData(k + 1) * 256& Or TempData(k + 2)) = k
          DesData(DesPos) = TempData(k)
        End If
      Else
        PointTable(TempData(k) * 65536 Or TempData(k + 1) * 256& Or TempData(k + 2)) = k
        DesData(DesPos) = TempData(k)
      End If
    Next
    For k = k To j
      DesPos = DesPos + 1
      DesData(DesPos) = TempData(k)
    Next

    DesData(TempPos + 1) = (DesPos - TempPos - 2) \ 256
    DesData(TempPos + 2) = (DesPos - TempPos - 2) And &HFF
    ReDim Preserve DesData(LBound(DesData) To DesPos + 2 + 2 * PointPos)
    DesData(DesPos + 1) = PointPos \ 256
    DesData(DesPos + 2) = PointPos And &HFF
    If PointPos > 0 Then Call CopyMemory(DesData(DesPos + 3), PointCol(1), 2 * PointPos)

  Loop Until UBound(SouData) - j < 4096

  If k - 4095 > i Then i = k - 4095
  
  Call SwapArray(TempData, SouData)
  ReDim TempData(i To UBound(SouData))
  Call CopyMemory(TempData(i), SouData(i), UBound(SouData) - i + 1)
  If UBound(SouData) >= k Then
    ReDim SouData(k To UBound(SouData))
    Call CopyMemory(SouData(k), TempData(k), UBound(SouData) - k + 1)
  Else
    Call ClearArray(SouData, k)
  End If
  ReDim Preserve TempData(i To k - 1)
  
End If

End Sub

Private Sub UnPointCode(SouData() As Byte, DesData() As Byte)
'变量定义
Static TempData() As Byte
Dim PointCol(1 To 16383) As Integer 'int(65535/4)=16383
Dim RealLen As Long
Dim i As Long, j As Long, k As Long
Dim l As Byte, r As Long, t As Long
Dim PointPos As Long
Dim SouPos As Long, TempPos As Long
Dim TempData2() As Byte

SouPos = LBound(SouData)

If UBound(SouData) - LBound(SouData) + 1 = 0 Then
  Erase TempData
Else
  If LBound(SouData) = 1 Then
    Call ClearArray(DesData, 1)
    Call ClearArray(TempData, 1)
  End If


  l = SouData(SouPos)
  SouPos = SouPos + 1
  RealLen = SouData(SouPos) * 256& Or SouData(SouPos + 1)
  TempPos = SouPos + 2
  SouPos = TempPos + RealLen
  PointPos = SouData(SouPos) * 256& Or SouData(SouPos + 1)
  SouPos = SouPos + 2
  Call CopyMemory(PointCol(1), SouData(SouPos), PointPos * 2)
  SouPos = SouPos + 2 * PointPos

  j = UBound(TempData)
  ReDim Preserve TempData(LBound(TempData) To j + ReadLen) '初始化目标单元大小
  PointPos = 0
  For k = TempPos To TempPos + RealLen - 1
    j = j + 1
    If SouData(k) = l Then
      PointPos = PointPos + 1
      t = PointCol(PointPos) And &HFFF
      For r = 0 To (PointCol(PointPos) And &HFFFF&) \ 4096 + 3
        TempData(j + r) = TempData(j - t + r)
      Next
      j = j + r - 1
    Else
      TempData(j) = SouData(k)
    End If
  Next
    
  'ReDim Preserve TempData(LBound(TempData) To j)  '确定目标单元真实大小
'  ReDim Preserve DesData(LBound(DesData) To j)
'  Call CopyMemory(DesData(LBound(DesData)), TempData(LBound(DesData)), j - LBound(DesData) + 1)
  If j - 4095 > LBound(DesData) Then i = j - 4095 Else i = LBound(DesData)
  
  If SouPos > UBound(SouData) Then
    Call ClearArray(SouData, SouPos)
  Else
    ReDim TempData2(SouPos To UBound(SouData))
    Call CopyMemory(TempData2(SouPos), SouData(SouPos), UBound(SouData) - SouPos + 1)
    Call SwapArray(TempData2, SouData)
  End If

  k = LBound(DesData)
  If i < k Then
    Call SwapArray(TempData, DesData)
    ReDim TempData(i To j)
    Call CopyMemory(TempData(i), DesData(i), j - i + 1)
    ReDim DesData(k To j)
    Call CopyMemory(DesData(k), TempData(k), j - k + 1)
  Else
    If k > j Then
      Call ClearArray(DesData, k)
    Else
      ReDim DesData(k To j)
      Call CopyMemory(DesData(k), TempData(k), j - k + 1)
      ReDim TempData(i To j)
      Call CopyMemory(TempData(i), DesData(i), j - i + 1)
    End If
  End If
End If

End Sub

Private Sub RePlaceCode(SouData() As Byte, DesData() As Byte)

'变量定义
Const RePlaceLim As Byte = 20
Static RePlaceDic(1 To 255) As RePlaceCode, RePlaceAble As Byte '替换表,可替换数
Static i As Long, j As Long
Dim AscCol(0 To 255) As Boolean, AscCount As Byte 'Asc集合
Dim DicCol(0 To 65535) As Byte, DicMap(0 To 65535) As Byte '字典集合,字典映射
Dim RealLen As Long '实际流大小
Dim CycleDic(1 To 255) As RePlaceCode, CycleMap(1 To 255) As Byte '循环字典,循环映射
Dim PossibleCycle As Byte, CycleCount As Byte '可能循环字典,循环数
Dim k As Long, l As Byte, m As Long, n As Long   '杂项变量
Dim TempData() As Byte
Dim DesPos As Long

If UBound(SouData) - LBound(SouData) + 1 = 0 Then
  Erase RePlaceDic
  RePlaceAble = 0
  i = 0
Else
  If i = 0 Then
    i = 1
    Call ClearArray(DesData, 1)
  End If

  Do
    If UBound(SouData) - i + 1 > ReadLen Then RealLen = ReadLen Else RealLen = UBound(SouData) - i + 1 '确定读取大小
    DesPos = UBound(DesData)

    'DoEvents '防卡死
    '分析数据
    Erase AscCol, DicCol, DicMap 'Asc集合,字典集合,字典映射
    AscCol(SouData(i)) = True
    PossibleCycle = RePlaceAble
    RePlaceAble = 0 '可替换数初始化
    AscCount = 255 'Asc未出现数初始化
    For j = i + 1 To i + RealLen - 1
      k = SouData(j - 1) Or SouData(j) * 256&