PureBasic Forums - English

Code: Select all

    ;*****************************************************************************
    ;   Huffman Encoding File Compression Technique
    ;   From Book: Algorithms in C, by R. Sedgwick  , MA: Addison-Wesley.
    ;   Converted to Pure Basic by PAMKKKKK
    ;   taken from a Power Basic Code by M. Rosenberg CI$: [73707,2545]
    ;   PB 3.94

    Declare PqDownheap(K.l)
    Declare Bin2Int(X.s)

    InText.s ="A SIMPLE STRING TO BE ENCODED USING A MINIMAL NUMBER OF BITS" ;The Input "File"


    Global Dim Count.l(1023)
    Global Dim Heap.l(1023)
    Global Dim Dad.l(1023)
    Global Dim Code.l(255)
    Global Dim Leng.l(255)
    Global N.l
    Global OutText.s
    Global NewText.s


    Procedure Huffman(InText.s)
      ;Count the frequency of each character in the message to be encoded
      For i = 1 To Len(InText)
        Count(Asc(Mid(InText, i , 1))) = Count(Asc(Mid(InText, i, 1))) +1
      Next
       
     ; Initialize the heap array to point to non-zero frequency counts
     N = 0
     For i = 0 To 255
       If Count(i) <> 0
        Heap(N) = i
        N = N +1
       EndIf
     Next

     ;Construct an indirect heap on the frequency values
     For K = N To 1 Step -1
       PqDownheap(K)
     Next
     
      ; Construct the Huffman tree
      Repeat
        T=Heap(1)
        Debug N
        Heap(1) = Heap (N)
        N = N -1
        PqDownheap(1)
        Count( 255 + N) = Count(Heap(1)) + Count(T)
        Dad(T) = 255 + N
        Dad (Heap (1)) = -255 - N
        Heap(1) = 255 + N
        PqDownheap(1)
      Until N <= 0
      Dad(255 + N) = 0
     
      ;Reconstruct the information from the representation of the coding tree
      ;    computed during the shifting process.
      For K = 0 To 255
        If Count(K) = 0
          Code(K) = 0
          Leng(K) = 0
        Else
          i = 0
          J = 1
          T = Dad(K)
          X = 0
          Repeat
            If T < 0
              X=X+J
              T = 0-T
            EndIf
            T =Dad(T)
            J =J +J
            i = i +1
          Until T = 0
          Code(K) = X
          Leng(K) = i
        EndIf
      Next

      ; Use the computed representations of the code to encode the string
      J= 0
      Repeat
        J = J + 1
        char = Asc(Mid(InText,J,1))
        Compr.s = Bin(Code(char))
        While Len(Compr.s) < Leng(char)
          Compr = "0" + Compr.s
        Wend
        ;Debug Chr(char) + " = " + Compr
        Hold.s = Hold.s + Compr.s
        If Len(Hold.s) > 8
          OutText.s = OutText.s + Chr(Bin2Int(Left(Hold.s,8)))
          Hold.s = Right(Hold.s,Len(Hold.s) - 8)
        EndIf
      Until J = Len(InText)
     
      ; Add a byte at the End that contains any left-over bits
      If Len(Hold.s) > 0
        While Len(Hold) < 8
          Hold.s = Hold.s + "0"
        Wend
        OutText.s = OutText.s + Chr(Bin2Int(Left(Hold,8)))
      EndIf

      ;*****************************************************************************
      ; Unpack compressed string into character representation of binary
      J = 0
      Repeat
        J = J + 1
        Hold.s= Mid(OutText.s,J,1)
        Hold.s= Bin(Asc(Hold))
        While Len(Hold) < 8
          Hold.s = "0" + Hold.s
        Wend
        UnCompr.s = UnCompr.s + Hold.s
      Until J = Len(OutText.s)
     
      ;Decode compressed string
      Repeat
        For  K = 0 To 255
          If K = 255
            Break 2      ;All done
          EndIf
          If  Leng(K) > 0
            If Bin2Int(Left(UnCompr.s,Leng(K))) = Code(K)
              UnCompr.s = Right(UnCompr.s,Len(UnCompr.s) - Leng(K))
              NewText.s= NewText.s + Chr(K)
              Break
            EndIf
          EndIf
        Next
      Until Len(UnCompr.s) = 0
     
    EndProcedure

    Procedure Bin2Int(X.s)
      X.s=Trim(X)
      Ll = Len(X)
      Ex = 0
      Tot = 0
      i =Ll
      While i > 0
        If Mid(X.s,i,1) = "1"
          Tot =Tot + Pow(2,Ex)
        EndIf
        Ex = Ex + 1
        i = i -1
      Wend
      ProcedureReturn Tot
    EndProcedure

    Procedure PqDownheap(K.l)
      ;Build and maintain an indirect heap on the frequency values
      ;    reversing the inequalities since we want the smallest values first.
      J.l
      V = Heap(K)
      While (K <= N/2)
        J = K+K
        If J<N And Count(Heap(J)) > Count(Heap(J+1))
          J = J +1
        EndIf
        If Count(V)<=Count(Heap(J))
          Heap(K) = V
          ProcedureReturn
        EndIf
       
        Heap(K) = Heap(J)
        Heap(J) = V
        K = J
      Wend
    EndProcedure


    ; ********************************************************
    Huffman(InText)
    Debug "in: " + Str(Len(InText)) + " "+ InText
    Debug "out: " + Str(Len(OutText))  + " "+ OutText
    Debug "New: " + Str(Len(NewText)) +  " " + NewText