Namespace Compression

#Region " NAMESPACE : Huffman "
    Namespace Huffman
#Region " CLASS : Compressor "
        Public Class Compressor
            Private Overloads Function Equals(ByVal objA As Object, ByVal objB As Object) As Boolean
            End Function
            Private Overloads Function ReferenceEquals(ByVal objA As Object, ByVal objB As Object) As Boolean
            End Function

            Public ReadOnly Property Value() As Long
                Get
                    Dim lngValue As Long
                    If Not (Me.fsInput Is Nothing) Then
                        Try
                            lngValue = Me.fsInput.Position
                        Catch ex As Exception
                        End Try
                    End If
                    Return lngValue
                End Get
            End Property
            Public ReadOnly Property Length() As Long
                Get
                    Static lngLength As Long = -1
                    If lngLength = -1 Then
                        Dim fileInfo As New IO.FileInfo(Me.Input)
                        lngLength = fileInfo.Length
                    End If
                    Return lngLength
                End Get
            End Property

            Private Input As String
            Private Output As String
            Private fsInput As IO.FileStream
            Private fsOutput As IO.FileStream
            Private bsInput As IO.BufferedStream
            Private bsOutput As IO.BufferedStream
            Private TreeNodes() As Internal.HuffmanTreeNode
            Public Sub New(ByVal Input As String, ByVal Output As String)
                Me.Input = Input
                Me.Output = Output
            End Sub
            Public Sub Compress()
                'get the tree
                Me.TreeNodes = Huffman.Internal.GetHuffmanTreeNodes(Me.Input)
                Huffman.Internal.GetHuffmanTree(Me.TreeNodes)

                'open input and output files.
                Me.fsInput = New IO.FileStream(Me.Input, IO.FileMode.Open)
                Me.fsOutput = New IO.FileStream(Me.Output, IO.FileMode.Create)
                Me.bsInput = New IO.BufferedStream(Me.fsInput, Huffman.Internal.BufferSize)
                Me.bsOutput = New IO.BufferedStream(Me.fsOutput, Huffman.Internal.BufferSize)

                'write the XML
                Dim strXML As String = Huffman.Internal.NodesToString(Me.TreeNodes)
                Dim bytXML() As Byte = System.Text.Encoding.Default.GetBytes(strXML)
                'write the length of the xml, in a ten byte long.
                Dim xmlLength As String = bytXML.Length.ToString
                Do Until xmlLength.Length = 10 : xmlLength = " " & xmlLength : Loop
                Dim bytXmlLength() As Byte = System.Text.Encoding.Default.GetBytes(xmlLength)
                Me.bsOutput.Write(bytXmlLength, 0, bytXmlLength.Length)
                'increment 10 bytes so the leftover bits can be written here.
                Me.bsOutput.Position += 10
                'write the xml bytes.
                Me.bsOutput.Write(bytXML, 0, bytXML.Length)
                'wrote the xml.

                'write the compressed data.
                Dim binaryDecimalConverter As New Internal.BinaryDecimalConverter
                Dim strBinary As String
                Dim readByte As Integer
                Do Until readByte = -1
                    readByte = Me.bsInput.ReadByte
                    If Not readByte = -1 Then
                        Dim strPath As String = Me.TreeNodes(readByte).Path
                        strBinary = strBinary & strPath
                    End If
                    If strBinary.Length > 8 Then
                        Dim byteOut As Byte = CByte(binaryDecimalConverter.GetDecimal(strBinary.Substring(0, 8)))
                        Me.bsOutput.WriteByte(byteOut)
                        strBinary = strBinary.Remove(0, 8)
                    End If
                Loop
                'finished writing compressed data.

                'write the leftover bits, starting at byte 10 of the file.
                If Not strBinary = "" Then
                    Do Until strBinary.Length = 10 : strBinary = " " & strBinary : Loop
                    Dim bytLeftovers() As Byte = System.Text.Encoding.Default.GetBytes(strBinary)
                    Me.bsOutput.Position = 10
                    Me.bsOutput.Write(bytLeftovers, 0, bytLeftovers.Length)
                End If
                'finished writing leftover bits.

                Me.bsInput.Close()
                Me.bsOutput.Close()

                Me.fsInput.Close()
                Me.fsOutput.Close()
            End Sub
        End Class
