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
Results (compressed size in bytes, test runtime on my 200MHz box):
Just for the record, I also tested Elias' delta coding, but it fared worse:
courier12: 615 times12i: 660 castle: 11173 ouster: 1774
This is intuitively explained by the fact that short runs (<16) are predominant in the sample images.
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
}