Attribute VB_Name = "mod_ctCompressA"
' Copyright (C) 2004-2006 Jan Vorel
'
' This program is free software; you can redistribute it and/or modify
' it under the terms of the GNU General Public License as published by
' the Free Software Foundation; either version 2 of the License, or
' (at your option) any later version.

' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY; without even the implied warranty of
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
' GNU General Public License for more details.

' You should have received a copy of the GNU General Public License
' along with this program; if not, write to the Free Software
' Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

' This is a shared modul, class modul, usercontrol or form. It is also
' published under the GNU General Public License.

' If you have any questions, suggestions or bug reports about this product,
' contact me: info@ctuser.net; Do not contact me about general B.A.S.I.C.
' language or A.P.I. issues

Option Explicit
Option Base 0

Private Declare Sub RtlMoveMemory Lib "kernel32" (Destination As Any, Source As Any, ByVal Length As Long)

'#ctCompressA_FlagA
'    1 = Use Compress
'    2 = use decompress (default)
'    3 = use Both
' 1000 = CanAbort
#If (ctCompressA_FlagA And &H1000&) = &H1000& Then
  Public ctCompressA_Abort As Boolean
  #End If

#If (ctCompressA_FlagA And &H1&) = &H1& Then
  Public Function ctCompressA_Compress(ByRef Data As String, Optional ByVal ProgressControl As Long = 0&, Optional ByVal ProgressStart As Long = 0&, Optional ByVal ProgressTotal As Long = 0&, Optional ByVal ProgressQueue As Long = 0&) As String
    Dim ProgressQueueTemp As Long
    Dim FileArray() As Byte
    Dim X As Long
    Dim Y As Long
    Dim Z As Long
    Dim Char As Long
    Dim Bitlen As Long
    Dim FileLen As Long
    Dim TelBits As Long
    Dim TotBits As Long
    Dim OutStream() As Byte
    Dim TreeNodesA(511) As Long
    Dim TreeNodesB(511) As Long
    Dim TreeNodesC(511) As Long
    Dim TreeNodesD(511) As Long
    Dim TreeNodesE(511) As Long
    Dim BitValue(7) As Long
    Dim ByteValue As Long
    Dim ByteBuff As String
    Dim NumberOfNodes As Long
    Dim OrgNumberOfNodes As Long
    Dim PackedSize As Long
    Dim DictSize As Long
    Dim OutPutSize As Long
    Dim CharCount(255) As Long
    Dim Bits(255) As String
    'Dim Nubits As String
    'Dim lTemp As Long
    Dim lWeight As Long
    Dim rWeight As Long
    Dim MaxWeight As Long
    Dim NowWeight As Long
    Dim lNode As Long
    Dim rNode As Long
    Dim StringBuffer As String
      
    'If ProgressControl = 0& 'Then ProgressTotal = 0&
    #If (ctCompressA_FlagA And &H1000&) = &H1000& Then
      ctCompressA_Abort = False
      #End If
      
    FileLen = Len(Data) - 1&
    If Not FileLen = -1& Then
      ReDim FileArray(FileLen)
      Call RtlMoveMemory(FileArray(0), ByVal Data, FileLen + 1&)
      OutPutSize = -1&
      If Not (FileLen = 0&) Then
        ProgressQueueTemp = ProgressQueue \ 25&
        For X = 0& To FileLen
          CharCount(FileArray(X)) = CharCount(FileArray(X)) + 1&
          If (X Mod 1024&) = 1023& Then
            'If Not ProgressTotal = 0& Then
              ctProgressB_SetValue ProgressControl, (ProgressStart + (X / FileLen * ProgressQueueTemp)), ProgressTotal
              'Debug.Print (ProgressStart + (x / FileLen * ProgressQueueTemp)) , ProgressTotal
              'End If
            #If (ctCompressA_FlagA And &H1000&) = &H1000& Then
              If ctCompressA_Abort Then Exit Function
              #End If
            End If
          Next
        MaxWeight = FileLen + 1&
        Z = -1&
        For X = 0& To 255&
          If Not CharCount(X) = 0& Then
            Z = Z + 1&
            TreeNodesA(Z) = CharCount(X)
            TreeNodesB(Z) = X
            TreeNodesC(Z) = -1&
            TreeNodesD(Z) = -1&
            TreeNodesE(Z) = -1&
            End If
          Next
        ProgressStart = ProgressStart + ProgressQueueTemp
        ProgressQueue = ProgressQueue - ProgressQueueTemp
        'If Not ProgressTotal = 0& Then
          ctProgressB_SetValue ProgressControl, ProgressStart, ProgressTotal
          'Debug.Print ProgressStart , ProgressTotal
          'End If
        'DoEvents
        #If (ctCompressA_FlagA And &H1000&) = &H1000& Then
          If ctCompressA_Abort Then Exit Function
          #End If
        ProgressQueueTemp = ProgressQueue \ 50&
        NumberOfNodes = Z
        OrgNumberOfNodes = NumberOfNodes
        For X = NumberOfNodes + 1& To 2& Step -1&
          lWeight = MaxWeight * 2&: rWeight = MaxWeight * 2&
          For Y = 0& To NumberOfNodes + 1&
            If TreeNodesE(Y) = -1& Then
              NowWeight = TreeNodesA(Y)
              If NowWeight < rWeight Or NowWeight < lWeight Then
                If rWeight > lWeight Then
                  rWeight = NowWeight
                  rNode = Y
                  Else
                  lWeight = NowWeight
                  lNode = Y
                  End If
                End If
              End If
            Next Y
          NumberOfNodes = NumberOfNodes + 1&
          TreeNodesE(lNode) = NumberOfNodes
          TreeNodesE(rNode) = NumberOfNodes
          TreeNodesA(NumberOfNodes) = lWeight + rWeight
          TreeNodesB(NumberOfNodes) = -1
          TreeNodesC(NumberOfNodes) = lNode
          TreeNodesD(NumberOfNodes) = rNode
          TreeNodesE(NumberOfNodes) = -1
          If (X Mod 1024&) = 2& Then
            'If Not ProgressTotal = 0& Then
              ctProgressB_SetValue ProgressControl, (ProgressStart + (NumberOfNodes - (X - 1&)) / NumberOfNodes * ProgressQueueTemp), ProgressTotal
              'Debug.Print (ProgressStart + (NumberOfNodes - (x - 1&)) / NumberOfNodes * ProgressQueueTemp) , ProgressTotal
              'End If
            'DoEvents
            #If (ctCompressA_FlagA And &H1000&) = &H1000& Then
              If ctCompressA_Abort Then Exit Function
              #End If
            End If
          Next
        TotBits = 0&
        ProgressStart = ProgressStart + ProgressQueueTemp
        ProgressQueue = ProgressQueue - ProgressQueueTemp
        'ProgressControl.ValueSet ProgressStart , ProgressTotal
        'DoEvents
        #If (ctCompressA_FlagA And &H1000&) = &H1000& Then
          If ctCompressA_Abort Then Exit Function
          #End If
        ProgressQueueTemp = ProgressQueue \ 20&
        For X = 0& To OrgNumberOfNodes
          Char = TreeNodesB(X)
          Y = X
          Z = Y
          Do Until TreeNodesE(Y) = -1&
            Y = TreeNodesE(Y)
            If TreeNodesC(Y) = Z Then
              Bits(Char) = vbNullChar & Bits(Char)
              ElseIf TreeNodesD(Y) = Z Then
              Bits(Char) = Chr(1) & Bits(Char)
              Else
              'MsgBox "error creating bitpatern"
              Exit Function
              End If
            TotBits = TotBits + 1&
            Z = Y
            Loop
          PackedSize = PackedSize + (TreeNodesA(X) * (Len(Bits(Char))))
          DictSize = DictSize + 2&
          If (X Mod 1024&) = 1023& Then
            'If Not ProgressTotal = 0& Then
              ctProgressB_SetValue ProgressControl, (ProgressStart + X / (OrgNumberOfNodes * 2&) * ProgressQueueTemp), ProgressTotal
              'Debug.Print (ProgressStart + x / (OrgNumberOfNodes * 2&) * ProgressQueueTemp) , ProgressTotal
              'End If
            'DoEvents
            #If (ctCompressA_FlagA And &H1000&) = &H1000& Then
              If ctCompressA_Abort Then Exit Function
              #End If
            End If
          Next
        PackedSize = (PackedSize + 7&) \ 8&
        Bitlen = (TotBits + 7&) \ 8&
        ReDim OutStream(4& + DictSize + Bitlen + 4& + PackedSize + 1&)   '-2 tolerate
        For X = 0& To 7&
          BitValue(X) = 2& ^ X
          Next
        TotBits = 0&
        TelBits = 7&
        ByteBuff = ""
        For X = 0& To OrgNumberOfNodes
          Char = TreeNodesB(X)
          Bitlen = Len(Bits(Char))
          TotBits = TotBits + Bitlen
          StringBuffer = StringBuffer & Chr(Char) & Chr(Bitlen)
          For Y = 1& To Bitlen
            If Mid(Bits(Char), Y, 1&) = vbNullChar Then
              ByteValue = ByteValue + BitValue(TelBits)
              End If
            TelBits = TelBits - 1&
            If TelBits = -1& Then
              ByteBuff = ByteBuff & Chr(ByteValue)
              TelBits = 7&
              ByteValue = 0&
              End If
            Next
          If (X + OrgNumberOfNodes Mod 1024&) = 1023& Then
            'If Not ProgressTotal = 0& Then
              ctProgressB_SetValue ProgressControl, (ProgressStart + (X + OrgNumberOfNodes) / (OrgNumberOfNodes * 2&) * ProgressQueueTemp), ProgressTotal
              'End If
            'Debug.Print (ProgressStart + (x + OrgNumberOfNodes) / (OrgNumberOfNodes * 2&) * ProgressQueueTemp) , ProgressTotal
            'DoEvents
            #If (ctCompressA_FlagA And &H1000&) = &H1000& Then
              If ctCompressA_Abort Then Exit Function
              #End If
            End If
          Next
        If Not TelBits = 7& Then
          ByteBuff = ByteBuff & Chr(ByteValue)
          End If
        ProgressStart = ProgressStart + ProgressQueueTemp
        ProgressQueue = ProgressQueue - ProgressQueueTemp
        'DoEvents
        #If (ctCompressA_FlagA And &H1000&) = &H1000& Then
          If ctCompressA_Abort Then Exit Function
          #End If
        StringBuffer = StringBuffer & ByteBuff
        Call AddLong2Array(OutStream, OutPutSize, DictSize)
        ByteValue = Len(StringBuffer)
        For TelBits = 1& To ByteValue
          OutStream(OutPutSize + TelBits) = Asc(Mid(StringBuffer, TelBits, 1&))
          Next
        'If Not ProgressTotal = 0& Then
          ctProgressB_SetValue ProgressControl, ProgressStart, ProgressTotal
          'End If
        OutPutSize = OutPutSize + ByteValue
        Call AddLong2Array(OutStream, OutPutSize, FileLen + 1&)
        TelBits = 7&
        ByteValue = 0&
        For X = 0& To FileLen
          For Y = 1& To Len(Bits(FileArray(X)))
            If Mid(Bits(FileArray(X)), Y, 1&) = vbNullChar Then
              ByteValue = ByteValue + BitValue(TelBits)
              End If
            TelBits = TelBits - 1&
            If TelBits = -1& Then
              OutPutSize = OutPutSize + 1&
              OutStream(OutPutSize) = ByteValue
              TelBits = 7&
              ByteValue = 0&
              End If
            Next
          If (X Mod 1024&) = 1023& Then
            'If Not ProgressTotal = 0& Then
              ctProgressB_SetValue ProgressControl, (ProgressStart + X / FileLen * ProgressQueue), ProgressTotal
              'Debug.Print (ProgressStart + x / FileLen * ProgressQueue) , ProgressTotal
              'End If
            'DoEvents
            #If (ctCompressA_FlagA And &H1000&) = &H1000& Then
              If ctCompressA_Abort Then Exit Function
              #End If
            End If
          Next
        If Not TelBits = 7& Then
          OutPutSize = OutPutSize + 1&
          OutStream(OutPutSize) = ByteValue
          End If
        ReDim Preserve OutStream(OutPutSize)
        OutPutSize = OutPutSize + 1&
        ctCompressA_Compress = String(OutPutSize, vbNullChar)
        Call RtlMoveMemory(ByVal ctCompressA_Compress, OutStream(0), OutPutSize)
        'If Not ProgressTotal = 0& Then
          ctProgressB_SetValue ProgressControl, (ProgressStart + ProgressQueue), ProgressTotal
          'Debug.Print (ProgressStart + ProgressQueue) , ProgressTotal
          'End If
        'DoEvents
        #If (ctCompressA_FlagA And &H1000&) = &H1000& Then
          If ctCompressA_Abort Then Exit Function
          #End If
        End If
      End If
    End Function

  Private Sub AddLong2Array(ByRef WichArray() As Byte, ByRef StartPos As Long, ByVal xLong1 As Long)
    Dim xLong2 As Long
    xLong2 = xLong1 \ &H1000000
    xLong1 = xLong1 - xLong2 * &H1000000
    WichArray(StartPos + 1&) = xLong2
    xLong2 = xLong1 \ &H10000
    xLong1 = xLong1 - xLong2 * &H10000
    WichArray(StartPos + 2&) = xLong2
    xLong2 = xLong1 \ &H100&
    WichArray(StartPos + 3&) = xLong2
    WichArray(StartPos + 4&) = xLong1 - xLong2 * &H100&
    StartPos = StartPos + 4
    End Sub
  #End If

