Attribute VB_Name = "modHuffman"
Option Explicit

Private Type tBinaryNode
   Index As Long
   Weight As Long
   Child0 As Long
   Child1 As Long
End Type

Private Type tByteCode
   Byt As Byte
   BitCt As Byte
   Code As Long
End Type


Public Function HuffEncode(Bytes() As Byte) As Byte()
Dim i As Long, j As Long, Ub As Long, Ct As Long, Byt As Byte, tot As Long, a As Long

Dim BytCode(255) As Long
Dim BytFreq(255) As Long
Dim P2(30) As Long
Dim BytIndx() As Long
Dim BinTree() As tBinaryNode
Dim BytOut() As Byte
Dim Dn As Long, Up As Long, Wght As Long, Dpth As Long
Dim iBit As Long, Code As Long, BitCt As Long, iByt As Long
Dim MaxSZ As Long
Dim CodeCt As Long
   
   'create a bit table
   j = 1
   For i = 0 To 29
      P2(i) = j
      j = j + j
   Next i
   P2(i) = j

   
   'count the frequency of each byte
   Ub = UBound(Bytes)
   For i = 0 To UBound(Bytes)
      BytFreq(Bytes(i)) = BytFreq(Bytes(i)) + 1
   Next i
   
   'sort decending by index
   BytIndx = QuicksortIndex(BytFreq)
   
   'count the bytes with a frequency above zero
   For CodeCt = 0 To 255
      If BytFreq(BytIndx(CodeCt)) Then Else Exit For
   Next CodeCt
   'CodeCt = CodeCt - 1
   
   'size the binary tree and fill the leaf nodes
   ReDim BinTree(CodeCt + CodeCt)
   For Up = 0 To CodeCt
      With BinTree(Up)
         .Index = BytIndx(Up)
         .Weight = BytFreq(BytIndx(Up))
         .Child0 = -1 'to indicate leaf node
      End With
   Next Up
   If CodeCt = &H100& Then BinTree(&H100&).Index = BytIndx(&HFF&)
   
   'build the binary tree
   For Dpth = Up - 2 To 0 Step -1
      Wght = BinTree(Dpth).Weight + BinTree(Dpth + 1).Weight
      BinTree(Up) = BinTree(Dpth)
      Dn = Dpth
      If Dn Then
         Dn = Dn - 1
         Do While Wght > BinTree(Dn).Weight
            BinTree(Dn + 1) = BinTree(Dn)
            Dn = Dn - 1
            If Dn < 0 Then Exit Do
         Loop
         Dn = Dn + 1
      End If
      With BinTree(Dn)
         .Weight = Wght
         .Child0 = Up
         .Child1 = Dpth + 1
      End With
      Up = Up + 1
   Next

   'recurse the tree to generate the codes
   ResolveBinTree BinTree, 0, 0, 1, 0
   
   'assign codes to letters and calculate compression
   BitCt = (CodeCt + 1) * 13 + 28
   For i = 0 To UBound(BinTree)
      With BinTree(i)
         If .Child0 = -1 Then
            BytCode(.Index) = .Weight
            BitCt = BitCt + .Child1 * (BytFreq(.Index) + 1)
            BytFreq(.Index) = .Child1
         End If
      End With
   Next i
   BitCt = BitCt \ 8
   ReDim BytOut(BitCt)
   
   'encode dictionary
   Ct = 1
   BitCt = 0
   Code = 0
   BytOut(0) = CodeCt - 1
   For i = 0 To CodeCt
      j = BytIndx(i)
      
      Code = Code Or P2(BitCt) * j
      BitCt = BitCt + 8
      Do While BitCt > 7
         BytOut(Ct) = Code And &HFF&
         Code = Code \ &H100
         BitCt = BitCt - 8
         Ct = Ct + 1
      Loop
      
      Code = Code Or P2(BitCt) * BytFreq(j)
      BitCt = BitCt + 5
      Do While BitCt > 7
         BytOut(Ct) = Code And &HFF&
         Code = Code \ &H100
         BitCt = BitCt - 8
         Ct = Ct + 1
      Loop
      
      Code = Code Or P2(BitCt) * BytCode(j)
      BitCt = BitCt + BytFreq(j)
      Do While BitCt > 7
         BytOut(Ct) = Code And &HFF&
         Code = Code \ &H100
         BitCt = BitCt - 8
         Ct = Ct + 1
      Loop
   Next i
   

   
   'encode
   For i = 0 To Ub
      Code = Code Or P2(BitCt) * BytCode(Bytes(i))
      BitCt = BitCt + BytFreq(Bytes(i))
      Do While BitCt > 7
         BytOut(Ct) = (Code And &HFF&)
         BitCt = BitCt - 8
         Code = Code \ &H100&
         Ct = Ct + 1
      Loop
   Next i

   Code = Code Or P2(BitCt) * BytCode(BytIndx(CodeCt))
   BitCt = BitCt + BytFreq(BytIndx(CodeCt))

   Do
      BytOut(Ct) = (Code And &HFF&)
      BitCt = BitCt - 8
      Code = Code \ &H100&
      Ct = Ct + 1
   Loop While BitCt > 0


   ReDim Preserve BytOut(Ct - 1)

   HuffEncode = BytOut
