Adaptive huffman coding has the advantage over static coding that the entire dataset does not need to be known in advance and the dictionary does not need to be transmitted separately from the data.  It is also trickier to implement.

It would be wrong to call this implementation adaptive huffman coding because well, it isn't.  It is ''an'' adaptive encoding, but my tree
balancing routines are buggy and I've already spent enough time on this.  To make it a true huffman encoding, just fix balance-FGK or balance-V.

The performance is hideously slow - around 200 characters per second on my machine.  I think most of this is due to all the tree manipulation.

I intended to mate this code with the code in [LZW], but the combination works pretty badly, probably because of my lack of a good idea for encoding the higher-ordered symbols effeciently.

JR

    # this uses the tree data structure from tcllib
    package require struct
    
    namespace eval ::huffman {
    
        # reverse a string
        # This is used to store partial words in big-endian order.  
        # 'binary format' will only store bits starting at the msb or 
        # lsb of a word, so we do the formatting little-endian and reverse it
        proc reverse {str} {
            set rv {}
            foreach c [split $str ""] {
                set rv [linsert $rv 0 $c]
            }
            return [join $rv ""]
        }
    
        # some tree helper functions
    
        # create a tree and set up symbol->node and node->symbol arrays
        proc mktree {} {
            variable trees
            variable symbols
            set tree [::struct::tree]
            set trees(e0) root
            set symbols(root) e0
            $tree set root 0
            return $tree
        }
    
        # delete the tree and arrays
        proc deltree {tree} {
            variable trees
            variable symbols
            $tree destroy
            unset trees
            unset symbols
        }
    
        # given a node, find the bit path to that node from the root
        proc getpath {tree node} {
            set p {}
            while {$node != "root"} {
                append p [$tree index $node]
                set node [$tree parent $node]
            }
            return [reverse $p]
        }
    
        # 'tree swap' doesn't move child trees, so we move the two nodes
        # separately using this helper
        proc swap {tree node1 node2} {
            set np [$tree parent $node1]
            set ni [$tree index $node1]
            $tree move [$tree parent $node2] [$tree index $node2] $node1
            $tree move $np $ni $node2
        }
    
        # dump out the tree
        # for debugging
        proc dump-tree {tree} {
            variable symbols
            $tree walk root -type bfs -order pre -command {
              if {[info exists symbols(%n)]} {set sym $symbols(%n)} else {set sym "-"}
              puts "[string repeat "  " [%t depth %n]]%n($sym [%t get %n]): [%t children %n]"
            }
        }
    
        # increment weight of node, rebalance tree
        proc update-tree {tree node}  {
            balance-FGK $tree $node
        }
    
        # update the node weights and rebalance the tree
        # using algorithm FGK
        # not quite right, doesn't always find the correct sibling.
        proc balance-FGK {tree node}  {
            set cn $node
            while {$cn != "root"} {
                set next [$tree parent $cn]
                $tree set $cn [expr {[$tree get $cn]+1}]
                set sib [$tree next $cn]
                if {$sib == ""} {
                    # if we're at the end of a row then the next
                    # sibling is the start of the previous row.
                    # this works if the tree is only 2 deep, otherwise it's
                    # really wrong
                    set sib [$tree previous $next]
                }
                if {$sib != "" && [$tree get $cn] > [$tree get $sib]} {
                    swap $tree $cn $sib
                }
                set cn $next
            }
            # update root node
            $tree set $cn [expr {[$tree get $cn]+1}]
        }
        
        # update the node weights and rebalance the tree
        # using algorithm V
        # pretty much completely wrong
        proc balance-V {tree node} {
            # update the weights on the path to the added node
            set cn $node
            while {$cn != ""} {
                $tree set $cn [expr {[$tree get $cn]+1}]
                set cn [$tree parent $cn]
            }
    
            set pn {}
            # this is an attempt to walk the tree in 'implicit' order.
            # it doesn't work.
            $tree walk root -order post -type bfs -command {
              # if weight of current node is less than weight of previous node,
              # then swap 
              if {$pn != "" && [%t get %n] < [%t get $pn]} {
                swap %t %n $pn
              }
              set pn %n
            }
        }
    
        # encode symbol (char/integer) as bitstring
        # handle int range 0-2^11
        # the range is beyond 0-255 because this is intended to handle 
        # a LZW dictionary rather than just characters.
        # there's got to be a better way.
        # symbol is encoded as a length bit (0 = 8 bits, 1 = 11 bits)
        # followed by the data in big-endian order
        proc encsym {sym} {
            set ebs "" ;# encoded bit-string
            if {$sym < 256} {
                append ebs 0
                set si [binary format c $sym]
                binary scan $si B8 sv
                append ebs $sv
            } else {
                append ebs 1
                set si [binary format s $sym]
                # format in little-endian then reverse
                binary scan $si b11 sv
                append ebs [reverse $sv]
            }
            return $ebs
        }
    
        # decode the next symbol in the bitstring starting at index 'ind'
        # using the given tree
        # updates the tree 
        # returns the symbol and the new index
        proc getsym {tree bits ind} {
            variable symbols
            set n root
            set bl [llength $bits]
            while {![$tree isleaf $n] && $ind < $bl} {
                set n [lindex [$tree children $n] [lindex $bits $ind]]
                incr ind
            }
            if {$symbols($n) == "e0"} {
                # new symbol
                set lb [lindex $bits $ind] ;# length bit
                incr ind
                if {$lb == "0"} {
                    set sb [join [lrange $bits $ind [expr {$ind+7}]] ""]
                    incr ind 8
                    binary scan [binary format B8 $sb] c sym
                    # mask to keep result unsigned
                    set sym [expr {$sym & 0xff}]
                } else {
                    set sb [join [lrange $bits $ind [expr {$ind+10}]] ""]
                    incr ind 11
                    # reverse the bitstring and decode as little-endian
                    binary scan [binary format b11 [reverse $sb]] s sym
                    # mask to keep result unsigned
                    set sym [expr {$sym & 0x7ff}]
                }
                set symbols($n) $sym
            } else {
                set sym $symbols($n)
            }
            # add the symbol to the tree and/or update the tree
            addsym $tree $sym
            return [list $sym $ind]
        }
    
        # insert the symbol into the tree if it doesn't exist
        # update the tree and the mapping arrays
        # returns code for symbol
        proc addsym {tree sym} {
            variable trees
            variable symbols
            set rs {}
            if {![info exists trees($sym)]} {
                # if symbol doesn't exist: split e0 into new node and new e0
                append rs [getpath $tree $trees(e0)] [encsym $sym]
                set n $trees(e0)
                set trees($sym) [$tree insert $n 0]
                $tree set $trees($sym) 0
                set trees(e0) [$tree insert $n 1]
                $tree set $trees(e0) 0
                set symbols($trees($sym)) $sym
                set symbols($trees(e0)) e0
            } else {
                # symbol exists, just emit code and update
                append rs [getpath $tree $trees($sym)]
            }
            update-tree $tree $trees($sym)
            return $rs
        }
    
        # input is a list of integers 
        proc encode {rval} {
          set tree [mktree]
          set l [llength $rval]
          set c 0
          foreach rv $rval {
            append bs [addsym $tree $rv]
            incr c
            # progress meter
            puts -nonewline stderr [format "%3.2f%%\r" [expr {double($c)/$l*100}]]
          }
          deltree $tree
          return $bs
        }
    
        # decode bitstring into list of integers
        proc decode {bs} {
            set tree [mktree]
            set bits [split $bs ""]
            set ind 0
            set ds {}
            set bl [llength $bits]
            while {$ind < $bl} {
                set si [getsym $tree $bits $ind]
                lappend ds [lindex $si 0]
                set ind [lindex $si 1]
                # progress meter
                puts -nonewline stderr [format "%3.2f%%\r" [expr {double($ind)/$bl*100}]]
            }
            return $ds
        }
    }
    # end namespace eval ::huffman
    
    # convert string to list
    proc s2l {str} {
        set l {}
        foreach c [split $str ""] {
            binary scan $c c num
            lappend l $num
        }
        return $l
    }
    
    # convert list to string
    proc l2s {list} {
        set s ""
        foreach num $list {
            append s [binary format c $num]
        }
        return $s
    }
    
    # some testing
    set st "Hello, world!"
    # set st [read stdin]
    puts "input length: [string length $st] bytes"
    set cst [huffman::encode [s2l $st]]
    puts "compressed length: [expr {[string length $cst]/8}] (bytes) [format "%3.2f%%" [expr {(1-([string length $cst]/8)/double([string length $st]))*100}]]"
    set dst [l2s [huffman::decode $cst]]
    if {[string compare $dst $st] == 0} {
        puts "input and output match"
    } else {
        puts "input and output differ"
    }
----
[Category Compression]