modlzss.bas

WinBig. A file archive utility written in VB. Compression and decompression routines are LZSS. Full

Attribute VB_Name = "ModLZSS"
Option Explicit

'** Lempel Ziv compression algorithm
Private Const INDEX_BC = 12
Private Const LENGTH_BC = 4
Private Const BREAK_EVEN = 1

Private Const WINSIZE = 4096
Private Const LOOK_SIZE = 17
Private Const UNUSED = 0

Private Const TREE_ROOT = WINSIZE

Private Type tyTREE
    parent As Integer
    smaller_child As Integer
    larger_child As Integer
End Type
Private Tree() As tyTREE

Private Window() As Byte

Private mMask As Byte
Private mRack As Byte
Private mEof As Boolean

Private Infile() As Byte
Private Outfile() As Byte
Private InLen As Long
Private InCnt As Long
Private OutLen As Long
Private OutCnt As Long

Public Sub InitializeLZSS()
    ReDim Window(0 To WINSIZE) As Byte
End Sub

Public Function Compact(Bytes() As Byte) As Byte()
    On Error GoTo FuncError
    
    oError.Clear
    ReDim Tree(0 To WINSIZE) As tyTREE
    
    mRack = 0
    mMask = &H80
    mEof = False
    
    InCnt = 0
    OutCnt = 0
    InLen = UBound(Bytes)
    ReDim Outfile(0 To InLen)
    OutLen = UBound(Outfile)
    Infile = Bytes
    
    Call LZSScompress

    Erase Tree

FuncExit:
    ReDim Preserve Outfile(0 To OutCnt)
    Compact = Outfile
    
    Exit Function
FuncError:
    oError.Number = Err.Number
    oError.Description = Err.Description
    Exit Function
End Function

Public Function UnCompact(Bytes() As Byte) As Byte()
    On Error GoTo FuncError
    
    oError.Clear
    
    
    mRack = 0
    mMask = &H80
    mEof = False
    
    InCnt = 0
    OutCnt = 0
    InLen = UBound(Bytes)
    ReDim Outfile(0 To (InLen * 4))
    OutLen = UBound(Outfile)
    Infile = Bytes
    
    Call LZSSdecompress


    
FuncExit:
    ReDim Preserve Outfile(0 To OutCnt)
    UnCompact = Outfile
    
    Exit Function
FuncError:
    oError.Number = Err.Number
    oError.Description = Err.Description
    Exit Function
End Function

Private Sub putc(c As Byte)
    If OutCnt > OutLen Then
        ReDim Preserve Outfile(0 To (OutLen * 1.25))
        OutLen = UBound(Outfile)
    End If

    Outfile(OutCnt) = c
    OutCnt = OutCnt + 1
End Sub

Private Function getc() As Byte
    If InCnt <= InLen Then
        getc = Infile(InCnt)
        InCnt = InCnt + 1
    Else
        mEof = True
    End If
End Function

'** Kevin Doherty
'** 14 May 1996
'** Computational Methods
'** Lempel Ziv compression algorithm project

Private Sub LZSScompress()
    Dim c As Byte
    Dim i As Integer
    Dim look_ahead_bytes As Integer
    Dim current_position As Integer
    Dim replace_count As Integer
    Dim match_length As Integer
    Dim match_position As Integer
    
    current_position = 1
    For i = 0 To LOOK_SIZE - 1
        c = getc
        If mEof Then Exit For
        Window(current_position + i) = c
    Next i
    
    look_ahead_bytes = i
    Tree_Init (current_position)
    match_length = 0

    Do While look_ahead_bytes > 0
        If (match_length > look_ahead_bytes) Then
            match_length = look_ahead_bytes
        End If
        
        If (match_length <= BREAK_EVEN) Then
            OutputBit True
            OutputBits CInt(Window(current_position)), 8
            replace_count = 1
        Else
            OutputBit False
            OutputBits match_position, INDEX_BC
            OutputBits match_length - (BREAK_EVEN + 1), LENGTH_BC
            replace_count = match_length
        End If
        
        For i = 1 To replace_count
            Tree_Delete Mod_Window(current_position + LOOK_SIZE)
            c = getc
            If mEof Then
                look_ahead_bytes = look_ahead_bytes - 1
            Else
                Window(Mod_Window(current_position + LOOK_SIZE)) = c
            End If
            current_position = Mod_Window(current_position + 1)
            If look_ahead_bytes > 0 Then
                match_length = Tree_Add(current_position, match_position)
            End If
        Next i
    Loop

    OutputBit False
    OutputBits 0, INDEX_BC
End Sub

Private Sub LZSSdecompress()
    Dim c As Byte
    Dim i As Integer
    Dim current_position As Integer
    Dim match_length As Integer
    Dim match_position As Integer
    
    current_position = 1
    
    Do
        If InputBit() Then
            c = CByte(InputBits(8))
            putc c
            Window(current_position) = c
            current_position = Mod_Window(current_position + 1)
        Else
            match_position = InputBits(INDEX_BC)
            If match_position = 0 Then Exit Do
            match_length = InputBits(LENGTH_BC)
            match_length = match_length + BREAK_EVEN
            For i = 0 To match_length
                c = Window(Mod_Window(match_position + i))
                putc c
                Window(current_position) = c
                current_position = Mod_Window(current_position + 1)
            Next i
        End If
    Loop
