GFCompression/GFCompression_Huffmanmod.bas

Attribute VB_Name = "GFCompression_Huffmanmod"
Option Explicit
'(c)2001 by Louis.
Private Declare Function DLLHuffman_CompressString Lib "cmprss10.dll" Alias "Huffman_CompressString" (ByRef HT_CodeStringStructArray As AnyByVal ByteStringLength As LongByRef ByteString As AnyByVal CompressedStringLength As LongByRef CompressedString As Any) As Long
Private Declare Function DLLHuffman_DecompressString Lib "cmprss10.dll" Alias "Huffman_DecompressString" (ByRef HuffmanDecompressStructArray As AnyByVal ByteStringLength As LongByRef ByteString As AnyByVal BitReadStartPos As LongByVal OutputByteStringLength As LongByRef OutputByteString As Any) As Long
'general use
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As AnyByVal cbCopy As Long)

'****************************************HUFFMAN****************************************
'NOTE: the Huffman compression assigns shorter bit codes to chars that appear
'with a high frequency in the string to compress, and longer bit codes to chars that
'appear with a low frequency.
'The HT_CodeStringStruct contains the chars and the related bit code length and the
'bit code itself.
'The HT_CodeStringStruct is temporarily used to create the HT_CodeStringStruct.
'
'Every char of the char set (code 0 ‑ 255) gets a bit code assigned.
'The compressed string has the following format:
'
'FFFFTTTTB[*256]C[*TTTT]X
'F: original string (file) length
'T: total length (bytes) of all bit codes (code 0 ‑ 255)
'B: length (bits) of related bit code
'C: bit code
'X: compressed string
'
'T + B + C: HuffmanTreeCode[String/ByteString]
'

