June 2018 Update

Task/Huffman-coding/Lua/huffman-coding.lua

@@ -0,0 +1,73 @@
+local build_freqtable = function (data)
+  local freq = { }
+
+  for i = 1, #data do
+    local cur = string.sub (data, i, i)
+    local count = freq [cur] or 0
+    freq [cur] = count + 1
+  end
+
+  local nodes = { }
+  for w, f in next, freq do
+    nodes [#nodes + 1] = { word = w, freq = f }
+  end
+
+  table.sort (nodes, function (a, b) return a.freq > b.freq end) --- reverse order!
+
+  return nodes
+end
+
+local build_hufftree = function (nodes)
+  while true do
+    local n = #nodes
+    local left = nodes [n]
+    nodes [n] = nil
+
+    local right = nodes [n - 1]
+    nodes [n - 1] = nil
+
+    local new = { freq = left.freq + right.freq, left = left, right = right }
+
+    if n == 2 then return new end
+
+    --- insert new node at correct priority
+    local prio = 1
+    while prio < #nodes and nodes [prio].freq > new.freq do
+      prio = prio + 1
+    end
+    table.insert (nodes, prio, new)
+  end
+end
+
+local print_huffcodes do
+  local rec_build_huffcodes
+  rec_build_huffcodes = function (node, bits, acc)
+    if node.word == nil then
+      rec_build_huffcodes (node.left,  bits .. "0", acc)
+      rec_build_huffcodes (node.right, bits .. "1", acc)
+      return acc
+    else --- leaf
+      acc [#acc + 1] = { node.freq, node.word, bits }
+    end
+    return acc
+  end
+
+  print_huffcodes = function (root)
+    local codes = rec_build_huffcodes (root, "", { })
+    table.sort (codes, function (a, b) return a [1] < b [1] end)
+    print ("frequency\tword\thuffman code")
+    for i = 1, #codes do
+      print (string.format ("%9d\t‘%s’\t“%s”", table.unpack (codes [i])))
+    end
+  end
+end
+
+
+local huffcode = function (data)
+  local nodes = build_freqtable (data)
+  local huff = build_hufftree (nodes)
+  print_huffcodes (huff)
+  return 0
+end
+
+return huffcode "this is an example for huffman encoding"

Task/Huffman-coding/Perl-6/huffman-coding-2.pl6

@@ -9,3 +9,23 @@ sub huffman (%frequencies) {
     }
     @queue[0].value;
 }
+
+# Testing
+
+for huffman 'this is an example for huffman encoding'.comb.Bag {
+    say "'{.key}' : {.value}";
+}
+
+# To demonstrate that the table can do a round trip:
+
+say '';
+my $original = 'this is an example for huffman encoding';
+
+my %encode-key = huffman $original.comb.Bag;
+my %decode-key = %encode-key.invert;
+my @codes      = %decode-key.keys;
+
+my $encoded = $original.subst: /./,      { %encode-key{$_} }, :g;
+my $decoded = $encoded .subst: /@codes/, { %decode-key{$_} }, :g;
+
+.say for $original, $encoded, $decoded;

Task/Huffman-coding/REXX/huffman-coding.rexx

@@ -1,6 +1,7 @@
 /* REXX ---------------------------------------------------------------
 * 27.12.2013 Walter Pachl
 * 29.12.2013 -"- changed for test of s=xrange('00'x,'ff'x)
+* 14.03.2018 -"- use format instead of right to diagnose size poblems
 * Stem m contains eventually the following node data
 * m.i.0id Node id
 * m.i.0c  character
@@ -130,8 +131,8 @@ Do si=1 To 999 While sc<>''
       End
     End
   End
-Say 'Input ' s
-Say 'result' sr
+Say 'Input ="'s'"'
+Say 'result="'sr'"'
 
 Exit
 
@@ -139,10 +140,10 @@ show:
 /*---------------------------------------------------------------------
 * show all lines representing node data
 *--------------------------------------------------------------------*/
-Say ' i  pp id  c  f  l r d'
+Say '  i   pp  id   c   f   l r d'
 Do i=1 To m.0
-  Say right(i,2) right(m.i.0o,3) right(m.i.0id,2),
-          right(m.i.0f,2) right(m.i.0l,2) right(m.i.0r,2) m.i.0d m.i.0t
+  Say format(i,3) format(m.i.0o,4) format(m.i.0id,3),
+          format(m.i.0f,3) format(m.i.0l,3) format(m.i.0r,3) m.i.0d m.i.0t
   End
 Call dbg copies('-',21)
 Return

Task/Huffman-coding/Red/huffman-coding.red

@@ -0,0 +1,91 @@
+Red [file: %huffy.red]
+
+;; message to encode:
+msg: "this is an example for huffman encoding"
+
+;;map to collect leave knots  per uniq character of message
+m: make map! []	
+
+knot: make object! [
+	left: right: none    ;; pointer to left/right sibling
+	code: none        ;; first holds char for debugging, later binary code
+	count: depth: 1     ;;occurence of character - length of branch
+]
+
+;;-----------------------------------------
+set-code: func  ["recursive function to generate binary code sequence"
+			wknot
+			wcode [string!]] [
+;;-----------------------------------------
+	either wknot/left = none [
+		wknot/code:  wcode
+	] [
+		set-code wknot/left rejoin [wcode "1"]
+		set-code wknot/right rejoin [wcode "0"]
+	]
+]	;;-- end func
+
+;-------------------------------
+merge-2knots: func ["function to merge 2 knots into 1 new"
+	t [block!]][
+;-------------------------------
+	nknot: copy knot      ;; create new knot
+	nknot/count:  t/1/count + t/2/count
+	nknot/right: t/1
+	nknot/left: t/2
+	nknot/depth: t/1/depth + 1
+	tab: remove/part t 2	;; delete first 2 knots
+	insert t nknot  ;; insert new generated knot
+]	;;-- end func
+
+;; count occurence of characters, save in map: m
+foreach chr msg [
+	either k:  select/case m chr [
+			k/count: k/count + 1	
+	][
+		put/case m chr nknot: copy knot
+		nknot/code: chr
+	]
+]
+
+;; create sortable block (=tab) for use as prio queue
+foreach k  keys-of m [	append tab: []  :m/:k ]
+
+;; build tree
+while [ 1 <  length? tab][
+	sort/compare tab function [a b] [
+					a/count  <  b/count
+		  or (   a/count = b/count and ( a/depth > b/depth ) )
+	]
+	merge-2knots tab	;; merge 2 knots with lowest count / max depth
+]
+
+set-code tab/1 ""		;; generate binary codes, save at leave knot
+
+;;  display codes
+foreach k sort keys-of m [
+	print [k " = " m/:k/code]	
+	append codes: "" m/:k/code	
+]
+
+;; encode orig message string
+foreach chr msg [
+	k: select/case m chr
+	 append msg-new: ""   k/code
+]
+
+print [ "length of encoded msg "  length? msg-new]
+print [ "length of (binary) codes "  length? codes ]
+
+print ["orig. message: "  msg newline "encoded message: " "^/" msg-new]
+prin "decoded: "
+
+;; decode message (destructive! ):
+while [ not empty? msg-new ][
+  foreach [k v] body-of   m [
+    if  t: find/match msg-new v/code   [
+      prin k
+      msg-new: t
+    ]
+  ]
+ ]

Task/Huffman-coding/Tcl/huffman-coding.tcl

@@ -20,14 +20,13 @@ proc huffmanEncode {str args} {
     }
 
     set encoding [walkTree [$pq get]]
-    set map [dict create {*}[lreverse $encoding]]
 
     if {$opts(-dump)} {
-        foreach key [lsort -command compare [dict keys $map]] {
-            set char [dict get $map $key]
-            puts "$char\t[dict get $charcount $char]\t$key"
+        foreach {char huffCode} [lsort -index 1 -stride 2 -command compare $encoding] {
+            puts "$char\t[dict get $charcount $char]\t$huffCode"
         }
     }
+    $pq destroy
 
     return $encoding
 }