#If (ctCompressA_FlagA And &H2&) = &H2& Or ctCompressA_FlagA = &H0& Then
    Public Function ctCompressA_Decompress(ByRef Data As String, ByRef OriginalSize As Long, Optional ByVal ProgressControl As Long = 0&, Optional ByVal ProgressStart As Long = 0&, Optional ByVal ProgressTotal As Long = 0&, Optional ByVal ProgressQueue As Long = 0&) As String
      Dim FileArray() As Byte
      Dim DeCompressed() As Byte
      Dim X As Long
      Dim Y As Long
      'Dim Z As Long
      Dim TreeNodesA(511) As Long
      Dim TreeNodesB(511) As Long
      Dim TreeNodesC(511) As Long
      'Dim TreeNodesD(511) As Long
      Dim TreeNodesE(511) As Long
      Dim LeafA(255) As Long
      Dim LeafB(255) As Long
      Dim ByteValue As Long
      Dim BitValue(7) As Long
      Dim NumberOfNodes As Long
      Dim NuNode As Long
      Dim ToNode As Long
      'Dim Char As Long
      'Dim Bitlen As Long
      Dim Bits(255) As String
      Dim TotBits As Long
      Dim TelBits As Long
      Dim DictSize As Long
      Dim InpPos As Long
      Dim OrgLen As Long
      Dim Nulen As Long
    
    'If ProgressControl = 0& Then ProgressTotal = 0&
    #If (ctCompressA_FlagA And &H1000&) = &H1000& Then
      ctCompressA_Abort = False
      #End If
    
      TotBits = Len(Data)
      If Not TotBits = 0& Then
        ReDim FileArray(TotBits - 1&)
        Call RtlMoveMemory(FileArray(0), ByVal Data, TotBits)
        DictSize = GetLongFromArray(FileArray, InpPos)
        For X = 0& To 7&: BitValue(X) = 2& ^ X: Next
        TotBits = 0&
        Do While InpPos < DictSize + 3&
          LeafA(TotBits) = FileArray(InpPos)
          LeafB(TotBits) = FileArray(InpPos + 1&)
          InpPos = InpPos + 2&
          TotBits = TotBits + 1&
          Loop
        TelBits = -1&
        For X = 0& To TotBits - 1&
          For Y = 1& To LeafB(X)
            If TelBits = -1 Then
              ByteValue = FileArray(InpPos)
              InpPos = InpPos + 1&
              TelBits = 7&
              End If
            Bits(LeafA(X)) = Bits(LeafA(X)) & Chr(-1& * ((ByteValue And BitValue(TelBits)) > 0&))
