Código:
Option Explicit
'This is a 1 run method
'This compressor makes use of the Fibonacci codes
'How This codes are build up you can see in the init section
Private Type Fibonacci_Code
LeadingZero As Integer
Value As Long
End Type
Private BitNumVal(11) As Integer
Private Fibonacci(257) As Fibonacci_Code
Private OutPos As Long
Private OutByteBuf As Byte
Private OutBitCount As Integer
Private InpPos As Long
Private ReadBitPos As Integer
Private Sub Init_Fibonacci_code()
' 1 2 3 5 8 13 21 34 55 89 144 233
' --------------------------------------------
' 1 (1) =1
' 0 1 (1) =2
' 0 0 1 (1) =3
' 1 0 1 (1) =4
' 0 0 0 1 (1) =5
' 1 0 0 1 0 0 1 (1) =27
' 0 0 1 0 1 0 1 (1) =32
' = 3 + 8 + 21 = =32
BitNumVal(0) = 1
BitNumVal(1) = 2
BitNumVal(2) = 3
BitNumVal(3) = 5
BitNumVal(4) = 8
BitNumVal(5) = 13
BitNumVal(6) = 21
BitNumVal(7) = 34
BitNumVal(8) = 55
BitNumVal(9) = 89
BitNumVal(10) = 144
BitNumVal(11) = 233
OutPos = 0
OutByteBuf = 0
OutBitCount = 0
InpPos = 0
ReadBitPos = 0
End Sub
Private Sub Create_Fibonacci_Codes()
Dim Temp As String
Dim X As Integer
Dim Y As Integer
Dim Value As Integer
Dim bitcount As Integer
Call Init_Fibonacci_code
For Y = 1 To 257
Value = Y
Fibonacci(Y).LeadingZero = 0
Fibonacci(Y).Value = 1
bitcount = 0
For X = 11 To 0 Step -1
If Value - BitNumVal(X) < 0 Then
If Fibonacci(Y).Value > 1 Then
Fibonacci(Y).LeadingZero = Fibonacci(Y).LeadingZero + 1
End If
Else
bitcount = bitcount + 1
Fibonacci(Y).Value = Fibonacci(Y).Value + 2 ^ bitcount
Fibonacci(Y).LeadingZero = -1 * (X > 0)
Value = Value - BitNumVal(X)
X = X - 1
End If
If bitcount > 0 Then
bitcount = bitcount + 1
End If
Next
Next
End Sub
Public Sub Compress_Fibonacci(ByteArray() As Byte)
Dim OutStream() As Byte
Dim X As Long
Call Create_Fibonacci_Codes
ReDim OutStream(UBound(ByteArray))
For X = 0 To UBound(ByteArray)
Call AddFibonacciToArray(OutStream, CLng(ByteArray(X)))
Next
Call AddFibonacciToArray(OutStream, 256)
If OutBitCount > 0 Then
Call AddBitsToArray(OutStream, 0, 8 - OutBitCount)
End If
ReDim ByteArray(OutPos)
Call CopyMem(ByteArray(0), OutStream(0), OutPos + 1)
End Sub
Public Sub DeCompress_Fibonacci(ByteArray() As Byte)
Dim OutStream() As Byte
Dim Char As Integer
Dim X As Long
Call Init_Fibonacci_code
ReDim OutStream(UBound(ByteArray))
Char = ReadFibonacciCode(ByteArray)
Do While Char <> 256
Call AddCharToArray(OutStream, Char)
Char = ReadFibonacciCode(ByteArray)
Loop
OutPos = OutPos - 1
ReDim ByteArray(OutPos)
Call CopyMem(ByteArray(0), OutStream(0), OutPos + 1)
End Sub
Private Sub AddFibonacciToArray(Toarray() As Byte, Char As Long)
Dim X As Integer
Dim bitcount As Integer
Char = Char + 1
For bitcount = 0 To 14
If Fibonacci(Char).Value < 2 ^ bitcount Then
Exit For
End If
Next
Call AddBitsToArray(Toarray, 0, Fibonacci(Char).LeadingZero)
Call AddBitsToArray(Toarray, Fibonacci(Char).Value, bitcount)
End Sub
Private Function ReadFibonacciCode(FromArray() As Byte) As Integer
Dim bitcount As Integer
Dim Temp As Integer
Dim BitVal As Integer
Dim LastCode As Boolean
LastCode = False
Do
BitVal = ReadBitsFromArray(FromArray, InpPos, 1)
If BitVal = 1 Then
If LastCode = True Then
Exit Do
Else
LastCode = True
End If
Temp = Temp + BitNumVal(bitcount)
Else
LastCode = False
End If
bitcount = bitcount + 1
Loop
ReadFibonacciCode = Temp - 1
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
Private Sub AddCharToArray(Toarray() As Byte, Char As Integer)
If OutPos > UBound(Toarray) Then
ReDim Preserve Toarray(OutPos + 100)
End If
Toarray(OutPos) = Char
OutPos = OutPos + 1
End Sub
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
Método 4: GroupSmart
Código:
Option Explicit
'This is a 1 run method
'This method is the smartgrouping method
'it will search for follower bytes within a curtain range wich
'will fit into a curtain bitlenght
'It will search as long as needed to find the best compression
'if it finds followers of 12*0 and 4*1 = 16 bytes it will be compressed
'because 0 - 0 and 1 - 0 will both fit into 1 bit, it will fit
'in 16*1 bit wich will lead to to the following
'in 17 headerbits and 16 codebits = 33 bits = 4 bytes and 1 bit
'if it finds followers of 12*0 and 4*173 = 16 bytes it will be compressed
'because 0 - 0 will fit in 1 bit and 173 - 173 will fit into 1 bit it will fit
'in 12*1 bit and 4*1 bit wich will lead to to the following
'in 17 headerbits and 12 codebits = 29 bits = 3 bytes and 5 bits
'in 17 headerbits and 4 codebits = 21 bits = 2 bytes and 3 bits
'wich get a total of 6 bytes
Private OutPos As Long 'invoeg positie voor de output array
Private OutBitCount As Integer
Private OutByteBuf As Byte
Private ReadBitPos As Integer
Private NumExtBits(7) As Byte
Private Type Grouping
LowValue As Long
HighValue As Long
NumInGroup As Long
End Type
Private Sub Init_Grouping()
OutPos = 0 'Next position in the output stream
OutBitCount = 0 'Number of bits stored in the output buffer
OutByteBuf = 0 'byte wich will be stores in outputstream if it is filled with 8 bits
ReadBitPos = 0 'next position wich will be read
'This array is used to determen the amount of bits used to store a number
NumExtBits(0) = 3 '<8
NumExtBits(1) = 3 '<16
NumExtBits(2) = 4 '<32
NumExtBits(3) = 5 '<64
NumExtBits(4) = 6 '<128
NumExtBits(5) = 7 '<256
NumExtBits(6) = 8 '<512
NumExtBits(7) = 16 'the rest
End Sub
Public Sub Compress_SmartGrouping(ByteArray() As Byte)
Dim OutStream() As Byte 'The output array
Dim BeginGroup As Long 'Start for the next bytes wich will be compressed
Dim BestGroup As Integer 'Best grouping method to get the best result
Dim NewBest As Integer 'used to check if there is maybe a better method
Dim BitsDeep As Integer 'This is used as a dummy
Dim X As Long
Dim TotFileLen As Long 'total file len
Dim Group(1 To 8) As Grouping
TotFileLen = UBound(ByteArray)
ReDim OutStream(TotFileLen + (TotFileLen / 7)) 'Worst case scenario
BeginGroup = 0
'whe start by setting the beginvalues
Call Init_Grouping
'lets check if we have done the whole file
Do While BeginGroup < TotFileLen
Group(8).LowValue = 0
Group(8).HighValue = 255
Group(8).NumInGroup = TotFileLen - BeginGroup + 1
'If where not ready yet whe assume the best method of compression is no compression
'That is indeed the best method cause nocompression needs 9 additional bits and compression uses 17
BestGroup = 8
'lets check if there is maybe a better way
NewBest = CheckForBetterWithin(ByteArray, Group, BestGroup, BeginGroup)
Do While BestGroup <> NewBest
'yes there is, lets check again to be shure
BestGroup = NewBest
NewBest = CheckForBetterWithin(ByteArray, Group, BestGroup, BeginGroup)
Loop
'whe have found the best method
If BestGroup = 8 Then
BitsDeep = 0 'No compression
Else
BitsDeep = BestGroup
End If
'here we will store the header in into the outputstream
Call AddGroupCodeToStream(OutStream, Group(BestGroup).NumInGroup, BitsDeep)
'If we have found compression then we must store also the lowest value of the group
'opslaan minimum waarde van de groep
If BestGroup <> 8 Then
Call AddBitsToStream(OutStream, CLng(Group(BestGroup).LowValue), 8)
End If
'here we will read the bytes from the inputstream, convert them, and store them
'into the output stream
For X = BeginGroup To BeginGroup + Group(BestGroup).NumInGroup - 1
Call AddBitsToStream(OutStream, CLng(ByteArray(X) - Group(BestGroup).LowValue), BestGroup)
Next
BeginGroup = BeginGroup + Group(BestGroup).NumInGroup
Loop
'if the grouping part is complete we have to store the EOF-marker = 0
'0 = no compression ,marker for less than 8 bytes, and 0 bytes to store
Call AddGroupCodeToStream(OutStream, 0, 0)
'maybe we have some bits leftover so lets store them
If OutBitCount < 8 Then
Do While OutBitCount < 8
OutByteBuf = OutByteBuf * 2
OutBitCount = OutBitCount + 1
Loop
OutStream(OutPos) = OutByteBuf: OutPos = OutPos + 1
End If
OutPos = OutPos - 1
ReDim ByteArray(OutPos)
'lets copy the outputstream into the inputstream so that we can return the compressed file
'to the caller
Call CopyMem(ByteArray(0), OutStream(0), OutPos + 1)
End Sub
'This part is used to select the extra bits used to store a value
Private Function GetExtraBitsNum(Number As Long)
Select Case Number
Case Is < 8
GetExtraBitsNum = 0
Case Is < 16
GetExtraBitsNum = 1
Case Is < 32
GetExtraBitsNum = 2
Case Is < 64
GetExtraBitsNum = 3
Case Is < 128
GetExtraBitsNum = 4
Case Is < 256
GetExtraBitsNum = 5
Case Is < 512
GetExtraBitsNum = 6
Case Else
GetExtraBitsNum = 7
End Select
End Function
Private Sub AddGroupCodeToStream(ToStream() As Byte, Number As Long, GroupNum As Integer)
Dim NumVal As Byte
Dim X As Long
'Store 3 bits to say what grouping method is used
Call AddBitsToStream(ToStream, CLng(GroupNum), 3)
NumVal = GetExtraBitsNum(Number)
'store 3 bits to with will tell the amount of bits to be read to get the groupsize
Call AddBitsToStream(ToStream, CLng(NumVal), 3)
'store 3 to 16 bits to put in the groepsize
Call AddBitsToStream(ToStream, Number, CInt(NumExtBits(NumVal)))
End Sub
'this sub will add an amount of bits into the outputstream
Private Sub AddBitsToStream(ToStream() 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: ToStream(OutPos) = OutByteBuf: OutBitCount = 0: OutByteBuf = 0: OutPos = OutPos + 1
Next
End Sub
'This is Smart part of the grouping method
'it will look for the way to get the best compression
Private Function CheckForBetterWithin(InArray() As Byte, Group() As Grouping, MaxGroup As Integer, StartPositie As Long)
Dim LowInGroup As Integer 'lowest value found
Dim HighInGroup As Integer 'highest value found
Dim GroupSize As Integer 'size of the group 1-7
Dim NumInGroup As Long 'total numbers in group
Dim RealBegin As Long
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
StartPos = StartPositie
RealBegin = StartPos
StartGroep = MaxGroup
CheckForBetterWithin = 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
CheckForBetterWithin = 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 = CheckForBetterWithin(InArray, Group, 8, RealBegin)
Do While BestGroep <> NewBestGroep
BestGroep = NewBestGroep
NewBestGroep = CheckForBetterWithin(InArray, Group, BestGroep, RealBegin)
Loop
CheckForBetterWithin = BestGroep
Exit Function
End If
Else
'if we didn't find compression then maybe there 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
BitsNoComp = 3 + 3 + NumExtBits(GetExtraBitsNum(Group(GroupSize).NumInGroup)) + (8 * Abs(MaxGroup < 8)) + (Group(GroupSize).NumInGroup * 8) - (Group(GroupSize).NumInGroup * (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 + 3 + NumExtBits(GetExtraBitsNum(Group(GroupSize).NumInGroup)) + (8 * Abs(GroupSize < 8)) + (Group(GroupSize).NumInGroup * 8) - (Group(GroupSize).NumInGroup * (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 Group(GroupSize).NumInGroup <= Group(MaxGroup).NumInGroup Then BitsComp = BitsComp + 3 + 3 + NumExtBits(GetExtraBitsNum(CheckLen - StartPos - Group(GroupSize).NumInGroup)) + (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 + 3 + NumExtBits(GetExtraBitsNum(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_SmartGrouping(ByteArray() As Byte)
Dim AddFileLen As Long
Dim OutStream() As Byte 'de output array
Dim InpPos As Long
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)
InpPos = 0
NewPos = 0
Call Init_Grouping
Do 'loop until done
'read 3 bits to get grouping method (0 = not grouped)
PackedOrNot = ReadBitsFromArray(ByteArray, InpPos, 3)
'read 3 bits to get the bits needed for the groupsize
NumVal = ReadBitsFromArray(ByteArray, InpPos, 3)
'read the amount of data needed for the group
NumBytes = ReadBitsFromArray(ByteArray, InpPos, CInt(NumExtBits(NumVal)))
'add an extra bit if needed (number 15 fits in 3 bits)
If NumVal > 0 And NumVal < 7 Then
NumBytes = NumBytes Or 2 ^ (NumVal + 2)
End If
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, InpPos, 8)
NewPos = NewPos + 1
Next
Else
'if grouped, read the lowest value in the group
LowInGroup = ReadBitsFromArray(ByteArray, InpPos, 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, InpPos, 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, 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