comp_vbcreorderble.bas

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

'The one with the most characters should have the least amount of repetitions
'First let sort them from lowcount to highcount
    For X = 1 To DifBitLength
        LastPos = ((256 - (2 ^ BitLen(X)) - 1) / 4) + 1
        For Y = 2 To LastPos
            t = S(BitLen(X), Y)
            j = Y
            Do
                If S(BitLen(X), j - 1).Count <= t.Count Then Exit Do
                S(BitLen(X), j) = S(BitLen(X), j - 1)
                j = j - 1
            Loop While j > 1
            S(BitLen(X), j) = t
        Next
    Next
    PosCount = 12
    For X = 1 To PosCount
        Bestway(X).Minimum = -1
        Bestway(X).Maximum = -1
    Next
    FoundFit = False
    For X = DifBitLength To 1 Step -1
        PosCBeg = PosCount
        FoundFit = False
        StilNeed = BitNeed(BitLen(X))
        Do While StilNeed > 0
            NowNeed = BitLen(X)
            If FoundFit = False Then
                NuPos = Stpoint(NowNeed)
            Else
                NuPos = 1
            End If
            LastPos = ((256 - (2 ^ NowNeed) - 1) / 4) + 1
            Do While NuPos <= LastPos
                FoundFit = True
                For Z = 12 To PosCount Step -1
                    If S(NowNeed, NuPos).StartPos + (2 ^ NowNeed - 1) >= Bestway(Z).Minimum And S(NowNeed, NuPos).StartPos <= Bestway(Z).Maximum Then
                        FoundFit = False
                        Exit For
                    End If
                Next
                If FoundFit = True Then
                    NewFileLong = NewFileLong + S(NowNeed, NuPos).Count * (NowNeed + 4)
                    Bestway(PosCount).Minimum = S(NowNeed, NuPos).StartPos
                    Bestway(PosCount).Maximum = S(NowNeed, NuPos).StartPos + (2 ^ NowNeed - 1)
                    PosCount = PosCount - 1
                    StilNeed = StilNeed - 1
                    Exit Do
                End If
                NuPos = NuPos + 1
            Loop
            If FoundFit = False Then
'reset all findings
                For Z = PosCount To PosCBeg
                    Bestway(Z).Minimum = -1
                    Bestway(Z).Maximum = -1
                Next
                NewFileLong = 0
                PosCount = PosCBeg
                If NuPos > LastPos Then
                    If Stpoint(NowNeed) = LastPos - 1 Then
                        If X = DifBitLength Then
                            MsgBox ("Fail to re-order")
                            Exit Function
                        Else
                            X = X + 1
                            PosCount = PosCount + BitNeed(BitLen(X))
                        End If
                    End If
                End If
                Stpoint(NowNeed) = Stpoint(NowNeed) + 1
                StilNeed = BitNeed(BitLen(X))
            End If
        Loop
    Next
'transpose them to the variable that can be used troughout the programm
    For X = 1 To 12
        ExtraBits(X).LowValue = Bestway(X).Minimum
    Next
'    Find_Best2 = (NewLong / 8) + 9
End Function

'Here whe're gone Decompress using the VBC-Reorderble method
Public Sub DeCompress_VBC_Reorderble(ByteArray() As Byte)
    Dim X As Long
    Dim OutStream() As Byte
    Dim InpPos As Long
    Dim FileLang As Long
    Dim Char As Byte
    Dim ExtBits As Integer
'init the coder to the standard values so you know how much bits needed for each group
    Call Init_VBC
    LastChar = 0
'extract the original filelenght
    For X = 0 To 3
        FileLang = FileLang * 256 + ByteArray(X)
    Next
    InpPos = 4
'read the 12 values needed to add to the other stored values
    For X = 1 To 12
        ExtraBits(X).LowValue = ReadBitsFromArray(ByteArray, InpPos, 6) * 4
    Next
    ReDim OutStream(FileLang)
    Do While OutPos < FileLang + 1
        ExtBits = ReadBitsFromArray(ByteArray, InpPos, 2)       'read two bits
        If ExtBits = 0 Then                                     'if the two bits say 0 then the new char
            Char = LastChar                                     'is the same as the last char
        Else