'Dim aa&
'aa& = -1& * ((ByteValue And BitValue(TelBits)) > 0&)
'Stop
            TelBits = TelBits - 1&
            Next
          Next
        For X = 0& To 255&
          TreeNodesA(X) = -1&
          TreeNodesB(X) = -1&
          TreeNodesC(X) = -1&
          TreeNodesE(X) = -1&
          Next
        
        NumberOfNodes = -1&
        NuNode = -1&
        GoSub Create_New_Node
        For X = 0& To 255&
          If Not Bits(X) = "" Then
            NuNode = 0&
            For Y = 1& To Len(Bits(X))
              If Mid(Bits(X), Y, 1&) = vbNullChar Then
                ToNode = TreeNodesC(NuNode)
                If ToNode = -1 Then
                  GoSub Create_New_Node
                  TreeNodesC(NuNode) = ToNode
                  End If
                Else
                ToNode = TreeNodesB(NuNode)
                If ToNode = -1 Then
                  GoSub Create_New_Node
                  TreeNodesB(NuNode) = ToNode
                  End If
                End If
              NuNode = ToNode
              Next
            TreeNodesA(NuNode) = X
            TreeNodesE(NuNode) = 255&
            End If
          Next
        Nulen = ProgressQueue \ 100&
        'If Not ProgressTotal = 0& Then
          ctProgressB_SetValue ProgressControl, (ProgressStart + Nulen), ProgressTotal
          'End If
        'DoEvents
        #If (ctCompressA_FlagA And &H1000&) = &H1000& Then
          If ctCompressA_Abort Then Exit Function
          #End If
        ProgressQueue = ProgressQueue - Nulen
        OrgLen = GetLongFromArray(FileArray, InpPos)
        ReDim DeCompressed(OrgLen - 1&)
        Nulen = 0&
        NuNode = 0&
        'StringBuffer = ""
        TelBits = 7&
