comp_reducerhalfdict.bas

21加密算法,用vB语言编写实现,可了解各种加密算法的结构

Attribute VB_Name = "Comp_ReducerHalfDict"


Option Explicit

'This is a 2 run method

'this reducer works by splitting a 256 chars dictionary into 128
'dictionaries of 2 chars each
'it will then store the dictionary number and the position of the char
'into the output stream
'the dictnumber will be translated into huffman codes
'so there will be 128 different codes to store + 1 bit for the position
'the dictionary will be created on the flow.

Private Type BytePos
    Data() As Byte
    Position As Long
    Buffer As Integer
    BitPos As Integer
End Type
Private Stream(1) As BytePos    '0=control 1=BitStreams

Private Dictionary As String
Private DictCharCount(256) As Long
Private BitVal() As Long
Private CharVal() As Long
Private HuffDict As String

Public Sub Compress_ReducerDynamicHalfDict(ByteArray() As Byte)
    Dim X As Long
    Dim Y As Long
    Dim NoMore As Boolean
    Dim Most As Long
    Dim NewFileLen As Long
    Dim Nuchar As Byte
    Dim BitsDeep As Long
    Dim ByteVal As Integer
    Call Init_Dictionary
    Call MakeHuffTreeForReducer(ByteArray)
    Call Init_Dictionary
    For Y = 1 To Len(HuffDict)
        Call AddBitsToStream(Stream(0), ASC(Mid(HuffDict, Y, 1)), 8)
    Next
'whe only read the stream and convert them to bitstreams
    For X = 0 To UBound(ByteArray)
        ByteVal = ByteArray(X)
        BitsDeep = ReducerBits(ByteVal)
        Call AddBitsToStream(Stream(0), CLng(BitVal(BitsDeep)), CInt(CharVal(BitsDeep)))
        Call AddBitsToStream(Stream(1), CLng(ByteVal), 1)
    Next
'send the EOF-marker
    ByteVal = 256
    BitsDeep = ReducerBits(ByteVal)
    Call AddBitsToStream(Stream(0), CLng(BitVal(BitsDeep)), CInt(CharVal(BitsDeep)))
    Call AddBitsToStream(Stream(1), CLng(ByteVal), 1)
'lets fill the leftovers
    For X = 0 To 1
        Do While Stream(X).BitPos > 0
            Call AddBitsToStream(Stream(X), 0, 1)
        Loop
    Next
'Lets restore the bounderies
    For X = 0 To 1
        ReDim Preserve Stream(X).Data(Stream(X).Position - 1)
    Next
'whe calculate the new length of the new data
    NewFileLen = 0
    For X = 0 To 1
        NewFileLen = NewFileLen + UBound(Stream(X).Data) + 1
    Next
    ReDim ByteArray(NewFileLen + 3)
'here we store the compressed data
    NewFileLen = 0
    For X = 0 To 0
        ByteArray(NewFileLen) = Int(UBound(Stream(X).Data) / &H10000) And &HFF
        NewFileLen = NewFileLen + 1
        ByteArray(NewFileLen) = Int(UBound(Stream(X).Data) / &H100) And &HFF
        NewFileLen = NewFileLen + 1
        ByteArray(NewFileLen) = UBound(Stream(X).Data) And &HFF
        NewFileLen = NewFileLen + 1
    Next
    For X = 0 To 1
        For Y = 0 To UBound(Stream(X).Data)
            ByteArray(NewFileLen) = Stream(X).Data(Y)
            NewFileLen = NewFileLen + 1
        Next
    Next
End Sub

Public Sub DeCompress_ReducerDynamicHalfDict(ByteArray() As Byte)
    Dim OutStream() As Byte
    Dim OutPos As Long
    Dim InposCont As Long
    Dim InContBit As Integer
    Dim InposData As Long
    Dim InDataBit As Integer
    Dim Char As Integer
    Dim Numbits As Integer
    Dim X As Long
    Dim Temp As Integer
    Dim TotBits As Integer
    Dim TelBits As Integer
    Dim DictString As String
    Dim ByteValue As Integer
    Dim BitsDeep As Integer
    ReDim OutStream(500)
    Call Init_Dictionary
    InposCont = 0
    InposData = 0
    InContBit = 0
'Read total of controler bytes
    For X = 0 To 2
        InposData = CLng(InposData) * 256 + ByteArray(InposCont)
        InposCont = InposCont + 1
    Next
    InposData = InposData + InposCont + 1
