-
Notifications
You must be signed in to change notification settings - Fork 0
/
Comp_EliasDelta.bas
191 lines (178 loc) · 5.94 KB
/
Comp_EliasDelta.bas
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
Attribute VB_Name = "Comp_EliasDelta"
Option Explicit
'This is a 1 run method
'This compressor makes use of the Elias Delta codes
'How This codes are build up you can see in the init section
Private LeadingZero(9) As Integer
Private DeltaCode(9) As Integer
Private BitsToFollow(9) As Integer
Private ValToAdd(9) As Integer
Private OutPos As Long
Private OutByteBuf As Byte
Private OutBitCount As Integer
Private InpPos As Long
Private ReadBitPos As Integer
Public Sub Compress_Elias_Delta(ByteArray() As Byte)
Dim OutStream() As Byte
Dim X As Long
Call Init_Elias_Delta
ReDim OutStream(UBound(ByteArray))
For X = 0 To UBound(ByteArray)
Call AddEliasToArray(OutStream, CLng(ByteArray(X)))
Next
Call AddEliasToArray(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_Elias_Delta(ByteArray() As Byte)
Dim OutStream() As Byte
Dim Char As Integer
Dim X As Long
Call Init_Elias_Delta
ReDim OutStream(UBound(ByteArray))
Char = ReadEliasCode(ByteArray)
Do While Char <> 256
Call AddCharToArray(OutStream, Char)
Char = ReadEliasCode(ByteArray)
Loop
OutPos = OutPos - 1
ReDim ByteArray(OutPos)
Call CopyMem(ByteArray(0), OutStream(0), OutPos + 1)
End Sub
Private Sub Init_Elias_Delta()
OutPos = 0
OutByteBuf = 0
OutBitCount = 0
InpPos = 0
ReadBitPos = 0
LeadingZero(0) = 0: DeltaCode(0) = 1: BitsToFollow(0) = 0 '1 =1 -7
LeadingZero(1) = 1: DeltaCode(1) = 2: BitsToFollow(1) = 1 '010x =2-3 -4
LeadingZero(2) = 1: DeltaCode(2) = 3: BitsToFollow(2) = 2 '011xx =4-7 -3
LeadingZero(3) = 2: DeltaCode(3) = 4: BitsToFollow(3) = 3 '00100xxx =8-15 0
LeadingZero(4) = 2: DeltaCode(4) = 5: BitsToFollow(4) = 4 '00101xxxx =16-31 +1
LeadingZero(5) = 2: DeltaCode(5) = 6: BitsToFollow(5) = 5 '00110xxxxx =32-63 +2
LeadingZero(6) = 2: DeltaCode(6) = 7: BitsToFollow(6) = 6 '00111xxxxxx =64-127 +3
LeadingZero(7) = 3: DeltaCode(7) = 1: BitsToFollow(7) = 7 '0001xxxxxxx =128-255 +3
LeadingZero(8) = 4: DeltaCode(8) = 1: BitsToFollow(8) = 0 '00001 =256 -3
LeadingZero(9) = 4: DeltaCode(9) = 0: BitsToFollow(9) = 0 '00000 =257 +5 EOF
ValToAdd(0) = 1
ValToAdd(1) = 2
ValToAdd(2) = 4
ValToAdd(3) = 8
ValToAdd(4) = 16
ValToAdd(5) = 32
ValToAdd(6) = 64
ValToAdd(7) = 128
ValToAdd(8) = 0
ValToAdd(9) = 0
End Sub
Private Function Get_Elias_Code(Number As Long) As Integer
Select Case Number
Case 1
Get_Elias_Code = 0
Case Is < 4
Get_Elias_Code = 1
Case Is < 8
Get_Elias_Code = 2
Case Is < 16
Get_Elias_Code = 3
Case Is < 32
Get_Elias_Code = 4
Case Is < 64
Get_Elias_Code = 5
Case Is < 128
Get_Elias_Code = 6
Case Is < 256
Get_Elias_Code = 7
Case Is = 256
Get_Elias_Code = 8
Case Else
Get_Elias_Code = 9
End Select
End Function
Private Sub AddEliasToArray(Toarray() As Byte, Char As Long)
Dim Code As Integer
Dim X As Integer
Dim BitSize As Integer
Char = Char + 1
Code = Get_Elias_Code(Char)
Call AddBitsToArray(Toarray, 0, LeadingZero(Code))
Select Case DeltaCode(Code)
Case Is < 2
BitSize = 1
Case Is < 4
BitSize = 2
Case Is < 8
BitSize = 3
Case Else
BitSize = 1
End Select
Call AddBitsToArray(Toarray, CLng(DeltaCode(Code)), BitSize)
Call AddBitsToArray(Toarray, Char, BitsToFollow(Code))
End Sub
Private Function ReadEliasCode(FromArray() As Byte) As Integer
Dim X As Integer
Dim Temp As Integer
Dim DeltaCode As Integer
Dim bitcount As Integer
Do While ReadBitsFromArray(FromArray, InpPos, 1) = 0 And bitcount < 5
bitcount = bitcount + 1
Loop
If bitcount = 5 Then ReadEliasCode = 256: Exit Function
If bitcount = 4 Then ReadEliasCode = 255: Exit Function
If bitcount = 3 Then
DeltaCode = 7
Else
DeltaCode = 2 ^ bitcount + ReadBitsFromArray(FromArray, InpPos, bitcount) - 1
End If
Temp = ValToAdd(DeltaCode) + ReadBitsFromArray(FromArray, InpPos, BitsToFollow(DeltaCode))
ReadEliasCode = 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