comp_groupsmart2.bas

20多种VB软件的加密与压缩模块

    Dim BestGroep As Integer                'the best group found
    Dim NewBestGroep As Integer             'check for bestgroup
    Dim StartGroep As Integer               'startgroup to hold the group wich will be checked for better comp.
    Dim BestCompression As Long             'maximum compression (for now)
    Dim WheHaveCompression As Boolean       'whe have found a better method
    Dim Char As Integer                     'character found in input stream
    Dim BitsNoComp As Long                  'bits used if no comp.
    Dim BitsComp As Long                    'bits used if comp.
    Dim CheckLen As Long                    'maximum bytes to check
    Dim StartPos As Long                    'startposition where the check will start
    Dim GroupBits As Integer
    Dim TotInGroup As Long
    StartPos = StartPositie
    RealBegin = StartPos
    StartGroep = MaxGroup
    CheckForBetterWithin2 = MaxGroup
    BestCompression = 0
    If MaxGroup = 1 Then Exit Function          'better than the use of 1 bit ????
    Do While StartPos + NumInGroup <= RealBegin + Group(StartGroep).NumInGroup - 1
        CheckLen = RealBegin - StartPos + Group(StartGroep).NumInGroup - 1
'if ther are less then 3 bytes to check we exit
        If CheckLen < 3 Then Exit Function
        WheHaveCompression = False
        GroupSize = 1                   'Lets start with the minimal groupsize
        Group(GroupSize).LowValue = InArray(StartPos + NumInGroup)
        Group(GroupSize).HighValue = InArray(StartPos + NumInGroup)
'check if we don't check the group we started with
        Do While GroupSize < StartGroep And NumInGroup < 65535
            NumInGroup = NumInGroup + 1
            Group(GroupSize).NumInGroup = NumInGroup
'if we are at the end of the group we exit
            If StartPos + NumInGroup > RealBegin + Group(StartGroep).NumInGroup - 1 Then GoSub Calc_Compression: Exit Do
            Char = InArray(StartPos + NumInGroup)
            If Char < Group(GroupSize).LowValue Then
                If Group(GroupSize).HighValue - Char >= 2 ^ GroupSize Then
                    GoSub Calc_Compression              'we have have found the maximum numer in the group
                    If GroupSize < StartGroep - 1 Then
'why start over again for the next group
'if the number 15 will fit in 4 bits it shure will fit in 5
                        Group(GroupSize + 1).LowValue = Group(GroupSize).LowValue
                        Group(GroupSize + 1).HighValue = Group(GroupSize).HighValue
                    End If
                    GroupSize = GroupSize + 1
                Else
                    Group(GroupSize).LowValue = Char
                End If
            ElseIf Char > Group(GroupSize).HighValue Then
                If Char - Group(GroupSize).LowValue >= 2 ^ GroupSize Then
                    GoSub Calc_Compression
                    If GroupSize < StartGroep - 1 Then
                        Group(GroupSize + 1).LowValue = Group(GroupSize).LowValue
                        Group(GroupSize + 1).HighValue = Group(GroupSize).HighValue
                    End If
                    GroupSize = GroupSize + 1
                Else
                    Group(GroupSize).HighValue = Char
                End If
            End If
        Loop
        If WheHaveCompression = True Then
            If RealBegin = StartPos Then
'if the beginning of the group is the same we startted with we have found a best group and leave
                CheckForBetterWithin2 = BestGroep
                Exit Function
            Else
'if not, then we have to check if there is maybe a compression possible in the part between
'the start of the file and the start of the new found bestgroep (again we start with no compression)
                Group(8).NumInGroup = StartPos - RealBegin
                BestGroep = 8
                NewBestGroep = CheckForBetterWithin2(InArray, Group, 8, RealBegin)
                Do While BestGroep <> NewBestGroep
                    BestGroep = NewBestGroep
                    NewBestGroep = CheckForBetterWithin2(InArray, Group, BestGroep, RealBegin)
                Loop
                CheckForBetterWithin2 = BestGroep
                Exit Function
            End If
        Else
'if we didn't find compression then maybe ther is a part further up in the file that achieves
'even better compression
            StartPos = StartPos + 1
            NumInGroup = 0
        End If
    Loop
    Exit Function
Calc_Compression:
'bits needed if we dont do compression or maybe did already
'3 for the compression method
'3 for the number with will tell the amount of next bits to read
'? numbers of bits needed to store the number of groupsize
'if whe already would do it with compression we need 8 bits for the lowvalue
'plus ofcourse the numbers of bits needed to store the group
    If CheckLen > 65535 Then CheckLen = 65535
    TotInGroup = Group(GroupSize).NumInGroup
    GroupBits = ExtraLengthBits(GetExtraBits(TotInGroup))
    BitsNoComp = 3 + 5 + GroupBits + (8 * Abs(MaxGroup < 8)) + (TotInGroup * 8) - (TotInGroup * (8 - MaxGroup))
'bits needed to store compression
'3 for method,3 for bits needed,the groupsize,8 bits for lowest value and the group itself
    BitsComp = 3 + 5 + GroupBits + (8 * Abs(GroupSize < 8)) + (TotInGroup * 8) - (TotInGroup * (8 - GroupSize))
