54 lines
1.3 KiB
Tcl
54 lines
1.3 KiB
Tcl
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]
|