#End Region
#Region " CLASS : Decompressor "
        Public Class Decompressor
            Private Overloads Function Equals(ByVal objA As Object, ByVal objB As Object) As Boolean
            End Function
            Private Overloads Function ReferenceEquals(ByVal objA As Object, ByVal objB As Object) As Boolean
            End Function

            Public ReadOnly Property Value() As Long
                Get
                    Dim lngValue As Long
                    If Not (Me.fsInput Is Nothing) Then
                        Try
                            lngValue = Me.fsInput.Position
                        Catch ex As Exception
                        End Try
                    End If
                    Return lngValue
                End Get
            End Property
            Public ReadOnly Property Length() As Long
                Get
                    Static lngLength As Long = -1
                    If lngLength = -1 Then
                        Dim fileInfo As New IO.FileInfo(Me.Input)
                        lngLength = fileInfo.Length
                    End If
                    Return lngLength
                End Get
            End Property

            Private Input As String
            Private Output As String
            Private fsInput As IO.FileStream
            Private fsOutput As IO.FileStream
            Private bsInput As IO.BufferedStream
            Private bsOutput As IO.BufferedStream
            Private Tree As Internal.HuffmanTreeNode
            Private currentNode As Internal.HuffmanTreeNode
            Public Sub New(ByVal Input As String, ByVal Output As String)
                Me.Input = Input
                Me.Output = Output
            End Sub
            Public Sub Decompress()
                Me.fsInput = New IO.FileStream(Me.Input, IO.FileMode.Open)
                Me.fsOutput = New IO.FileStream(Me.Output, IO.FileMode.Create)
                Me.bsInput = New IO.BufferedStream(Me.fsInput, Huffman.Internal.BufferSize)
                Me.bsOutput = New IO.BufferedStream(Me.fsOutput, Huffman.Internal.BufferSize)

                'get the xml length.
                Dim bytTreeNodesAsStringLength(9) As Byte
                Me.bsInput.Read(bytTreeNodesAsStringLength, 0, bytTreeNodesAsStringLength.Length)
                Dim treeNodesAsStringLength As Integer = Integer.Parse(System.Text.Encoding.Default.GetString(bytTreeNodesAsStringLength).Replace(" ", "")

                'get the leftover bits.
                Dim bytLeftOvers(9) As Byte
                Me.bsInput.Read(bytLeftOvers, 0, bytLeftOvers.Length)
                Dim strLeftovers As String = System.Text.Encoding.Default.GetString(bytLeftOvers).Replace(" ", ""

                'get the tree
                Dim bytXml(treeNodesAsStringLength - 1) As Byte
                Me.bsInput.Read(bytXml, 0, treeNodesAsStringLength)
                Dim strXML As String = System.Text.Encoding.Default.GetString(bytXml)
                Dim TreeNodes() As Internal.HuffmanTreeNode = Huffman.Internal.StringToNodes(strXML)
                Me.Tree = Huffman.Internal.GetHuffmanTree(TreeNodes)
                Me.currentNode = Me.Tree
                'got the tree

                'decompress the file.
                Dim binaryDecimalConverter As New Internal.BinaryDecimalConverter
                Dim readByte As Integer
                Do Until (readByte = -1)
                    readByte = Me.bsInput.ReadByte
                    If Not readByte = -1 Then
                        Dim strBinary As String = binaryDecimalConverter.GetBinary(readByte)
                        Me.DecryptBits(strBinary)
                    End If
                Loop
                'decrypt the leftovers too.
                Me.DecryptBits(strLeftovers)

                Me.bsInput.Close()
                Me.bsOutput.Close()

                Me.fsInput.Close()
                Me.fsOutput.Close()
            End Sub
            Private Sub DecryptBits(ByVal Bits As String)
                Dim x As Integer
                For x = 0 To (Bits.Length - 1)

                    Select Case Bits.Chars(x).ToString
                        Case "0"
                            Me.currentNode = Me.currentNode.Left
                        Case "1"
                            Me.currentNode = Me.currentNode.Right
                    End Select

                    If Not (Me.currentNode.Character = -1) Then
                        Me.bsOutput.WriteByte(CByte(Me.currentNode.Character)) 'write a byte.
                        Me.currentNode = Me.Tree 'go back to the beginning of the tree.
                    End If
                Next x
            End Sub
        End Class
#End Region
#Region " CLASS : Internal "
        Friend Class Internal
            Public Const BufferSize As Integer = (1024) * 4
#Region " FUNCTION : GetHuffmanTreeNodes "
            Public Shared Function GetHuffmanTreeNodes(ByVal File As String) As HuffmanTreeNode()
                Dim HuffmanTreeNodes(255) As HuffmanTreeNode
                Dim x As Integer
                For x = 0 To 255
                    HuffmanTreeNodes(x) = New HuffmanTreeNode
                    HuffmanTreeNodes(x).Character = x
                Next x

                Dim fileStream As New IO.FileStream(File, IO.FileMode.Open)
                Dim readByte As Integer
                Do Until readByte = -1
                    readByte = fileStream.ReadByte
                    If Not readByte = -1 Then
                        HuffmanTreeNodes(readByte).Weight += 1
                    End If
                Loop
                fileStream.Close()
                Return HuffmanTreeNodes
            End Function
#End Region
#Region " FUNCTION : GetHuffmanTree "
            Public Shared Function GetHuffmanTree(ByVal TreeNodes() As HuffmanTreeNode) As HuffmanTreeNode
                'get the last two elements.
                'combine them into a node. (which is not a leaf)
                'kill them from nodelist.
                'add(New node, weight = 1 + 2)
                'sort the list again and join the last 2 elements (do this until only 1 element exists)

                'this makes it so that changes to each treenode are reflected in TreeNodes,
                'but changes to the array order stay the same.
                Dim tempTreeNodes() As HuffmanTreeNode = CType(TreeNodes.Clone, HuffmanTreeNode())
                Do Until tempTreeNodes.Length = 1
                    Array.Sort(tempTreeNodes, New HuffmanTreeNodeComparer)
                    Dim node1 As HuffmanTreeNode = tempTreeNodes(tempTreeNodes.Length - 1)
                    Dim node2 As HuffmanTreeNode = tempTreeNodes(tempTreeNodes.Length - 2)

                    Dim newNode As New HuffmanTreeNode
                    newNode.Character = -1
                    newNode.Weight = node1.Weight + node2.Weight
                    newNode.Left = node1
                    newNode.Right = node2

                    node1.Parent = newNode
                    node2.Parent = newNode

                    ReDim Preserve tempTreeNodes(tempTreeNodes.Length - 3)
                    ReDim Preserve tempTreeNodes(tempTreeNodes.Length)
                    tempTreeNodes(tempTreeNodes.Length - 1) = newNode
                Loop
                Return tempTreeNodes(0)
            End Function
#End Region
#Region " FUNCTION : NodesToString/StringToNodes "
            Public Shared Function NodesToString(ByVal TreeNodes() As HuffmanTreeNode) As String
                Dim characters(255) As String
                Dim weights(255) As String

                Dim x As Integer
                For x = 0 To 255
                    characters(x) = CStr(TreeNodes(x).Character)
                    weights(x) = CStr(TreeNodes(x).Weight)
                Next x
                Return String.Join("#", characters) & "%" & String.Join("#", weights)
            End Function
            Public Shared Function StringToNodes(ByVal Xml As String) As HuffmanTreeNode()
                Dim characters() As String = Xml.Split("%".ToCharArray)(0).Split("#".ToCharArray)
                Dim weights() As String = Xml.Split("%".ToCharArray)(1).Split("#".ToCharArray)
                Dim TreeNodes(255) As HuffmanTreeNode

                Dim x As Integer
                For x = 0 To 255
                    TreeNodes(x) = New HuffmanTreeNode
                    TreeNodes(x).Character = CInt(characters(x))
                    TreeNodes(x).Weight = CLng(weights(x))
                Next x
                Return TreeNodes
            End Function
#End Region

#Region " CLASS : HuffmanTreeNode "
            Public Class HuffmanTreeNode
                Public Sub New()
                End Sub
                Private Shadows Function Equals() As Boolean
                    Return False
                End Function
                Private Shadows Function ReferenceEquals() As Boolean
                    Return False
                End Function

                Public Character As Integer = -1 'the character found in the file.
                Public Weight As Long = 0 'amount of times the character was found in the file.
                <System.Xml.Serialization.XmlIgnore()> Public Parent As HuffmanTreeNode 'the parent node.
                <System.Xml.Serialization.XmlIgnore()> Public Left As HuffmanTreeNode 'the left leaf.
                <System.Xml.Serialization.XmlIgnore()> Public Right As HuffmanTreeNode 'the right leaf.
                <System.Xml.Serialization.XmlIgnore()> Public ReadOnly Property Path() As String  'the binary path to the node.
                    Get
                        Static strPath As String
                        If strPath Is Nothing Then
                            If Not (Me.Parent Is Nothing) Then
                                If (Me.Parent.Left Is Me) Then strPath = "0"
                                If (Me.Parent.Right Is Me) Then strPath = "1"
                                strPath = Parent.Path & strPath
                            End If
                        End If
                        Return strPath
                    End Get
                End Property
            End Class
#End Region
#Region " CLASS : HuffmanTreeNodeComparer "
            Public Class HuffmanTreeNodeComparer
                Implements IComparer
                Public Sub New()
                End Sub
                Public Function Compare(ByVal x As Object, ByVal y As Object) As Integer Implements System.Collections.IComparer.Compare
                    Dim returnVal As Integer = -1
                    Dim a As Double = CType(x, HuffmanTreeNode).Weight
                    Dim b As Double = CType(y, HuffmanTreeNode).Weight
                    If a > b Then
                        returnVal = 1
                    ElseIf a < b Then
                        returnVal = -1
                    ElseIf a = b Then
                        returnVal = 0
                    End If
                    returnVal *= -1 'descending sort order... (biggest to smallest)
                    Return returnVal
                End Function
            End Class
#End Region
#Region " CLASS : BinaryDecimalConverter "
            Public Class BinaryDecimalConverter
                Private hashGetDecimal As Hashtable
                Private hashGetBinary As Hashtable
                Public Function GetDecimal(ByVal strBinary As String) As Integer
                    If Me.hashGetDecimal Is Nothing Then
                        Me.hashGetDecimal = New Hashtable
                        Dim x As Integer
                        For x = 0 To 255
                            Me.hashGetDecimal(Me.GetBinaryInternal(x)) = x
                        Next x
                    End If
                    Return CInt(Me.hashGetDecimal(strBinary))
                End Function
                Public Function GetBinary(ByVal intDecimal As Integer) As String
                    If Me.hashGetBinary Is Nothing Then
                        Me.hashGetBinary = New Hashtable
                        Dim x As Integer
                        For x = 0 To 255
                            Me.hashGetBinary(x) = Me.GetBinaryInternal(x)
                        Next x
                    End If
                    Return CStr(Me.hashGetBinary(intDecimal))
                End Function
                Private Function GetBinaryInternal(ByVal intDecimal As Integer) As String
                    Dim Y As Integer
                    Dim strBinary As String

                    While (intDecimal \ 2) > 0
                        Y = intDecimal \ 2
                        If intDecimal > 1 Then
                            strBinary = Val(CStr(intDecimal - (Y * 2))) & strBinary
                        End If
                        intDecimal = Y
                    End While
                    strBinary = intDecimal & strBinary
                    Do Until strBinary.Length = 8
                        strBinary = "0" & strBinary
                    Loop
                    Return strBinary
                End Function
                Private Function GetDecimalInternal(ByVal strBinary As String) As Integer
                    Dim sngNumber As Integer
                    Dim x As Integer
                    Dim Tmp As Integer
                    Dim Output As Integer
                    sngNumber = CInt(strBinary)

                    For x = 0 To Len(CStr(sngNumber)) - 1
                        Tmp = CInt(Right(CStr(sngNumber), 1))
                        If Tmp = 1 Then
                            Tmp = CInt(Tmp * Math.Pow(2, x))
                        End If
                        Output = Output + Tmp
                        Tmp = 1

                        If Len(CStr(sngNumber)) > 1 Then
                            sngNumber = CInt(Left(CStr(sngNumber), Len(CStr(sngNumber)) - 1))
                        Else
                            sngNumber = 0
                        End If
                    Next
                    Return Output
                End Function
                Private Function GetPowerInternal(ByRef Value As Integer, ByRef Power As Integer) As Integer
                    Dim result As Integer
                    If Power > 1 Then
                        Dim x As Integer
                        For x = 2 To Power
                            Value = Value * 2
                        Next
                        result = Value
                    Else
                        If Power = 0 Then result = 1
                        If Power = 1 Then result = Value
                    End If
                    Return result
                End Function
            End Class
#End Region
        End Class
#End Region
    End Namespace
#End Region 'works ok. not the best compression ratio though.

#Region " NAMESPACE : AdaptiveHuffman "
    'Namespace AdaptiveHuffman

    'End Namespace
#End Region 'not yet implemented.

#Region " NAMESPACE : RLE "
    '    Namespace RLE
    '#Region " CLASS : Compressor "
    '        Public Class Compressor
    '            Private Overloads Function Equals(ByVal objA As Object, ByVal objB As Object) As Boolean
    '            End Function
    '            Private Overloads Function ReferenceEquals(ByVal objA As Object, ByVal objB As Object) As Boolean
    '            End Function

    '            Public ReadOnly Property Value() As Long
    '                Get
    '                    im lngValue As Long
    '                    If Not (Me.fsInput Is Nothing) Then
    '                        Try
    '                            lngValue = Me.fsInput.Position
    '                        Catch ex As Exception
    '                        End Try
    '                    End If
    '                    Return lngValue
    '                End Get
    '            End Property
    '            Public ReadOnly Property Length() As Long
    '                Get
    '                    Static lngLength As Long = -1
    '                    If lngLength = -1 Then
    '                        im fileInfo As New IO.FileInfo(Me.Input)
    '                        lngLength = fileInfo.Length
    '                    End If
    '                    Return lngLength
    '                End Get
    '            End Property

    '            Public Input As String
    '            Public Output As String
    '            Private fsInput As IO.FileStream
    '            Private fsOutput As IO.FileStream
    '            Public Sub New(ByVal Input As String, ByVal Output As String)
    '                Me.Input = Input
    '                Me.Output = Output
    '            End Sub

    '            Public Sub Compress()
    '                Me.fsInput = New IO.FileStream(Me.Input, IO.FileMode.Open)
    '                Me.fsOutput = New IO.FileStream(Me.Output, IO.FileMode.Create)

    '                'read byte from file.

    '                'if byte is last read byte then
    '                '   add count to last rleRepetition. (if its the right one,else create it)
    '                'Else
    '                '   record the location at which the new byte was detected.
    '                '   write byte to output
    '                'End If
    '                im rleRepetitions() As RLErepetition

    '                im lastReadByte As Integer = -2
    '                im readByte As Integer
    '                im differentCharacterPosition As Long
    '                im repetitiveCharacterCount As Integer
    '                o Until readByte = -1
    '                    readByte = Me.fsInput.ReadByte
    '                    If (readByte = -1) Then Exit Do

    '                    If (readByte = lastReadByte) Then
    '                        'add count to last rleRepetition
    '                        'byte is the same, add count.
    '                        repetitiveCharacterCount += 1
    '                    Else
    '                        'byte is different. add last repetition to rleRepetitions(), if count is bigger than 0.
    '                        If Not repetitiveCharacterCount = 0 Then
    '                            im bytes() As Byte = System.Text.Encoding.Default.GetBytes("*" & repetitiveCharacterCount.ToString & "*"
    '                            Me.fsOutput.Write(bytes, 0, bytes.Length)
    '                        End If

    '                        differentCharacterPosition = Me.fsInput.Position
    '                        repetitiveCharacterCount = 0

    '                        Me.fsOutput.WriteByte(CByte(readByte))
    '                    End If
    '                    lastReadByte = readByte
    '                Loop
    '                Me.fsInput.Close()
    '                Me.fsOutput.Close()
    '            End Sub
    '        End Class
    '#End Region
    '#Region " CLASS : Decompressor "
    '        Public Class Decompressor
    '            Private Overloads Function Equals(ByVal objA As Object, ByVal objB As Object) As Boolean
    '            End Function
    '            Private Overloads Function ReferenceEquals(ByVal objA As Object, ByVal objB As Object) As Boolean
    '            End Function

    '            Public ReadOnly Property Value() As Long
    '                Get
    '                    im lngValue As Long
    '                    If Not (Me.fsInput Is Nothing) Then
    '                        Try
    '                            lngValue = Me.fsInput.Position
    '                        Catch ex As Exception
    '                        End Try
    '                    End If
    '                    Return lngValue
    '                End Get
    '            End Property
    '            Public ReadOnly Property Length() As Long
    '                Get
    '                    Static lngLength As Long = -1
    '                    If lngLength = -1 Then
    '                        im fileInfo As New IO.FileInfo(Me.Input)
    '                        lngLength = fileInfo.Length
    '                    End If
    '                    Return lngLength
    '                End Get
    '            End Property

    '            Public Input As String
    '            Public Output As String
    '            Private fsInput As IO.FileStream
    '            Private fsOutput As IO.FileStream
    '            Public Sub New(ByVal Input As String, ByVal Output As String)
    '                Me.Input = Input
    '                Me.Output = Output
    '            End Sub

    '            Public Sub Decompress()

    '            End Sub

    '        End Class
    '#End Region
    '        Friend Class RLErepetition
    '            Public Location As Long
    '            Public Length As Long
    '        End Class
    '    End Namespace
#End Region 'just testing. not a very good compression method.

End Namespace

но интереснее самому осовить того же халфмана или lzw

новый велосипед?

Ну полно всего готового, но интереснее самому осовить того же халфмана или lzw

Я вот либо с GDI либо с MultiThreading разминаюсь в последнее время.. ))

Не ну а в учебных целей, для разминки моза и пальцев? Или так только я развликаюсь?

MultiThreading тоже полезно... это вам дотнетчикам там весело, а мы LOL'a никак на пример не разведём ))