'else read two bits more for the group, read the char and and the lowest value
            ExtBits = ExtBits * 4 + ReadBitsFromArray(ByteArray, InpPos, 2)
            Char = ReadBitsFromArray(ByteArray, InpPos, CInt(ExtraBits(ExtBits - 3).Needed)) + ExtraBits(ExtBits - 3).LowValue
        End If
'store the new char into the output stream and store it as the last char
        Call AddCharToArray(OutStream, OutPos, Char)
        LastChar = Char
    Loop
    OutPos = OutPos - 1
    ReDim ByteArray(OutPos)
'copy it intoe the bytearray to return it to the caller
    Call CopyMem(ByteArray(0), OutStream(0), OutPos + 1)
End Sub

'Here whe're gone initialize some variables needed troughout the program
Private Sub Init_VBC()
    OutPos = 0
    OutByteBuf = 0
    OutBitCount = 0
    ReadBitPos = 0
'                    bitsNeeded    from to char     gain/loss
    ExtraBits(0).Needed = 0     'Last Character     +6          only two bits needed to define 0
    ExtraBits(1).Needed = 2     '? - ?+3            +2
    ExtraBits(2).Needed = 2     '? - ?+3            +2
    ExtraBits(3).Needed = 2     '? - ?+3            +2
    ExtraBits(4).Needed = 2     '? - ?+3            +2
    ExtraBits(5).Needed = 2     '? - ?+3            +2
    ExtraBits(6).Needed = 2     '? - ?+3            +2
    ExtraBits(7).Needed = 2     '? - ?+3            +2
    ExtraBits(8).Needed = 2     '? - ?+3            +2
    ExtraBits(9).Needed = 5     '? - ?+31           -1
    ExtraBits(10).Needed = 6    '? - ?+63           -1
    ExtraBits(11).Needed = 6    '? - ?+63           -2
    ExtraBits(12).Needed = 6    '? - ?+63           -2
'ExtraBits().LowValue need to be defined by the program
End Sub

'Here whe're gone check the minimum amount of bits needed to store a value
Private Function getBitSize(Char As Byte) As Byte
    Dim X As Integer
    If Char = LastChar Then
        getBitSize = 0
        Exit Function
    End If
    For X = 1 To 12
        If Char >= ExtraBits(X).LowValue And Char < ExtraBits(X).LowValue + 2 ^ ExtraBits(X).Needed Then
            getBitSize = X
            Exit Function
        End If
    Next
End Function

'this sub will add an amount of bits into the outputstream
Private Sub AddBitsToArray(Toarray() As Byte, Number As Long, Numbits As Integer)
    Dim X As Long
    For X = Numbits - 1 To 0 Step -1
        OutByteBuf = OutByteBuf * 2 + (-1 * ((Number And 2 ^ X) > 0))
        OutBitCount = OutBitCount + 1
        If OutBitCount = 8 Then
            Toarray(OutPos) = OutByteBuf
            OutBitCount = 0
            OutByteBuf = 0
            OutPos = OutPos + 1
            If OutPos > UBound(Toarray) Then
                ReDim Preserve Toarray(OutPos + 500)
            End If
        End If
    Next
End Sub

'this sub will add a char into the outputstream
Private Sub AddCharToArray(Toarray() As Byte, ToPos As Long, Char As Byte)
    If ToPos > UBound(Toarray) Then
        ReDim Preserve Toarray(ToPos + 500)
    End If
    Toarray(ToPos) = Char
    ToPos = ToPos + 1
End Sub

'this sub will read an amount of bits from the inputstream
Private Function ReadBitsFromArray(FromArray() As Byte, FromPos As Long, 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 - ReadBitPos)) > 0))
        ReadBitPos = ReadBitPos + 1
        If ReadBitPos = 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
            ReadBitPos = 0
        End If
    Next
    ReadBitsFromArray = Temp
End Function