Updated 2011-07-10 22:24:11 by RLE ▲

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

Arts and crafts of Tcl-Tk programmingCategory Compression