Binary image compression challenge - KBK's entry

# This is KBK's entry to RS's binary image compression challenge. There's an overview on the binary image compression challenge page that describes how it works.

# Format a number in binary with a specific count of bits.

 proc bits { code n } {
     set s {}
     while { [incr n -1] >= 0 } {
         if { $code & ( 1 << $n ) } {
             append s 1
         } else {
             append s 0
         }
     }
     return $s
 }

# Build the table for Huffman coding of the run lengths. Note that 0 and 127 are inserted into the sequence so that they get short codes, to allow for efficient compression of large areas of whitespace

 proc initHuffTable {} {
     variable ctable
     variable dtable
     set l { 1 2 3 4 5 6 7 8 0 9 10 11 127 }
     for { set i 12 } { $i < 127 } { incr i } { lappend l $i }
     set n 2
     set code 0
     set x { 1 2 3 5 4 3 4 9 12 21 96 }
     set y 2
     foreach i $l {
         set h($i) [bits $code $n]
         incr code
         if { [incr y -1] == 0 } {
             set y [lindex $x 0]
             set x [lrange $x 1 end]
             incr code $code
             incr n
         }
     }
     set ctable {}
     for { set i 0 } { $i < 128 } { incr i } {
         lappend ctable $h($i)
         set dtable($h($i)) $i
     }
 }
 initHuffTable

# Procedure to run-length encode a string of bits, represented as the characters '0' and '1'. Returns the RLE string, Huffman compressed

 proc compress { bitstring } {
     variable ctable
     set l 0
     set n 0
     set m 0
     set r {}
     foreach b [split $bitstring {}] {
         if { $b == $l && $n < 127 } {
             incr n
         } else {
             if { [info exists count($n)] } {
                 incr count($n)
             } else {
                 set count($n) 1
             }
             lappend r $n
             if { $b == $l } {
                 lappend r 0
                 if { [info exists count(0)] } {
                     incr count(0)
                 } else {
                     set count(0) 1
                 }
             }
             set n 1
             set l $b
         }
     }
     if { [info exists count($n)] } {
         incr count($n)
     } else {
         set count($n) 1
     }
     if { $n > $m } {
         set m $n
     }
     lappend r $n
     set total 0
     foreach { len cnt } [array get count] {
         incr total [expr {$len * $cnt}]
     }
     set bits {}
     foreach run $r {
         append bits [lindex $ctable $run]
     }
     return $bits
 }

# Decompress a bit string compressed by 'compress'. Returns the original bit string

 proc decompress { bits } {
     variable dtable
     set s {}
     set result {}
     set x 0
     foreach b [split $bits {}] {
         append s $b
         if { [info exists dtable($s)] } {
             for { set i $dtable($s) } { $i > 0 } { incr i -1 } {
                 append result $x
             }
             set x [expr { ! $x }]
             set s {}
         }
     }
     return $result
 }

# Procedure that walks the Hilbert curve given its order, the width and height of the region of interest, the starting x and y coordinates, a direction (n, s, e, w) of motion, and a callback to execute for each point.

 proc hilbert { order w h startx starty dir callback } {
     if { $startx > $w || $starty > $h } return
     if { $order == 0 } {
         set cmd $callback; lappend cmd $w $h $startx $starty; eval $cmd
     } else {
         incr order -1
         set delta [expr { 1 << $order }]
         set nextx [expr { $startx + $delta }]
         set nexty [expr { $starty + $delta }]
         switch -exact -- $dir {
             e {
                 hilbert $order $w $h $startx $starty n $callback
                 hilbert $order $w $h $startx $nexty e $callback
                 hilbert $order $w $h $nextx $nexty e $callback
                 hilbert $order $w $h $nextx $starty s $callback
             }
             n {
                 hilbert $order $w $h $startx $starty e $callback
                 hilbert $order $w $h $nextx $starty n $callback
                 hilbert $order $w $h $nextx $nexty n $callback
                 hilbert $order $w $h $startx $nexty w $callback
             }
             s {
                 hilbert $order $w $h $nextx $nexty w $callback
                 hilbert $order $w $h $startx $nexty s $callback
                 hilbert $order $w $h $startx $starty s $callback
                 hilbert $order $w $h $nextx $starty e $callback
             }
             w {
                 hilbert $order $w $h $nextx $nexty s $callback
                 hilbert $order $w $h $nextx $starty w $callback
                 hilbert $order $w $h $startx $starty w $callback
                 hilbert $order $w $h $startx $nexty n $callback
             }
         }
     }
 }

# Callback for the 'hilbert' procedure when compressing an image. It accepts the image, the width and height, and the x and y coordinates on the Hilbert curve

 proc compressCallback { image w h x y } {
     variable bitstring
     if { $x < $w && $y < $h } {
         set d [$image get $x $y]
         if { [lindex $d 0] || [lindex $d 1] || [lindex $d 2] } {
             append bitstring 1
         } else {
             append bitstring 0
         }
     }
 }

# Callback for the 'hilbert' procedure when decompressing. It accepts the image, the width and height, and the x and y coordinates on the Hilbert curve.

 proc decompressCallback { image bitstring w h x y } {
     variable bitIndex
     if { $x < $w && $y < $h } {
         if { [string index $bitstring $bitIndex] } {
             $image put \#ffffff -to $x $y
         } else {
             $image put \#000000 -to $x $y
         }
         incr bitIndex
     }
 }

# Compress a black-and-white GIF image

 proc kbk'compressImage { image } {
 
     variable bitstring
 
     set order 0
     for { set n 1 } \
         { $n < [image width $image] || $n < [image height $image] } \
         { incr n $n } {
             incr order
         }
     
     set bitstring {}
     set w [image width $image]
     set h [image height $image]
     hilbert $order $w $h 0 0 e [list compressCallback $image]
 
     set rdata [compress $bitstring]
 
     return [binary format ssb* \
                 [image width $image] [image height $image] $rdata]
 }

# Decompress a black-and-white GIF image

 proc kbk'decompressImage { saveData } {
 
     variable bitIndex
     
     binary scan $saveData ssb* wd ht rdata
 
     set order 0
     for { set n 1 } { $n < $wd || $n < $ht } { incr n $n } {
         incr order
     }
     
     set bs2 [decompress $rdata]
     set bitIndex 0
 
     set image2 [image create photo -width $wd -height $ht]
     hilbert $order $wd $ht 0 0 e [list decompressCallback $image2 $bs2]
     return $image2
 
 }

  • A demonstration script follows.

# Process an image

 proc process { f image } {
     set bs [kbk'compressImage $image]
     puts [list $f : [string length $bs] bytes]
     set newImage [kbk'decompressImage $bs]
     return $newImage
 }
 
 grid [button .n -text Next -command { set done 1 }] -sticky ew
 grid [label .l1]
 grid [label .l2]
 foreach f [glob *.gif] {
     set input [image create photo -file $f]
     .l1 configure -image $input
     set output [process $f $input]
     .l2 configure -image $output
     vwait done
     rename $input {}
     rename $output {}
 }
 exit