'if the new groep falls within the range of the old one whe also need to store the header the old group again
    If TotInGroup <= Group(MaxGroup).NumInGroup Then BitsComp = BitsComp + 3 + 5 + ExtraLengthBits(GetExtraBits(CheckLen - StartPos - TotInGroup)) + (8 * Abs(MaxGroup < 8))
'if the start position of the new group is different whe also need the store a new header for that group
    If StartPos <> RealBegin Then BitsComp = BitsComp + 3 + 5 + ExtraLengthBits(GetExtraBits(RealBegin - StartPos)) ' + (8 * Abs(MaxGroup < 8))
    NumInGroup = NumInGroup - 1
'if it is still better than the old method then whe have found a new group
    If BitsComp < BitsNoComp Then
        If BestCompression < BitsNoComp - BitsComp Then
            BestCompression = BitsNoComp - BitsComp
            WheHaveCompression = True
            BestGroep = GroupSize
        End If
    End If
    Return
End Function

'this peace of code is very strait forward
Public Sub DeCompress_SmartGrouping2(ByteArray() As Byte)
    Dim AddFileLen As Long
    Dim OutStream() As Byte         'de output array
    Dim InCont As Long
    Dim InLong As Long
    Dim inLow As Long
    Dim InLitt As Long
    Dim InContBit As Integer
    Dim InLongBit As Integer
    Dim inLowBit As Integer
    Dim InLittBit As Integer
    Dim NewPos As Long
    Dim MaxPos As Long
    Dim PackedOrNot As Integer
    Dim NumBytes As Long
    Dim LowInGroup As Integer       'Laagste waarde in de groep
    Dim NumVal As Byte
    Dim X As Long
    AddFileLen = UBound(ByteArray) / 4
    ReDim OutStream(UBound(ByteArray) + AddFileLen)
    MaxPos = UBound(OutStream)
    InCont = 9
    InLong = CLng(ByteArray(0)) * 256 + ByteArray(1)
    InLong = CLng(InLong) * 256 + ByteArray(2)
    InLong = InCont + InLong
    inLow = CLng(ByteArray(3)) * 256 + ByteArray(4)
    inLow = CLng(inLow) * 256 + ByteArray(5)
    inLow = InLong + inLow
    InLitt = CLng(ByteArray(6)) * 256 + ByteArray(7)
    InLitt = CLng(InLitt) * 256 + ByteArray(8)
    InLitt = inLow + InLitt
    InContBit = 0
    InLittBit = 0
    InLongBit = 0
    inLowBit = 0
    NewPos = 0
    Call Init_Grouping2
    Do                                                              'loop until done
'read 3 bits to get grouping method (0 = not grouped)
        PackedOrNot = ReadBitsFromArray(ByteArray, InCont, InContBit, 3)
'read 5 bits to get the groupsize
        NumVal = ReadBitsFromArray(ByteArray, InLong, InLongBit, 5)
'read the amount of data needed for the group
        NumBytes = StartValLength(NumVal) + ReadBitsFromArray(ByteArray, InLong, InLongBit, CInt(ExtraLengthBits(NumVal)))
        If NumBytes = 0 Then Exit Do            'whe are done
        If PackedOrNot = 0 Then
'if not grouped, read the amount of nongrouped data (8 bits)
            For X = 1 To NumBytes       'de bytes zijn niet geGrouped
                If NewPos > MaxPos Then GoSub Increase_Outstream
                OutStream(NewPos) = ReadBitsFromArray(ByteArray, InLitt, InLittBit, 8)
                NewPos = NewPos + 1
            Next
        Else
'if grouped, read the lowest value in the group
            LowInGroup = ReadBitsFromArray(ByteArray, inLow, inLowBit, 8)
'and get the amount of data for that group
            For X = 1 To NumBytes       'de bytes zijn  geGrouped
                If NewPos > MaxPos Then GoSub Increase_Outstream
                OutStream(NewPos) = ReadBitsFromArray(ByteArray, InLitt, InLittBit, PackedOrNot) + LowInGroup
                NewPos = NewPos + 1
            Next
        End If
    Loop
    NewPos = NewPos - 1
    ReDim ByteArray(NewPos)
'copy the temporary outputstream into the input stream to return it to the caller
    Call CopyMem(ByteArray(0), OutStream(0), NewPos + 1)
    Exit Sub
    
Increase_Outstream:
'this is used if the reserved amount of store space wasn't sufficient
    ReDim Preserve OutStream(NewPos + AddFileLen)
    MaxPos = UBound(OutStream)
    Return
End Sub

'this function will return a value out of the amaunt of bits you asked for
Private Function ReadBitsFromArray(FromArray() As Byte, FromPos As Long, FromBit As Integer, Numbits As Integer) As Long
    Dim X As Integer
    Dim Temp As Long
    For X = 1 To Numbits
        Temp = Temp * 2 + (-1 * ((FromArray(FromPos) And 2 ^ (7 - FromBit)) > 0))
        FromBit = FromBit + 1
        If FromBit = 8 Then
            If FromPos + 1 > UBound(FromArray) Then
                Do While X < Numbits
                    Temp = Temp * 2
                    X = X + 1
                Loop
                FromPos = FromPos + 1
                Exit For
            End If
            FromPos = FromPos + 1
            FromBit = 0
        End If
    Next
    ReadBitsFromArray = Temp
End Function