# 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
 
 }
if 0 {
----
}
# Demonstration script
 
# 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