Huffman encoding on Mathematica

Question

Taking reference of Huffman code algorithm,

 list={{{{{{}, {{x7, 4}, {1, {{f, 3}}}, {0, {{q, 1}}}}},
    {{x8,9}, {1, {{b, 5}}}, {0, {{x7, 4}}}}}, 
    {{x9,12}, {1, {{e, 6}}}, {0, {{a, 6}}}}}, 
    {{x10,19}, {1, {{h, 10}}}, {0, {{x8, 9}}}}}, 
    {{x11,31}, {1, {{x10, 19}}}, {0, {{x9, 12}}}}}

This is in midway of creating the Huffman code for any string.

x* represents the new node made from two smallest nodes and 4 next to it represents the sum of the frequencies of the two child nodes under it.

Information on structure of list:

{{parent_node,fre1},{code,{{child_node1,freq2}}},{code,{{child_node2,freq3}}}}

freq1 = freq2 + freq3

{{x7, 4}, {1, {{f, 3}}}, {0, {{q, 1}}}} 

x7 is parent of f and q

4 = 3 + 1

This unique node(x7) is added in list, sorted and operation repeated again. I am facing problem with creating a final output as Huffman codes for each character, for example, h = 11, a = 00 walking from top to bottom. Final result could be {{h,11},{a,00}} and with other characters.

Answer 1

Having spent more time on this problem, I have been able to solve the problem in this way.

a) Let there is list="aheaheaaehbebheahebafhbfbhfbhqhh" and we create its run length coding using.

    lis = Tally[ ToExpression[Characters["aheaheaaehebheahebafhtttwwbfbhfbhqhh"]]]

{{a, 6}, {h, 10}, {e, 6}, {b, 5}, {f, 3}, {t, 3}, {w, 2}, {q, 1}}

To create a hierarchy by combining two nodes, putting under new node, putting new node in list and sorting again and repeating the process.

list = Module[{l1, l2, l3, l4 = {}, l5, l = lis},
  Do[
   {l1 = SortBy[l, Last],
    l2 = {Unique["x"], 
      Total[Last[#] & /@ Pick[l1, Flatten[{1, 1, Table[0, {Length[l1] - 2}]}], 1]]},
    l3 = SortBy[Join[Pick[l1, Flatten[{0, 0, Table[1, {Length[l1] - 2}]}], 
        1], {l2}], Last],
    l4 = {l4, {l2, {1, 
        Pick[l1, Flatten[{0, 1, Table[0, {Length[l1] - 2}]}], 1]}, {0,
         Pick[l1, Flatten[{1, 0, Table[0, {Length[l1] - 2}]}], 1]}}},
    l = l3;
    l5 = {l2, l3}
    }, {i, Length[l] - 1}]; l4]

Nested List :

 {{{{{{{{}, {{x38, 3}, {1, {{w, 2}}}, {0, {{q, 1}}}}},
         {{x39,6}, {1, {{t, 3}}}, {0, {{f, 3}}}}}, 
         {{x40,8}, {1, {{b, 5}}}, {0, {{x38, 3}}}}}, 
         {{x41,12}, {1, {{e, 6}}}, {0, {{a, 6}}}}}, 
         {{x42,14}, {1, {{x40, 8}}}, {0, {{x39, 6}}}}}, 
         {{x43,22}, {1, {{x41, 12}}}, {0, {{h, 10}}}}}, 
         {{x44,36}, {1, {{x43, 22}}}, {0, {{x42, 14}}}}}

Creating replacements as codes for nodes from nested list,

ruleslist = 
 Table[Level[list, {1,n}] /. {___, {{a_, 
        b_}, {c_, {{d_, e_}}}, {f_, {{g_, h_}}}}, ___} -> {d -> {c, 
        d}, g -> {f, g}}, {n, 0, Length[lis] - 1, 1}] // Flatten

{x43 -> {1, x43}, x42 -> {0, x42}, x41 -> {1, x41}, h -> {0, h}, x40 -> {1, x40}, x39 -> {0, x39}, e -> {1, e}, a -> {0, a}, b -> {1, b}, x38 -> {0, x38}, t -> {1, t}, f -> {0, f}, w -> {1, w}, q -> {0, q}}

Creating a list of graphs as the idea is to create a parent node for every two child nodes,

graphlist = 
 Table[Level[
    list, {0, n}] /. {___, 
     s : {{a_, b_}, {c_, {{d_, e_}}}, {f_, {{g_, h_}}}}, ___} :> 
    Graph[{a \[UndirectedEdge] d, a \[UndirectedEdge] g}, 
     VertexLabels -> {a -> a, d -> d, g -> g}, EdgeWeight -> {c, f}, 
     ImagePadding -> 10, 
     EdgeLabels -> {{a \[UndirectedEdge] d -> 
         c}, {a \[UndirectedEdge] g -> f}}, ImageSize -> 500], {n, 1, 
   Length[lis] - 1}]

Taking union of all graphs, to create a tree,

graphunion = 
 GraphUnion[graphlist /. List -> Sequence, VertexLabels -> "Name", 
  ImagePadding -> 10]

To find the starting node, or the top most parent node,

stnode = First[
  First[Level[
     list, {1, 1}] /. {___, 
      s : {{a_, b_}, {c_, {{d_, e_}}}, {f_, {{g_, h_}}}}, ___} -> s]]

x44

Intermediate step,

lh1 =  FindShortestPath[graphunion, stnode, #] & /@ 
       VertexList[graphunion] /. 
      ruleslist //. {q___, {a_Symbol, d__}, w___} :> {q, {d}, w}

To generate code for all characters,

code = Select[Flatten[#], IntegerQ] & /@ lh1

{{1, 1, 0}, {0, 1, 1}, {1, 1, 1}, {0, 0, 0}, {1, 0}, {0, 1, 0, 0}, {0, 0, 1}, {0, 1, 0, 1}, {0, 1, 0}, {0, 0}, {0, 1}, {1, 1}, {0}, {1}, {}}

Symbols involved,

symbs = Last[Flatten[#]] & /@ lh1

Combining code with symbol,

cd = MapThread[
       List, {cod, symbs}] //. {s___, {a_, b_}, r___} :> {s, b -> a, r}

{a -> {1, 1, 0}, b -> {0, 1, 1}, e -> {1, 1, 1}, f -> {0, 0, 0}, h -> {1, 0}, q -> {0, 1, 0, 0}, t -> {0, 0, 1}, w -> {0, 1, 0, 1}, x38 -> {0, 1, 0}, x39 -> {0, 0}, x40 -> {0, 1}, x41 -> {1, 1}, x42 -> {0}, x43 -> {1}, x44 -> {}}

Applying rules on some string as example,

ToExpression[Characters["aheaheaaehebheahebafhtttwwbfbhfbhqhh"]] /. cd

{{1, 1, 0}, {1, 0}, {1, 1, 1}, {1, 1, 0}, {1, 0}, {1, 1, 1}, {1, 1, 0}, {1, 1, 0}, {1, 1, 1}, {1, 0}, {1, 1, 1}, {0, 1, 1}, {1, 0}, {1, 1, 1}, {1, 1, 0}, {1, 0}, {1, 1, 1}, {0, 1, 1}, {1, 1, 0}, {0, 0, 0}, {1, 0}, {0, 0, 1}, {0, 0, 1}, {0, 0, 1}, {0, 1, 0, 1}, {0, 1, 0, 1}, {0, 1, 1}, {0, 0, 0}, {0, 1, 1}, {1, 0}, {0, 0, 0}, {0, 1, 1}, {1, 0}, {0, 1, 0, 0}, {1, 0}, {1, 0}}