Task: Huffman coding







Python: from heapq import heappush, heappop, heapify
from collections import defaultdict

def encode(symb2freq):
    
    heap = [[wt, [sym, ""]] for sym, wt in symb2freq.items()]
    heapify(heap)
    while len(heap) > 1:
        lo = heappop(heap)
        hi = heappop(heap)
        for pair in lo[1:]:
            pair[1] = '0' + pair[1]
        for pair in hi[1:]:
            pair[1] = '1' + pair[1]
        heappush(heap, [lo[0] + hi[0]] + lo[1:] + hi[1:])
    return sorted(heappop(heap)[1:], key=lambda p: (len(p[-1]), p))

txt = "this is an example for huffman encoding"
symb2freq = defaultdict(int)
for ch in txt:
    symb2freq[ch] += 1


huff = encode(symb2freq)
print "Symbol\tWeight\tHuffman Code"
for p in huff:
    print "%s\t%s\t%s" % (p[0], symb2freq[p[0]], p[1])




Fortran: 











module huffman
implicit none
type node
  character (len=1 ), allocatable :: sym(:)
  character (len=10), allocatable :: code(:) 
  integer                         :: freq
contains
  procedure                       :: show => show_node
end type

type queue
  type(node), allocatable :: buf(:)
  integer                 :: n = 0
contains
  procedure :: extractmin
  procedure :: append
  procedure :: siftdown
end type

contains

subroutine siftdown(this, a)
  class (queue)           :: this
  integer                 :: a, parent, child
  associate (x => this%buf)
  parent = a
  do while(parent*2 <= this%n)
    child = parent*2
    if (child + 1 <= this%n) then 
      if (x(child+1)%freq < x(child)%freq ) then
        child = child +1 
      end if
    end if
    if (x(parent)%freq > x(child)%freq) then
      x([child, parent]) = x([parent, child])
      parent = child
    else
      exit
    end if  
  end do      
  end associate
end subroutine

function extractmin(this) result (res)
  class(queue) :: this
  type(node)   :: res
  res = this%buf(1)
  this%buf(1) = this%buf(this%n)
  this%n = this%n - 1
  call this%siftdown(1)
end function

subroutine append(this, x)
  class(queue), intent(inout) :: this
  type(node)                  :: x
  type(node), allocatable     :: tmp(:)
  integer                     :: i
  this%n = this%n +1  
  if (.not.allocated(this%buf)) allocate(this%buf(1))
  if (size(this%buf)<this%n) then
    allocate(tmp(2*size(this%buf)))
    tmp(1:this%n-1) = this%buf
    call move_alloc(tmp, this%buf)
  end if
  this%buf(this%n) = x
  i = this%n
  do 
    i = i / 2
    if (i==0) exit
    call this%siftdown(i)
  end do
end subroutine

function join(a, b) result(c)
  type(node)             :: a, b, c
  integer                :: i, n, n1
  n1 = size(a%sym)
  n = n1 + size(b%sym)  
  c%freq = a%freq + b%freq
  allocate (c%sym(n), c%code(n))
  do i = 1, n1
    c%sym(i) = a%sym(i)
    c%code(i) = "0" // trim(a%code(i))
  end do
  do i = 1, size(b%sym)
    c%sym(i+n1) = b%sym(i)
    c%code(i+n1) = "1" // trim(b%code(i))
  end do
end function

subroutine show_node(this)
  class(node) :: this
  integer     :: i
  write(*, "(*(g0,'-> ',g0,:,', '))", advance="no") &
   (this%sym(i), trim(this%code(i)), i=1,size(this%sym))
  print *
end subroutine

function create(letter, freq) result (this)
  character :: letter
  integer   :: freq
  type(node) :: this
  allocate(this%sym(1), this%code(1))
  this%sym(1) = letter ; this%code(1) = ""
  this%freq = freq
end function
end module 

program main
  use huffman
  character (len=*), parameter   :: txt = &
   "this is an example for huffman encoding"
  integer                        :: i, freq(0:255) = 0
  type(queue)                    :: Q
  type(node)                     :: x
  do i = 1, len(txt)
    freq(ichar(txt(i:i))) = freq(ichar(txt(i:i))) + 1 
  end do
  do i = 0, 255
    if (freq(i)>0) then
      call Q%append(create(char(i), freq(i)))
    end if
  end do
  do i = 1, Q%n-1
    call Q%append(join(Q%extractmin(),Q%extractmin()))
  end do
  x = Q%extractmin()
  call x%show()
  do i = 1, len(txt) 
    do k = 1, size(x%sym)
      if (x%sym(k)==txt(i:i)) exit
     end do
     write (*, "(a,'|')", advance="no")  trim(x%code(k))
  end do
  print *
end program