if 0 {[Richard Suchenwirth] 2004-09-06 - Here's my take for the
[Binary image compression challenge], as proposed by [KBK].
It assumes that the colors of the
binary image are #000000 (black) and #FFFFFF (white), and
   * turns the pixels into a bitstream,
   * converts that to a sequence of positive runlengths
   * encodes those compactly with [Elias coding]
Results (compressed size in bytes, test runtime on my 200MHz box):
   * courier12.gif - 585 in 5.1 sec
   * times12i.gif - 586 in 4.9 sec
   * castle.gif - 9993 in 345 sec :(
   * ouster.gif - 1613 in 19.6 sec
   * cat.gif - will take a while...
}
 proc Elias'encode img {
    set h [image height $img]
    set w [image width  $img]
    set bits ""
    foreach row [$img data] {
        foreach pixel $row {
             append bits [string equal $pixel #000000]
        }
     }
     set runs [map strlen [split'runs $bits]]
     binary format ssb* $h $w [Elias'gammas $runs]
 }
 proc Elias'decode data {
    binary scan $data ssb* h w ebits
    set data {}
    set bit 1
    set bits ""
    foreach run [Elias'decode'gammas $ebits] {
        append bits [string repeat $bit $run]
        while {[string length $bits]>=$w} {
            lappend data [bits2cols [string range $bits 0 [expr {$w-1}]]]
            set bits [string range $bits $w end]
        }
        set bit [expr {!$bit}]
    }
    set img [image create photo -width $w -height $h]
    $img put $data -to 0 0
    set img
 }
 proc Elias'test img {
    set data [Elias'encode $img]
    set img2 [Elias'decode $data]
    if {[$img data] ne [$img2 data]} {error "result not equal"}
    image delete $img2
    string length $data
 }
 proc bits2cols bits {
    set res {}
    foreach bit [split $bits ""] {
        lappend res [expr {$bit? "#FFFFFF" : "#000000"}]
    }
    set res
 }
 proc map {fn list} {
    set res {}
    foreach e $list {lappend res [$fn $e]}
    set res
 }
 interp alias {} strlen {} string length ;# to make it a one-worder

 proc split'runs bits {
    string map {01 "0 1"} [string map {10 "1 0"} $bits]
 }
#-- See [Elias coding] for explanations on these functions
 proc Elias'gamma int {
    set bits [int2bits $int]
    return [string repeat 0 [expr {[string length $bits]-1}]]$bits
 }
 proc Elias'gammas ints {
    set res ""
    foreach int $ints {append res [Elias'gamma $int]}
    set res
 }
 proc Elias'decode'gammas bits {
    set res {}
    while {$bits ne ""} {
        regexp ^(0*) $bits -> zeroes
        set length [expr {[string length $zeroes]*2}]
        lappend res [bits2int [string range $bits 0 $length]]
        set bits [string range $bits [incr length] end]
    }
    set res
 }
 proc bits2int bits {
    set res 0
    foreach bit [split $bits ""] {set res [expr {$res*2+$bit}]}
    set res
 }
 proc int2bits int {
    set res ""
    while {$int>0} {
       set res [expr {$int%2}]$res
       set int [expr {$int/2}]
    }
    set res
 }

----
[Arts and crafts of Tcl-Tk programming]