Skip to content

Instantly share code, notes, and snippets.

@7shi
Created Apr 13, 2012
Embed
What would you like to do?
VBA版Deflate
' public domain
Option Explicit
Private FOut%
Private buf() As Byte
Private bufp&, cur&, bit%
Public Sub BitWriter_Init(FO%)
ReDim buf(4095)
FOut = FO
bufp = 0
cur = 0
bit = 0
End Sub
Public Sub BitWriter_WriteByte(ByVal B As Byte)
buf(bufp) = B
If bufp < 4095 Then
bufp = bufp + 1
Else
Put #FOut, , buf
bufp = 0
End If
End Sub
Public Sub BitWriter_Close()
If bit > 0 Then
BitWriter_WriteByte cur
cur = 0
bit = 0
End If
If bufp > 0 Then
ReDim Preserve buf(bufp - 1)
Put #FOut, , buf
ReDim buf(4095)
bufp = 0
End If
End Sub
Public Sub BitWriter_WriteBit(B As Boolean)
If B Then cur = cur Or sl(1, bit, 0)
If bit < 7 Then
bit = bit + 1
Else
BitWriter_WriteByte cur
cur = 0
bit = 0
End If
End Sub
Public Sub BitWriter_WriteBits(Length%, ByVal B%)
Dim v As Byte, pos%
If Length > 0 Then
v = cur Or sl(B, bit, 0)
pos = bit + Length
If pos < 8 Then
cur = v
bit = pos
Else
BitWriter_WriteByte v
If pos < 16 Then
cur = sl(B, bit, 1)
bit = pos - 8
Else
BitWriter_WriteByte sl(B, bit, 1)
cur = sl(B, bit, 2)
bit = pos - 16
End If
End If
End If
End Sub
Public Sub BitWriter_WriteFixedHuffman(ByVal B%)
If B < 144 Then
BitWriter_WriteBits 8, rev(B + 48)
ElseIf B < 256 Then
BitWriter_WriteBit True
BitWriter_WriteBits 8, rev(B)
ElseIf B < 280 Then
BitWriter_WriteBits 7, rev(B + B - 512)
ElseIf B < 288 Then
BitWriter_WriteBits 8, rev(B - 88)
End If
End Sub
Public Sub BitWriter_WriteLen(Length&)
Dim ll&
ll = litindex(Length - 3)
BitWriter_WriteFixedHuffman ll
BitWriter_WriteBits litexlens(ll), Length - litlens(ll)
End Sub
Public Sub BitWriter_WriteDist(d&)
Dim dl&
dl = distindex(d - 1)
BitWriter_WriteBits 5, rev(dl * 8)
BitWriter_WriteBits distexlens(dl), d - distlens(dl)
End Sub
' public domain
Option Explicit
Public Const maxlen& = 258, maxdist& = 32768
Public litexlens%(285), litlens&(285), litindex&(maxlen - 3)
Public distexlens%(29), distlens&(29), distindex&(maxdist - 1)
Public sl(8191, 7, 2) As Byte, rev(255) As Byte
Public hashseed%(255, 255)
Public Sub Deflate_Init()
Dim I&, J&, v&, P2&
Dim P2R As Byte, B As Byte
For I = 0 To 255
For J = 0 To 255
hashseed(I, J) = (I * 16) Xor (J * 4)
Next J
Next I
For I = 265 To 284
litexlens(I) = (I - 261) \ 4
Next I
v = 3
For I = 257 To 284
litlens(I) = v
P2 = 1
For J = 1 To litexlens(I)
P2 = P2 + P2
Next J
For J = 1 To P2
litindex(v - 3) = I
v = v + 1
Next J
Next I
litlens(285) = maxlen
litindex(maxlen - 3) = 285
For I = 4 To 29
distexlens(I) = (I - 2) \ 2
Next I
v = 1
For I = 0 To 29
distlens(I) = v
P2 = 1
For J = 1 To distexlens(I)
P2 = P2 + P2
Next
For J = 1 To P2
distindex(v - 1) = I
v = v + 1
Next J
Next I
For I = 0 To 8191
P2 = 1
For J = 0 To 7
v = I * P2
sl(I, J, 0) = v And 255
sl(I, J, 1) = (v \ 256) And 255
sl(I, J, 2) = v \ 65536
P2 = P2 + P2
Next J
Next I
For I = 0 To 255
P2 = 1
P2R = 128
B = 0
For J = 0 To 7
If I And P2 Then B = B + P2R
P2 = P2 + P2
P2R = P2R \ 2
Next J
rev(I) = B
Next I
End Sub
Public Sub Deflate_WriteBytes(FIn%, FOut%)
If rev(255) = 0 Then Deflate_Init
DeflateWriter_Compress FIn, FOut
End Sub
Public Sub Deflate_WriteFile(PIn$, POut$)
Dim FIn%, FOut%
FIn = FreeFile
Open PIn For Binary Lock Read As #FIn
On Error Resume Next
Kill POut
On Error GoTo 0
FOut = FreeFile
Open POut For Binary Lock Write As #FOut
Deflate_WriteBytes FIn, FOut
Close #FOut
Close #FIn
End Sub
Public Sub Deflate_Test(PIn$, POut$)
Dim T1#, T2#
T1 = Evaluate("=NOW()")
Deflate_WriteFile PIn, POut
T2 = Evaluate("=NOW()")
Debug.Print (T2 - T1) * 24 * 60 * 60
End Sub
' public domain
Option Explicit
Declare Sub RtlMoveMemory Lib "kernel32" (Destination As Any, Source As Any, ByVal Length&)
Private Const maxbuf& = maxdist * 2
Private Const buflen& = maxbuf + maxlen
Private Length&, bufstart&, filelen&
Private buf(buflen - 1) As Byte
Private tables&(4095, 15), current&(4095)
Private Sub Read(FIn%, pos&, readlen&)
Dim rbuf() As Byte, rlen&
rlen = filelen
If rlen > readlen Then rlen = readlen
ReDim rbuf(rlen - 1)
Get #FIn, , rbuf
RtlMoveMemory buf(pos), rbuf(0), rlen
filelen = filelen - rlen
If rlen < readlen Then Length = pos + rlen
End Sub
Private Sub AddHash(pos&)
Dim h%, C&, b1 As Byte, b2 As Byte
b1 = buf(pos)
b2 = buf(pos + 1)
If b1 <> b2 Then
h = hashseed(b1, b2) Xor buf(pos + 2)
C = current(h)
tables(h, C And 15) = bufstart + pos
current(h) = C + 1
End If
End Sub
Private Sub Search(pos&, ByRef rp&, ByRef rl&)
Dim maxp&, maxl&, mlen&, last&, h%, C&, P1&, I&, P&, l&
maxp = -1
maxl = 2
mlen = Length - pos
If mlen > maxlen Then mlen = maxlen
last = pos - maxdist
If last < 0 Then last = 0
h = hashseed(buf(pos), buf(pos + 1)) Xor buf(pos + 2)
C = current(h)
P1 = IIf(C < 16, 0, C - 16)
For I = C - 1 To P1 Step -1
P = tables(h, I And 15) - bufstart
If P < last Then
Exit For
Else
l = 0
While l < mlen And buf(P + l) = buf(pos + l)
l = l + 1
Wend
If l > maxl Then
maxp = P
maxl = l
End If
End If
Next
rp = maxp
rl = maxl
End Sub
Public Sub DeflateWriter_Compress(FIn%, FOut%)
Length = buflen
bufstart = 0
filelen = LOF(FIn)
Dim I&
For I = 0 To 4095
current(I) = 0
Next I
Read FIn, 0, buflen
Dim B As Byte
BitWriter_Init FOut
Dim P&, l&, mlen&, maxp&, maxl&
BitWriter_WriteBit True
BitWriter_WriteBits 2, 1
While P < Length
B = buf(P)
If P < Length - 4 And B = buf(P + 1) And B = buf(P + 2) And B = buf(P + 3) Then
l = 4
mlen = Length - P
If mlen > maxlen + 1 Then mlen = maxlen + 1
While l < mlen And B = buf(P + l)
l = l + 1
Wend
BitWriter_WriteFixedHuffman B
BitWriter_WriteLen l - 1
BitWriter_WriteDist 1
P = P + l
Else
Search P, maxp, maxl
If maxp < 0 Then
BitWriter_WriteFixedHuffman B
AddHash P
P = P + 1
Else
BitWriter_WriteLen maxl
BitWriter_WriteDist P - maxp
For I = P To P + maxl - 1
AddHash I
Next
P = P + maxl
End If
End If
If P > maxbuf Then
RtlMoveMemory buf(0), buf(maxdist), maxdist + maxlen
If Length < buflen Then
Length = Length - maxdist
Else
Read FIn, maxdist + maxlen, maxdist
End If
P = P - maxdist
bufstart = bufstart + maxdist
End If
Wend
BitWriter_WriteFixedHuffman 256
BitWriter_Close
End Sub
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment