-
Notifications
You must be signed in to change notification settings - Fork 0
/
Comp_LZW_Static.bas
222 lines (211 loc) · 7.64 KB
/
Comp_LZW_Static.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
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
Attribute VB_Name = "Comp_LZW_Static"
Option Explicit
'This is a 1 run method but we have to keep the whole contents
'in memory until some variables are saved wich are needed bij the decompressor
Private MaxChars As Long
Private TempStream() As Byte
Private Dict() As String 'de dictionaries
Private Dictpos As Integer 'de positie waar de volgende karakters worden ingevoegd
Private SearchPos() As Long
Private SpeedSearch() As Long
Private ActDict As Integer 'actuele dictionary
Private maxCharLenght As Byte 'Maximum stringlengte in de dictionary
Private maxDictDeep As Long 'maximaal opgeslagen woorden per dictionary
Private TotBitDeep As Byte 'totale bitlengte per karakter of karaktervolgorde
Public Sub Compress_LZW_Static(FileArray() As Byte)
Dim ByteValue As Byte
Dim TempByte As Long
Dim ExtraBits As Integer
Dim DictStr As String
Dim NewStr As String
Dim ComPByte() As Byte
Dim CompPos As Long
Dim DictVal As Long
Dim DictPosit As Long
Dim DictPositOld As Long
Dim FilePos As Long
Dim FileLenght As Long
Dim Temp As Long
Dim MaxDictPagesInBites As Long
MaxDictPagesInBites = CLng(1024) * DictionarySize - 1
Call Init_Dict(MaxDictPagesInBites)
FileLenght = UBound(FileArray)
ReDim ComPByte(FileLenght + 10)
ComPByte(0) = maxCharLenght
ComPByte(1) = maxDictDeep - Int(maxDictDeep / 256) * 256
ComPByte(2) = Int((maxDictDeep - ComPByte(1)) / 256)
Temp = FileLenght
ComPByte(6) = Temp And 255: Temp = Int(Temp / 256)
ComPByte(5) = Temp And 255: Temp = Int(Temp / 256)
ComPByte(4) = Temp And 255: Temp = Int(Temp / 256)
ComPByte(3) = Temp And 255: Temp = Int(Temp / 256)
FilePos = 0
CompPos = 7
DictStr = ""
ExtraBits = 0
Do Until FilePos > FileLenght
ByteValue = FileArray(FilePos)
FilePos = FilePos + 1
NewStr = DictStr & Chr(ByteValue)
DictPosit = Search(NewStr)
If DictPosit <> maxDictDeep + 1 Then
DictStr = NewStr
DictPositOld = DictPosit
Else
ExtraBits = ExtraBits + TotBitDeep - 8
DictVal = (TempByte * (2 ^ TotBitDeep)) + DictPositOld
TempByte = DictVal And ((2 ^ ExtraBits) - 1)
DictVal = Int(DictVal / (2 ^ ExtraBits))
If CompPos > UBound(ComPByte) Then ReDim Preserve ComPByte(CompPos + 500)
ComPByte(CompPos) = DictVal
CompPos = CompPos + 1
If ExtraBits >= TotBitDeep Then
ExtraBits = ExtraBits - 8
DictVal = TempByte
TempByte = DictVal And ((2 ^ ExtraBits) - 1)
DictVal = Int(DictVal / (2 ^ ExtraBits))
If CompPos > UBound(ComPByte) Then ReDim Preserve ComPByte(CompPos + 500)
ComPByte(CompPos) = DictVal
CompPos = CompPos + 1
End If
Call AddToDict(NewStr, 1)
DictPositOld = ByteValue
DictStr = Chr(ByteValue)
End If
Loop
ExtraBits = ExtraBits + TotBitDeep - 8
DictVal = (TempByte * (2 ^ TotBitDeep)) + DictPositOld
TempByte = DictVal And ((2 ^ ExtraBits) - 1)
DictVal = Int(DictVal / (2 ^ ExtraBits))
If CompPos > UBound(ComPByte) Then ReDim Preserve ComPByte(CompPos + 500)
ComPByte(CompPos) = DictVal
CompPos = CompPos + 1
Do While ExtraBits > 0
ExtraBits = ExtraBits - 8
DictVal = TempByte
TempByte = DictVal And ((2 ^ ExtraBits) - 1)
DictVal = Int(DictVal / (2 ^ ExtraBits))
If CompPos > UBound(ComPByte) Then ReDim Preserve ComPByte(CompPos + 500)
ComPByte(CompPos) = DictVal
CompPos = CompPos + 1
Loop
ReDim FileArray(CompPos - 1)
Call CopyMem(FileArray(0), ComPByte(0), CompPos)
End Sub
Public Sub DeCompress_LZW_Static(FileArray() As Byte)
Dim ReadBits As Integer
Dim DictVal As Long
Dim TempByte As Long
Dim OldKarValue As Long
Dim DeComPByte() As Byte
Dim DeCompPos As Long
Dim FilePos As Long
Dim FileLenght As Long
maxCharLenght = FileArray(0)
maxDictDeep = FileArray(1) + 256 * FileArray(2)
FileLenght = FileArray(3) * 256 + FileArray(4)
FileLenght = FileLenght * 256 + FileArray(5)
FileLenght = FileLenght * 256 + FileArray(6)
Call Init_Dict(maxDictDeep)
ReDim DeComPByte(FileLenght)
ReadBits = 0
TempByte = 0
DeCompPos = -1
FilePos = 7
DictVal = -1
Do Until DeCompPos >= FileLenght
OldKarValue = DictVal
DictVal = TempByte
Do While ReadBits < TotBitDeep And FilePos <= UBound(FileArray)
ReadBits = ReadBits + 8
DictVal = DictVal * 256 + FileArray(FilePos)
FilePos = FilePos + 1
Loop
If ReadBits < TotBitDeep Then DictVal = DictVal * (2 ^ (TotBitDeep - ReadBits)): ReadBits = TotBitDeep
ReadBits = ReadBits - TotBitDeep
TempByte = (DictVal And ((2 ^ ReadBits) - 1))
If ReadBits > 0 Then DictVal = Int(DictVal / 2 ^ ReadBits)
If Dict(DictVal) <> "" Then
Call AddASC2Array(DeComPByte, DeCompPos, Dict(DictVal))
If OldKarValue <> -1 Then Call AddToDict(Dict(OldKarValue) & Left(Dict(DictVal), 1), 0)
Else
Call AddToDict(Dict(OldKarValue) & Left(Dict(OldKarValue), 1), 0)
Call AddASC2Array(DeComPByte, DeCompPos, Dict(DictVal))
End If
Loop
ReDim FileArray(DeCompPos)
Call CopyMem(FileArray(0), DeComPByte(0), DeCompPos + 1)
End Sub
Private Sub Init_Dict(Optional MaxDictPagesInBites As Long = 512, Optional StoreTilCharLenght As Byte = 50)
Dim X As Integer
If MaxDictPagesInBites > 65535 Then
MaxDictPagesInBites = 65535
ElseIf MaxDictPagesInBites < 255 Then
MaxDictPagesInBites = 255
End If
MaxDictPagesInBites = MaxDictPagesInBites - 1
For X = 0 To 16
If MaxDictPagesInBites < 2 ^ X Then
TotBitDeep = X
Exit For
End If
Next
maxCharLenght = StoreTilCharLenght
maxDictDeep = MaxDictPagesInBites
Call Clean_Dictionary
End Sub
Private Sub Clean_Dictionary()
Dim X As Long
Dim Y As Long
ReDim Dict(maxDictDeep)
ReDim SearchPos(maxDictDeep - 255, maxCharLenght)
ReDim SpeedSearch(maxDictDeep - 255)
For X = 0 To 255
Dict(X) = Chr(X)
Next
For X = 256 To maxDictDeep
If Dict(X) = "" Then Exit For Else Dict(X) = ""
Next
For X = 0 To maxDictDeep - 255
SpeedSearch(X) = 0
For Y = 0 To maxCharLenght
If SearchPos(X, Y) = 0 Then Exit For Else SearchPos(X, Y) = 0
Next
Next
Dictpos = 256
End Sub
Private Function Search(Char As String) As Long
Dim X As Long
Dim Step As Long
If Len(Char) = 1 Then
Search = ASC(Char)
Exit Function
ElseIf Len(Char) < maxCharLenght Then
Step = 0
X = SearchPos(Step, Len(Char))
Do While X <> 0
If Dict(X) = Char Then
Search = X
Exit Function
End If
Step = Step + 1
X = SearchPos(Step, Len(Char))
Loop
End If
Search = maxDictDeep + 1
End Function
Private Sub AddToDict(Char As String, Comp1Decomp0 As Byte)
If Len(Char) = 1 Or Len(Char) - 2 > maxCharLenght Then Exit Sub
If Dictpos + Comp1Decomp0 >= maxDictDeep Then Call Clean_Dictionary
Dict(Dictpos) = Char
SearchPos(SpeedSearch(Len(Char)), Len(Char)) = Dictpos
SpeedSearch(Len(Char)) = SpeedSearch(Len(Char)) + 1
Dictpos = Dictpos + 1
End Sub
Private Sub AddASC2Array(WichArray() As Byte, StartPos As Long, Text As String)
Dim X As Long
For X = 1 To Len(Text)
WichArray(StartPos + X) = ASC(Mid(Text, X, 1))
Next
StartPos = StartPos + Len(Text)
End Sub