End Sub

Private Function Mod_Window(A As Integer) As Integer
    Mod_Window = (A) And (WINSIZE - 1)
End Function

Private Sub Tree_Init(R As Integer)
    Tree(TREE_ROOT).larger_child = R
    Tree(R).parent = TREE_ROOT
    Tree(R).larger_child = UNUSED
    Tree(R).smaller_child = UNUSED
End Sub

Private Sub Tree_Delete(old_node As Integer)
    Dim replacement As Integer
    If Tree(old_node).parent = UNUSED Then
        Exit Sub
    End If
    If Tree(old_node).larger_child = UNUSED Then
        Tree_Contract old_node, Tree(old_node).smaller_child
    ElseIf Tree(old_node).smaller_child = UNUSED Then
        Tree_Contract old_node, Tree(old_node).larger_child
    Else
        replacement = Tree_Findnext(old_node)
        Tree_Delete replacement
        Tree_Replace old_node, replacement
    End If
End Sub

Private Function Tree_Add(ByVal new_node As Integer, ByRef match_position As Integer) As Integer
    Dim i As Integer
    Dim test_node As Integer
    Dim delta As Integer
    Dim match_length As Integer
    Dim child As Integer
    
    If new_node = 0 Then
        Tree_Add = 0
        Exit Function
    End If
    
    test_node = Tree(TREE_ROOT).larger_child
    match_length = 0

    Do
        For i = 0 To LOOK_SIZE - 1
            delta = Window(Mod_Window(new_node + i)) - CInt(Window(Mod_Window(test_node + i)))
            If delta <> 0 Then
                Exit For
            End If
        Next i
    
        If i >= match_length Then
            match_length = i
            match_position = test_node
            If match_length >= LOOK_SIZE Then
                Tree_Replace test_node, new_node
                Tree_Add = match_length
                Exit Function
            End If
        End If
    
        If delta >= 0 Then
            child = Tree(test_node).larger_child
        Else
            child = Tree(test_node).smaller_child
        End If
    
        If child = UNUSED Then
            If delta >= 0 Then
                Tree(test_node).larger_child = new_node
            Else
                Tree(test_node).smaller_child = new_node
            End If
            Tree(new_node).parent = test_node
            Tree(new_node).larger_child = UNUSED
            Tree(new_node).smaller_child = UNUSED
            Tree_Add = match_length
            Exit Function
        End If
    
        test_node = child
    Loop
End Function

Private Sub Tree_Contract(old_node As Integer, new_node As Integer)
    Tree(new_node).parent = Tree(old_node).parent
    If Tree(Tree(old_node).parent).larger_child = old_node Then
        Tree(Tree(old_node).parent).larger_child = new_node
    Else
        Tree(Tree(old_node).parent).smaller_child = new_node
    End If
    Tree(old_node).parent = UNUSED
End Sub

Private Sub Tree_Replace(old_node As Integer, new_node As Integer)
    Dim parent As Integer
    parent = Tree(old_node).parent
    If Tree(parent).smaller_child = old_node Then
        Tree(parent).smaller_child = new_node
    Else
        Tree(parent).larger_child = new_node
    End If
    Tree(new_node) = Tree(old_node)
    Tree(Tree(new_node).smaller_child).parent = new_node
    Tree(Tree(new_node).larger_child).parent = new_node
    Tree(old_node).parent = UNUSED
End Sub

Private Function Tree_Findnext(node As Integer) As Integer
    Dim lnext As Integer
    lnext = Tree(node).smaller_child
    Do While Tree(lnext).larger_child <> UNUSED
        lnext = Tree(lnext).larger_child
    Loop
    Tree_Findnext = lnext
End Function

Private Sub OutputBit(bit As Boolean)
    If bit Then
        mRack = mRack Or mMask
    End If
    mMask = mMask \ 2
    If mMask = 0 Then
        putc mRack
        mRack = 0
        mMask = &H80
    End If
End Sub

Private Sub OutputBits(code As Integer, count As Byte)
    Dim mask As Integer
    mask = 1 * (2 ^ (count - 1))
    Do While mask <> 0
        If CBool(mask And code) Then
            mRack = mRack Or mMask
        End If
        mMask = mMask \ 2
        If mMask = 0 Then
            putc mRack
            mRack = 0
            mMask = &H80
        End If
        mask = mask \ 2
    Loop
End Sub

Private Function InputBit() As Boolean
    Dim value As Integer
    If mMask = &H80 Then
        mRack = getc
        If mEof Then
            InputBit = False
            Exit Function
        End If
    End If
    value = mRack And mMask
    mMask = mMask \ 2
    If mMask = 0 Then
        mMask = &H80
    End If
    InputBit = CBool(value)
End Function

Private Function InputBits(bit_count As Integer) As Integer
    Dim mask As Integer
    Dim return_value As Integer
    mask = 1 * (2 ^ (bit_count - 1))
    return_value = 0
    Do While mask <> 0
        If mMask = &H80 Then
            mRack = getc
            If mEof Then
                InputBits = 0
                Exit Function
            End If
        End If
        If CBool(mRack And mMask) Then
            return_value = return_value Or mask
        End If
        mask = mask \ 2
        mMask = mMask \ 2
        If mMask = 0 Then
            mMask = &H80
        End If
    Loop
    InputBits = return_value
End Function