Sync

Task/Huffman-coding/Bracmat/huffman-coding.bracmat

@@ -0,0 +1,56 @@
+( "this is an example for huffman encoding":?S
+& 0:?chars
+& 0:?p
+& ( @( !S
+     :   ?
+         ( [!p %?char [?p ?
+         & !char+!chars:?chars
+         & ~
+         )
+     )
+  |
+  )
+& 0:?prioritized
+&   whl
+  ' ( !chars:?n*%@?w+?chars
+    & (!n.!w)+!prioritized:?prioritized
+    )
+&   whl
+  ' ( !prioritized:(?p.?x)+(?q.?y)+?nprioritized
+    & (!p+!q.(!p.0,!x)+(!q.1,!y))+!nprioritized:?prioritized
+    )
+& 0:?L
+& ( walk
+  =   bits tree bit subtree
+    .   !arg:(?bits.?tree)
+      &   whl
+        ' ( !tree:(?p.?bit,?subtree)+?tree
+          & (   !subtree:@
+              & (!subtree.str$(!bits !bit))+!L:?L
+            | walk$(!bits !bit.!subtree)
+            )
+          )
+  )
+& !prioritized:(?.?prioritized)
+& walk$(.!prioritized)
+& lst$L
+& :?encoded
+& 0:?p
+& ( @( !S
+     :   ?
+         ( [!p %?char [?p ?
+         & !L:?+(!char.?code)+?
+         & !encoded !code:?encoded
+         & ~
+         )
+     )
+  | out$(str$!encoded)
+  )
+& ( decode
+  =   char bits
+    .       !L
+          : ?+(?char.?bits&@(!arg:!bits ?arg))+?
+        & !char decode$!arg
+      | !arg
+  )
+& out$("decoded:" str$(decode$(str$!encoded)));

Task/Huffman-coding/Erlang/huffman-coding.erl

@@ -0,0 +1,63 @@
+-module(huffman).
+
+-export([encode/1, decode/2, main/0]).
+
+encode(Text)  ->
+    Tree  = tree(freq_table(Text)),
+    Dict = dict:from_list(codewords(Tree)),
+    Code = << <<(dict:fetch(Char, Dict))/bitstring>> || Char <- Text >>,
+    {Code, Tree, Dict}.
+
+decode(Code, Tree) ->
+    decode(Code, Tree, Tree, []).
+
+main() ->
+    {Code, Tree, Dict} = encode("this is an example for huffman encoding"),
+    [begin
+        io:format("~s: ",[[Key]]),
+        print_bits(Value)
+     end || {Key, Value} <- lists:sort(dict:to_list(Dict))],
+    io:format("encoded: "),
+    print_bits(Code),
+    io:format("decoded: "),
+    io:format("~s\n",[decode(Code, Tree)]).
+
+decode(<<>>, _, _, Result) ->
+    lists:reverse(Result);
+decode(<<0:1, Rest/bits>>, Tree, {L = {_, _}, _R}, Result) ->
+    decode(<<Rest/bits>>, Tree, L, Result);
+decode(<<0:1, Rest/bits>>, Tree, {L, _R}, Result) ->
+    decode(<<Rest/bits>>, Tree, Tree, [L | Result]);
+decode(<<1:1, Rest/bits>>, Tree, {_L, R = {_, _}}, Result) ->
+    decode(<<Rest/bits>>, Tree, R, Result);
+decode(<<1:1, Rest/bits>>, Tree, {_L, R}, Result) ->
+    decode(<<Rest/bits>>, Tree, Tree, [R | Result]).
+
+codewords({L, R}) ->
+    codewords(L, <<0:1>>) ++ codewords(R, <<1:1>>).
+
+codewords({L, R}, <<Bits/bits>>) ->
+    codewords(L, <<Bits/bits, 0:1>>) ++ codewords(R, <<Bits/bits, 1:1>>);
+codewords(Symbol, <<Bits/bitstring>>) ->
+    [{Symbol, Bits}].
+
+tree([{N, _} | []]) ->
+    N;
+tree(Ns) ->
+    [{N1, C1}, {N2, C2} | Rest] = lists:keysort(2, Ns),
+    tree([{{N1, N2}, C1 + C2} | Rest]).
+
+freq_table(Text) ->
+    freq_table(lists:sort(Text), []).
+
+freq_table([], Acc) ->
+    Acc;
+freq_table([S | Rest], Acc) ->
+    {Block, MoreBlocks} = lists:splitwith(fun (X) -> X == S end, Rest),
+    freq_table(MoreBlocks, [{S, 1 + length(Block)} | Acc]).
+
+print_bits(<<>>) ->
+  io:format("\n");
+print_bits(<<Bit:1, Rest/bitstring>>) ->
+  io:format("~w", [Bit]),
+  print_bits(Rest).

Task/Huffman-coding/Fortran/huffman-coding.f

@@ -0,0 +1,148 @@
+! output:
+! d-> 00000, t-> 00001, h-> 0001, s-> 0010,
+! c-> 00110, x-> 00111, m-> 0100, o-> 0101,
+! n-> 011, u-> 10000, l-> 10001, a-> 1001,
+! r-> 10100, g-> 101010, p-> 101011,
+! e-> 1011, i-> 1100, f-> 1101,  -> 111
+!
+! 00001|0001|1100|0010|111|1100|0010|111|1001|011|
+! 111|1011|00111|1001|0100|101011|10001|1011|111|
+! 1101|0101|10100|111|0001|10000|1101|1101|0100|
+! 1001|011|111|1011|011|00110|0101|00000|1100|011|101010|
+!
+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