'Stop
        Do While Nulen < OrgLen
          If TelBits = -1 Then
            InpPos = InpPos + 1&
            TelBits = 7&
            End If
          If (FileArray(InpPos) And 2& ^ TelBits) > 0& Then
            NuNode = TreeNodesB(NuNode)
            Else
            NuNode = TreeNodesC(NuNode)
            End If
          If NuNode = 0& Then
            'Err.Raise vbError, "DecompressHuffman", "We zijn de boom tot op een dood punt genaderd, waarschijnlijk is de header beschadigd"
            Exit Function
            End If
          If TreeNodesE(NuNode) = 255& Then
            DeCompressed(Nulen) = TreeNodesA(NuNode)
            Nulen = Nulen + 1&
            NuNode = 0&
            If (Nulen Mod 1024&) = 1023& Then
              'If Not ProgressTotal = 0& Then
                ctProgressB_SetValue ProgressControl, (ProgressStart + Nulen / OrgLen * ProgressQueue), ProgressTotal
                'End If
              'DoEvents
              #If (ctCompressA_FlagA And &H1000&) = &H1000& Then
                If ctCompressA_Abort Then Exit Function
                #End If
              End If
            End If
          TelBits = TelBits - 1&
          Loop
        ctCompressA_Decompress = String(OrgLen, vbNullChar)
        Call RtlMoveMemory(ByVal ctCompressA_Decompress, DeCompressed(0), OrgLen)
        End If
'    Stop
      Exit Function
        
Create_New_Node:
      NumberOfNodes = NumberOfNodes + 1&
      TreeNodesA(NumberOfNodes) = -1&
      TreeNodesB(NumberOfNodes) = -1&
      TreeNodesC(NumberOfNodes) = -1&
'      TreeNodesD(NumberOfNodes) = NuNode
      TreeNodesE(NumberOfNodes) = -1&
      ToNode = NumberOfNodes
      Return
    End Function

  Private Function GetLongFromArray(ByRef WichArray() As Byte, ByRef StartPos As Long) As Long
    GetLongFromArray = WichArray(StartPos) * &H1000000 + _
                       WichArray(StartPos + 1&) * &H10000 + _
                       WichArray(StartPos + 2&) * &H100& + _
                       WichArray(StartPos + 3&)
    StartPos = StartPos + 4&
    End Function
  #End If
