# Generate encoding from nested list

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.

-
I recommend reading the relevant part of David Wagner's book on Mathematica programming, where he considers Huffman encoding in detail. The book is available for free as a pdf download, search for it on this site. Whatever partial answers are likely to be posted here, will probably be inferior to his excellent exposition of this topic. – Leonid Shifrin Feb 22 '14 at 15:58
@LeonidShifrin : Leo thanks for link, I found it and its indeed good. But I think I would like to keep question open too see some more good answers, specially how someone could manipulate this list using recursions or patterns to arrive at result. Thanks again :) – Rorschach Feb 22 '14 at 16:23

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},
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",


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}}

-