Public Function Huffman_CompressString(ByRef ByteStringLength As LongByRef ByteString() As Byte) As Boolean
    'on error resume next
    Dim HT_CodeStringStructNumber As Integer
    Dim HT_CodeStringStructArray(0 To 255) As HT_CodeStringStruct
    Dim HT_CharInfoStructVar As HT_CharInfoStruct
    Dim CompressedStringLength As Long
    Dim CompressedString() As Byte
    Dim CompressedStringIndex As Long
    Dim TreeByteStringLength As Long
    Dim TreeByteString() As Byte
    Dim InputByteStringLength As Long
    'end of compression
    Dim ByteStringLengthUnchanged As Long
    Dim GFCompressionHeaderStructVar As GFCompressionHeaderStruct
    Dim Temp As Long
    Dim Tempdbl#
    'preset
    ByteStringLengthUnchanged = ByteStringLength
    'begin
    'create Huffman tree struct
    HT_CodeStringStructNumber = 256 'preset
    Call HTCS_HT_CodeStringStruct_Define(ByteStringLength, ByteString(), HT_CharInfoStructVar, HT_CodeStringStructNumber, HT_CodeStringStructArray())
    'calculate length of the compressed data
    For Temp = 0 To 255
        Tempdbl# = Tempdbl# + _
            CDbl(HT_CharInfoStructVar.CharFrequencyArray(Temp)) * _
            CDbl(HT_CodeStringStructArray(Temp).CodeLength)
    Next Temp
    CompressedStringLength = CLng(‑Int(‑(Tempdbl# / 8#)))
    If Not (CompressedStringLength = 0) Then
        ReDim CompressedString(1 To CompressedStringLength) As Byte
    Else
        GoTo Error:
    End If
    'compress input string
    If IsVCCompressionAvailable = True Then
        Call Huffman_CompressString_VC(HT_CodeStringStructArray(), ByteStringLength, ByteString(), CompressedStringLength, CompressedString())
    Else
        Call Huffman_CompressString_VB(HT_CodeStringStructArray(), ByteStringLength, ByteString(), CompressedStringLength, CompressedString())
    End If
    'create the Huffman tree code string
    Call HTCS_TreeCodeByteString_Define(HT_CodeStringStructArray(), TreeByteStringLength, TreeByteString())
    'create the final compressed string
    InputByteStringLength = ByteStringLength
    ByteStringLength = 4 + CompressedStringLength + TreeByteStringLength
    ReDim ByteString(1 To ByteStringLength) As Byte
    Call CopyMemory(ByteString(1), InputByteStringLength, 4)
    Call CopyMemory(ByteString(5), TreeByteString(1), TreeByteStringLength)
    Call CopyMemory(ByteString(5 + TreeByteStringLength), CompressedString(1), CompressedStringLength)
    'add GFCompressionHeader
    '
    If GFCompressionHeader_Preset(GFCompressionHeaderStructVar) = False Then GoTo Error:
    If GFCompressionHeader_Write(ByteStringLength, ByteString(), ByteStringLength, ByteStringLengthUnchanged) = False Then GoTo Error:
    '
    Huffman_CompressString = True 'ok
    Exit Function
Error:
    Huffman_CompressString = False 'error
    Exit Function
End Function

Private Sub Huffman_CompressString_VC(ByRef HT_CodeStringStructArray() As HT_CodeStringStruct, ByVal ByteStringLength As LongByRef ByteString() As ByteByVal CompressedStringLength As LongByRef CompressedString() As Byte)
    'on error resume next
    Call DLLHuffman_CompressString(HT_CodeStringStructArray(0), ByteStringLength, ByteString(1), CompressedStringLength, CompressedString(1))
End Sub

Private Sub Huffman_CompressString_VB(ByRef HT_CodeStringStructArray() As HT_CodeStringStruct, ByVal ByteStringLength As LongByRef ByteString() As ByteByVal CompressedStringLength As LongByRef CompressedString() As Byte)
    'on error resume next
    Dim CompressedStringBitWritePos As Long
    Dim CompressedStringIndex As Long
    Dim Temp1 As Long
    Dim Temp2 As Long
    'begin
    For Temp1 = 1& To ByteStringLength
        '
        'NOTE: CompressedStringBitWritePos indendicates the bit in
        'CompressedString() where the next code string is to be 'added'.
        '
        For Temp2 = 1& To HT_CodeStringStructArray(ByteString(Temp1)).CodeLength
            '
            CompressedStringBitWritePos = CompressedStringBitWritePos + 1&
            '
            If (HT_CodeStringStructArray(ByteString(Temp1)).CodeArray(Temp2)) Then
                '
                'NOTE: earlier 'down‑converting' is faster:
                'a = CLng((9# ‑ 1#) / 8# + 1#) 'slower
                'a = CLng((9# ‑ 1#) / 8#) + 1& 'faster
                '
                CompressedStringIndex = ((CompressedStringBitWritePos ‑ 1&) \ 8&) + 1&
'                CompressedString(CompressedStringIndex) = _
'                    CompressedString(CompressedStringIndex) _
'                    Or _
'                    HT_CodeStringStructArray(ByteString(Temp1)).CodeArray(Temp2) * _
'                    (2& ^ (7& ‑ ((CompressedStringBitWritePos + 7&) Mod 8&)))
                'NOTE: Mod is much faster than Select Case (tested).
                'NOTE: copying Byte vars to Long vars before using Or did NOT increase speed.
                'NOTE: as 2 ^ is much slower than a Select Case statement checking
                '8 values we use the Select Case statement:
                '
                Select Case (CompressedStringBitWritePos Mod 8&)
                Case 1& 'propability is the same for every value
                    CompressedString(CompressedStringIndex) = CompressedString(CompressedStringIndex) _
                        Or HT_CodeStringStructArray(ByteString(Temp1)).CodeArray(Temp2) * 128& '2 ^ 7 = 128
                Case 2&
                    CompressedString(CompressedStringIndex) = CompressedString(CompressedStringIndex) _
                        Or HT_CodeStringStructArray(ByteString(Temp1)).CodeArray(Temp2) * 64& '2 ^ 6 = 64
                Case 3&
                    CompressedString(CompressedStringIndex) = CompressedString(CompressedStringIndex) _
                        Or HT_CodeStringStructArray(ByteString(Temp1)).CodeArray(Temp2) * 32& '2 ^ 5 = 32
                Case 4&
                    CompressedString(CompressedStringIndex) = CompressedString(CompressedStringIndex) _
                        Or HT_CodeStringStructArray(ByteString(Temp1)).CodeArray(Temp2) * 16& '2 ^ 4 = 16
                Case 5&
                    CompressedString(CompressedStringIndex) = CompressedString(CompressedStringIndex) _
                        Or HT_CodeStringStructArray(ByteString(Temp1)).CodeArray(Temp2) * 8& '2 ^ 3 = 8
                Case 6&
                    CompressedString(CompressedStringIndex) = CompressedString(CompressedStringIndex) _
                        Or HT_CodeStringStructArray(ByteString(Temp1)).CodeArray(Temp2) * 4& '2 ^ 2 = 4
                Case 7&
                    CompressedString(CompressedStringIndex) = CompressedString(CompressedStringIndex) _
                        Or HT_CodeStringStructArray(ByteString(Temp1)).CodeArray(Temp2) * 2& '2 ^ 1 = 1
                Case 0& 'as we removed '+ 7&' (see original calculation that is commented out) things get mysterious and we must use 0 and not 8 here
                    CompressedString(CompressedStringIndex) = CompressedString(CompressedStringIndex) _
                        Or HT_CodeStringStructArray(ByteString(Temp1)).CodeArray(Temp2) '* 1& '2 ^ 0 = 1
                End Select
            End If
        Next Temp2
    Next Temp1
End Sub

Public Function Huffman_DecompressString(ByRef ByteStringLength As LongByRef ByteString() As ByteByRef BlockLengthProcessed As Long) As Boolean
    'on error resume next 'returns True for success or False for error
    Dim HT_CodeStringStructNumber As Integer
    Dim HT_CodeStringStructArray(0 To 255) As HT_CodeStringStruct
    Dim HT_TreeStringStructVar As HT_TreeStringStruct
    Dim HTDC_CodeStringStructArray(0 To 255) As HTDC_CodeStringStruct
    Dim OutputStringStartPos As Long 'start pos of decompressed string in compressed string (after tree data)
    Dim OutputByteStringLength As Long
    Dim OutputByteString() As Byte
    Dim GFCompressionHeaderStructVar As GFCompressionHeaderStruct
    'preset
    '
    If GFCompressionHeader_Preset(GFCompressionHeaderStructVar) = False Then GoTo Error:
    If GFCompressionHeader_Read(ByteStringLength, ByteString(), GFCompressionHeaderStructVar.BlockLengthCompressed, GFCompressionHeaderStructVar.BlockLengthOriginal) = False Then GoTo Error:
    If GFCompressionHeader_Remove(ByteStringLength, ByteString(), GFCompressionHeaderStructVar, BlockLengthProcessed) = False Then GoTo Error:
    '
    'retain Huffman tree containing char codes
    HT_CodeStringStructNumber = 256
    Call HTDC_HT_TreeStringStructVar_Define(HT_TreeStringStructVar, ByteStringLength, ByteString())
    Call HTDC_HT_CodeStringStruct_Define(HT_CodeStringStructArray(), HT_TreeStringStructVar)
    Call HTDC_CodeStringStruct_Define(HT_CodeStringStructArray(), HTDC_CodeStringStructArray())
    '
    'NOTE: HTDC_CodeStringStructArray(0) contains the shortest,
    'HTDC_CodeStringStructArray(255) the longest bit code.
    'Note that the shortest bit code will also appear the most frequently so
    'that the decompression becomes fast.
    '
    Call CopyMemory(OutputByteStringLength, ByteString(1), 4) 'get decompressed string length
    ReDim OutputByteString(1 To OutputByteStringLength) As Byte
    OutputStringStartPos = 4 + 4 + HT_TreeStringStructVar.TreeByteStringLength + 1 'ok
    'decompress string
    If IsVCCompressionAvailable = True Then
        Call Huffman_DecompressString_VC(HTDC_CodeStringStructArray(), ByteStringLength, ByteString(), _
             (OutputStringStartPos * 8), OutputByteStringLength, OutputByteString())
    Else
        Call Huffman_DecompressString_VB(HTDC_CodeStringStructArray(), ByteStringLength, ByteString(), _
             (OutputStringStartPos * 8), OutputByteStringLength, OutputByteString())
    End If
    'create final, decompressed return string
    ByteStringLength = OutputByteStringLength
    ReDim ByteString(1 To OutputByteStringLength) As Byte
    Call CopyMemory(ByteString(1), OutputByteString(1), OutputByteStringLength) 'transfer decompressed string
    Huffman_DecompressString = True 'ok
    Exit Function
Error:
    Huffman_DecompressString = False 'error
    Exit Function
End Function

Private Sub Huffman_DecompressString_VC(ByRef HTDC_CodeStringStructArray() As HTDC_CodeStringStruct, ByVal ByteStringLength As LongByRef ByteString() As ByteByVal BitReadStartPos As LongByVal OutputByteStringLength As LongByRef OutputByteString() As Byte)
    'on error resume next
    Call DLLHuffman_DecompressString(HTDC_CodeStringStructArray(0), ByteStringLength, ByteString(1), BitReadStartPos, OutputByteStringLength, OutputByteString(1))
End Sub

Private Sub Huffman_DecompressString_VB(ByRef HTDC_CodeStringStructArray() As HTDC_CodeStringStruct, ByVal ByteStringLength As LongByRef ByteString() As ByteByVal BitReadStartPos As LongByVal OutputByteStringLength As LongByRef OutputByteString() As Byte)
    'on error resume next
    Dim CodeBufLength As Long
    Dim CodeBufArray(1 To 256) As Byte 'current code from input string
    Dim ByteStringIndex As Long
    Dim ByteStringLong As Long 'part of ByteString()
    Dim BitReadPos As Long
    Dim Temp1 As Long
    Dim Temp2 As Long
    Dim Temp3 As Long
    Dim Temp4 As Long
    'begin
    BitReadPos = BitReadStartPos
    For Temp1 = 1& To OutputByteStringLength
        'Temp1 = write pos into output string
        For Temp2 = 1& To 2048& 'read up to 256 chars (2048 bits) into CodeBufArray()
            'Temp2 = write pos into buffer array
            BitReadPos = BitReadPos + 1&
            ByteStringIndex = ((BitReadPos ‑ 1&) \ 8&)
            '
            'If (ByteString(ByteStringIndex) And (2& ^ (7& ‑ ((BitReadPos + 7&) Mod 8&)))) Then
            'NOTE: copying Byte vars to Long vars before using And did NOT increase speed.
            '
            Select Case BitReadPos Mod 8&
            Case 1&
                If (ByteString(ByteStringIndex) And 128&) Then
                    CodeBufArray(Temp2) = 1
                Else
                    CodeBufArray(Temp2) = 0
                End If
            Case 2&
                If (ByteString(ByteStringIndex) And 64&) Then
                    CodeBufArray(Temp2) = 1
                Else
                    CodeBufArray(Temp2) = 0
                End If
            Case 3&
                If (ByteString(ByteStringIndex) And 32&) Then
                    CodeBufArray(Temp2) = 1
                Else
                    CodeBufArray(Temp2) = 0
                End If
            Case 4&
                If (ByteString(ByteStringIndex) And 16&) Then
                    CodeBufArray(Temp2) = 1
                Else
                    CodeBufArray(Temp2) = 0
                End If
            Case 5&
                If (ByteString(ByteStringIndex) And 8&) Then
                    CodeBufArray(Temp2) = 1
                Else
                    CodeBufArray(Temp2) = 0
                End If
            Case 6&
                If (ByteString(ByteStringIndex) And 4&) Then
                    CodeBufArray(Temp2) = 1
                Else
                    CodeBufArray(Temp2) = 0
                End If
            Case 7&
                If (ByteString(ByteStringIndex) And 2&) Then
                    CodeBufArray(Temp2) = 1
                Else
                    CodeBufArray(Temp2) = 0
                End If
            Case 0&
                If (ByteString(ByteStringIndex) And 1&) Then
                    CodeBufArray(Temp2) = 1
                Else
                    CodeBufArray(Temp2) = 0
                End If
            End Select
            '
            For Temp3 = HTDC_CodeStringStructArray(1).StartIndexArray(Temp2) To HTDC_CodeStringStructArray(1).EndIndexArray(Temp2) 'check out if string in CodeBufArray() is equal to any of the existing non‑zero char strings
                'NOTE: HTDC_CodeStringStructArray(x).NonZeroLengthCharCodeNumber is constant for all x.
                If (Temp2 = HTDC_CodeStringStructArray(Temp3).CharCodeArrayLength) Then 'Temp2 is the current code string length
                    For Temp4 = 1& To HTDC_CodeStringStructArray(Temp3).CharCodeArrayLength 'check all chars of code
                        If Not (HTDC_CodeStringStructArray(Temp3).CharCodeArray(Temp4) = CodeBufArray(Temp4)) Then
                            GoTo Skip:
                        End If
                    Next Temp4
                    OutputByteString(Temp1) = HTDC_CodeStringStructArray(Temp3).Char
                    GoTo Jump:
Skip:
                End If
            Next Temp3
        Next Temp2
Jump:
    Next Temp1
End Sub

'************************************END OF HUFFMAN*************************************


[END OF FILE]