Note that this is still very much a work-in-progress as I (DKF) am not putting much time into working on this. :^)
package req Tk
proc load {file} {
image create photo foo -file $file
set w [image width foo]
set h [image height foo]
# Construct basic RLE data from image (assumed monochrome)
set init 0
set length 0
set out [list $w $h]
set max [expr {$w>$h ? $w : $h}]
for {set x 0} {$x<$w} {incr x} {
for {set y 0} {$y<$h} {incr y} {
set item [expr {[lindex [foo get $x $y] 0] > 127}]
if {$item != $init} {
lappend out $length
if {$max < $length} {
set max $length
}
set init $item
set length 0
}
incr length
}
}
if {$max < $length} {
set max $length
}
lappend out $length
image delete foo
return [list $max $out]
}
proc compress {file} {
foreach {max data} [load $file] break
set bits [expr {(int(ceil(log($max)/log(2)))>>1) + 1}]
set limit [expr {1<<$bits}]
# If the chunk size doesn't fit in 4 bits, we're in trouble.
binary scan [binary format i $bits] b4 output
foreach val $data {
if {$val < $limit} {
binary scan [binary format i $val] b$bits binary
append output $binary
} else {
set v1 [expr {$val & ($limit-1)}]
set v2 [expr {$val >> $bits}]
binary scan [binary format i $v1] b$bits b1
binary scan [binary format i $v2] b$bits b2
append output $b1[string repeat 0 $bits]$b2
}
}
return [binary format b* $output]
}
proc gzip d {
set data [open foo.tmp w]
fconfigure $data -translation binary
puts -nonewline $data $d
close $data
set f [open "|gzip -c <foo.tmp" r]
fconfigure $f -translation binary
set d [read $f]
close $f
after 100 ;# Ugly hack to give gzip time to exit so we can kill foo.tmp on Windows
file delete foo.tmp
return $d
}
set files [lsort [glob *.gif]]
pack [text .t -font {courier 12} -height [expr {[llength $files]+1}]]
set w [font measure {Courier 12} "File: "]
foreach f $files {
set w2 [font measure {Courier 12} "[file tail $f] "]
if {$w2 > $w} {
set w $w2
}
}
.t conf -tab "$w left [expr $w+100]"
.t insert end "File:\tPrior\tPost\tgzipped\tTimings\n"
foreach f $files {
set t [time {set d [compress $f]}]
set d2 [gzip $d]
.t insert end "[file tail $f]\t[file size $f]\t[string length $d]\t[string length $d2]\t$t\n"
}[?]