Updated 2013-03-05 02:29:28 by pooryorick

Summary  edit

Richard Suchenwirth 2004-09-06: Here's my take for the Binary image compression challenge, as proposed by KBK.

Description  edit

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 (gamma)

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 - 18633 in 45 minutes :(

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
}