End Function

Public Function HuffDecode(Bytes() As Byte) As Byte()
Dim i As Long, j As Long, Ub As Long, Ct As Long, Byt As Byte, tot As Long, a As Long, Ii As Long, Oi As Long
Dim P2(30) As Long
Dim Codes() As Long
Dim CodeBitCt() As Long
Dim Symbol() As Long
Dim BytOut() As Byte

Dim iBit As Long, Bits As Long, BitCt As Long
Dim MaxBitCt As Long
Dim CodeCt As Long

   ReDim HuffDecode(-1 To -1) 'set to the fail state return
   
   'power of 2 array
   j = 1
   For i = 0 To 29
      P2(i) = j
      j = j + j
   Next i
   P2(i) = j
   
   'decode dictionary
   Ub = UBound(Bytes)
   Ct = 1
   BitCt = 0
   CodeCt = Bytes(0) + 1
   ReDim Codes(CodeCt)
   ReDim CodeBitCt(CodeCt)
   ReDim Symbol(CodeCt)
   For i = 0 To CodeCt
      Bits = Bits Or P2(BitCt) * (&H100& * Bytes(Ct + 1) Or Bytes(Ct))
      Ct = Ct + 2
      If Ct > Ub Then Exit Function
      Symbol(i) = Bits And &HFF
      Bits = Bits \ &H100
      CodeBitCt(i) = Bits And &H1F
      If CodeBitCt(i) > MaxBitCt Then MaxBitCt = CodeBitCt(i)
      Bits = Bits \ &H20
      BitCt = BitCt + 3 '(+8 -5)
      Do While BitCt < CodeBitCt(i)
         Bits = Bits Or Bytes(Ct) * P2(BitCt)
         Ct = Ct + 1
         If Ct > Ub Then Exit Function
         BitCt = BitCt + 8
      Loop
      Codes(i) = (Bits And (P2(CodeBitCt(i)) - 1)) '!!!!!!!!!!!!!!!!!!!!!
      Bits = Bits \ P2(CodeBitCt(i))
      BitCt = BitCt - CodeBitCt(i)
   Next i
   
   
   Oi = 0
   Ub = Ub + Ub
   ReDim BytOut(Ub)

   For i = Ct To UBound(Bytes)
      Bits = Bits Or Bytes(i) * P2(BitCt)
      BitCt = BitCt + 8
      Do Until BitCt <= MaxBitCt
         j = 0

         Do While ((Bits And (P2(CodeBitCt(j)) - 1)) Xor Codes(j))
            j = j + 1
         Loop
         If Oi > Ub Then Ub = Ub + Ub: ReDim Preserve BytOut(Ub)
         BytOut(Oi) = Symbol(j)
         Bits = Bits \ P2(CodeBitCt(j))
         BitCt = BitCt - CodeBitCt(j)
         Oi = Oi + 1
      Loop
   Next i
   
   Bits = Symbol(CodeCt)
   
   For i = Oi - 1 To 0 Step -1
      If BytOut(i) = Bits Then Exit For
   Next i
   If i <> -1 Then Ub = i - 1 Else Ub = Oi - 1
   ReDim Preserve BytOut(Ub)
   

   HuffDecode = BytOut

   
End Function

Private Sub ResolveBinTree(BinTree() As tBinaryNode, ByVal i As Long, ByVal Code As Long, ByVal n As Long, ByVal Dpth As Long)
      If BinTree(i).Child0 <> -1 Then
         Dpth = Dpth + 1
         ResolveBinTree BinTree, BinTree(i).Child0, Code, n + n, Dpth
         ResolveBinTree BinTree, BinTree(i).Child1, Code Or n, n + n, Dpth
      Else
         BinTree(i).Weight = Code
         BinTree(i).Child1 = Dpth
      End If
End Sub

Public Function QuicksortIndex(Arr() As Long) As Long()
Dim i As Long, Indx() As Long
   i = UBound(Arr)
   ReDim Indx(i + 1)
   For i = 1 To i
      Indx(i) = i
   Next i
   Indx(i) = 0
   QuicksortIndex = Indx
   recQuicksortIndex Arr, QuicksortIndex, 0, i - 1
End Function

Private Sub recQuicksortIndex(Arr() As Long, Indx() As Long, ByVal StartIndex As Long, ByVal EndIndex As Long)
Dim Up As Long, Dn As Long, Piv As Long, Swp As Long

    Up = StartIndex
    Dn = EndIndex
    Piv = Arr(Indx((StartIndex + EndIndex) \ 2))
    Do
        Do While Arr(Indx(Up)) > Piv And Up < EndIndex: Up = Up + 1: Loop
        Do While Arr(Indx(Dn)) < Piv And Dn > StartIndex: Dn = Dn - 1: Loop
        If Up <= Dn Then
            Swp = Indx(Up)
            Indx(Up) = Indx(Dn)
            Indx(Dn) = Swp
            Up = Up + 1
            Dn = Dn - 1
        End If
    Loop Until Up > Dn
    
    If StartIndex < Dn Then recQuicksortIndex Arr, Indx, StartIndex, Dn
    If Up < EndIndex Then recQuicksortIndex Arr, Indx, Up, EndIndex
End Sub