Data commit

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

@@ -0,0 +1,53 @@
+package require Tcl 8.5
+package require struct::prioqueue
+
+proc huffmanEncode {str args} {
+    array set opts [concat -dump false $args]
+
+    set charcount [dict create]
+    foreach char [split $str ""] {
+        dict incr charcount $char
+    }
+
+    set pq [struct::prioqueue -dictionary] ;# want lower values to have higher priority
+    dict for {char count} $charcount {
+        $pq put $char $count
+    }
+
+    while {[$pq size] > 1} {
+        lassign [$pq peekpriority 2] p1 p2
+        $pq put [$pq get 2] [expr {$p1 + $p2}]
+    }
+
+    set encoding [walkTree [$pq get]]
+
+    if {$opts(-dump)} {
+        foreach {char huffCode} [lsort -index 1 -stride 2 -command compare $encoding] {
+            puts "$char\t[dict get $charcount $char]\t$huffCode"
+        }
+    }
+    $pq destroy
+
+    return $encoding
+}
+
+proc walkTree {tree {prefix ""}} {
+    if {[llength $tree] < 2} {
+        return [list $tree $prefix]
+    }
+    lassign $tree left right
+    return [concat [walkTree $left "${prefix}0"] [walkTree $right "${prefix}1"]]
+}
+
+proc compare {a b} {
+    if {[string length $a] < [string length $b]} {return -1}
+    if {[string length $a] > [string length $b]} {return  1}
+    return [string compare $a $b]
+}
+
+set str "this is an example for huffman encoding"
+
+set encoding [huffmanEncode $str -dump true]
+
+puts $str
+puts [string map $encoding $str]