# 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
}# 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