'read the huffman header
    TotBits = ReadBitsFromArray(ByteArray, InposCont, InContBit, 8)
    HuffDict = Chr(TotBits)
    TelBits = 0
    For X = 1 To TotBits
        ByteValue = ReadBitsFromArray(ByteArray, InposCont, InContBit, 8)
        TelBits = TelBits + ByteValue
        HuffDict = HuffDict & Chr(ByteValue)
    Next
    For X = 1 To TelBits
        HuffDict = HuffDict & Chr(ReadBitsFromArray(ByteArray, InposCont, InContBit, 8))
    Next
    Call Create_Huffcodes(HuffDict, False)
'Set starting point of the compressed data
    InDataBit = 0
    OutPos = 0
    Do
        Temp = 0
        Numbits = 0
        Do While BitVal(Temp) <> Numbits
            Temp = Temp * 2 + ReadBitsFromArray(ByteArray, InposCont, InContBit, 1)
            Numbits = Numbits + 1
            If TelBits = 20 Then
                Err.Raise vbError, "DecompressHuffman", "We zijn de boom tot op een dood punt genaderd, waarschijnlijk is de header beschadigd"
                Exit Sub
            End If
        Loop
        Numbits = CharVal(Temp)
        Char = ExpanderBits(Numbits, ReadBitsFromArray(ByteArray, InposData, InDataBit, 1))
        If Char = 256 Then Exit Do
        Call AddCharToArray(OutStream, OutPos, CByte(Char))
    Loop
    ReDim ByteArray(OutPos - 1)
    For X = 0 To OutPos - 1
        ByteArray(X) = OutStream(X)
    Next
End Sub

Private Sub Init_Dictionary()
    Dim X As Integer
    Dictionary = ""
    For X = 0 To 255
        Dictionary = Dictionary & Chr(X)
        DictCharCount(X) = 0
    Next
    DictCharCount(256) = 0
    For X = 0 To 1
        ReDim Stream(X).Data(500)
        Stream(X).BitPos = 0
        Stream(X).Buffer = 0
        Stream(X).Position = 0
    Next
End Sub

Private Function ReducerBits(Char As Integer) As Integer
    Dim DiPos As Integer
    If Char = 256 Then ReducerBits = 128: Char = 0: Exit Function
    DiPos = InStr(Dictionary, Chr(Char)) - 1
    Call update_Model(Char)
    ReducerBits = Int(DiPos / 2)
    Char = DiPos Mod 2
End Function

Private Function ExpanderBits(BitsNum As Integer, BytePos As Integer) As Integer
    If BitsNum = 128 And BytePos = 0 Then ExpanderBits = 256: Exit Function
    BitsNum = (BitsNum * 2) + BytePos + 1
    ExpanderBits = ASC(Mid(Dictionary, BitsNum, 1))
    Call update_Model(ExpanderBits)
End Function

Private Sub update_Model(Char As Integer)
    Dim DictPos As Integer
    Dim OldPos As Integer
    Dim Temp As Long
    DictPos = InStr(Dictionary, Chr(Char))
    OldPos = DictPos
    DictCharCount(DictPos) = DictCharCount(DictPos) + 1
    Do While DictPos > 1 And DictCharCount(DictPos) >= DictCharCount(DictPos - 1)
        Temp = DictCharCount(DictPos - 1)
        DictCharCount(DictPos - 1) = DictCharCount(DictPos)
        DictCharCount(DictPos) = Temp
        DictPos = DictPos - 1
    Loop
    If OldPos = DictPos Then Exit Sub
    Dictionary = Left(Dictionary, DictPos - 1) & Chr(Char) & Mid(Dictionary, DictPos, OldPos - DictPos) & Mid(Dictionary, OldPos + 1)
End Sub

'this sub will add an amount of bits to a sertain stream
Private Sub AddBitsToStream(Toarray As BytePos, Number As Long, Numbits As Integer)
    Dim X As Long
    If Numbits = 8 And Toarray.BitPos = 0 Then
        If Toarray.Position > UBound(Toarray.Data) Then ReDim Preserve Toarray.Data(Toarray.Position + 500)
        Toarray.Data(Toarray.Position) = Number And &HFF
        Toarray.Position = Toarray.Position + 1
        Exit Sub
    End If
    For X = Numbits - 1 To 0 Step -1
        Toarray.Buffer = Toarray.Buffer * 2 + (-1 * ((Number And 2 ^ X) > 0))
        Toarray.BitPos = Toarray.BitPos + 1
        If Toarray.BitPos = 8 Then
            If Toarray.Position > UBound(Toarray.Data) Then ReDim Preserve Toarray.Data(Toarray.Position + 500)
            Toarray.Data(Toarray.Position) = Toarray.Buffer
            Toarray.BitPos = 0
            Toarray.Buffer = 0
            Toarray.Position = Toarray.Position + 1
        End If
    Next
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
    If Numbits = 8 And FromBit = 0 Then
        ReadBitsFromArray = FromArray(FromPos)
        FromPos = FromPos + 1
    Else
        For X = 1 To Numbits