Version 3 of Binary image compression challenge - mig's Entry

Updated 2004-09-04 02:15:17

This is similar to Jeff's non-compressing encoding at Binary image compression challenge.

The differences are:

• faster encoding - access the [$img data] in one go, instead of repeating [$img get] calls.
• it encodes changes in color, instead of encoding the color.

The second difference is expected to produce more zeros, and hence (maybe?) a file that compresses better even though it has the same length as Jeff's.

---

Results

• courier12.dif: 2163b (courier12.dif.gz: 660b) courier12.gif: 1923b
• times12i.dif: 1611b (times12i.dif.gz: 683b) times12i.gif: 1947b
• castle.dif: 15763b (castle.dif.gz: 10234b) castle.gif: 11598b

castle.dif has 80% nonzero bits, versus 69% in castle.jeff.

---

 #
 # Given an image, it returns an encoded binary string.
 #

 proc analyse img {
     set h [image height $img]
     set w [image width  $img]
     set raw [$img data]
     set clr0 [lindex [lindex $raw 0] 0]
     set clr $clr0
     set str {}

     catch {
         foreach line $raw {
             foreach pix $line {
                 if {$pix ne $clr} {
                     set clr1 $pix
                     return; #double break
                 }
             }
         }
         set clr1 $clr0
     }

     foreach line $raw {
         foreach pix $line {
             append str [expr {$pix ne $clr}]
             set clr $pix
         }
     }
     set clr0 [expr {[string replace $clr0 0 0 0x]}]
     set clr1 [expr {[string replace $clr1 0 0 0x]}]
     return [binary format ssiib* $w $h $clr0 $clr1 $str]
 }

 #
 # Given an encoded binary string, it returns an image.
 #

 proc synth {data} {
     binary scan $data ssiib* w h clr0 clr1 str
     set img [image create photo -width $w -height $h]

     set clr0 \#[format %06x $clr0]
     set clr1 \#[format %06x $clr1]

     set empty [list]
     set data $empty
     set line $empty

     set clrs [list $clr0 $clr1]
     set clr $clr0
     set nclr 0
     set i 0
     foreach bit [split $str {}] {
         if {$bit} {
             set nclr [expr {!$nclr}]
             set clr [lindex $clrs $nclr]
         }
         lappend line $clr
         if {[incr i] == $w} {
             lappend data $line
             set line $empty
             set i 0
         }
     }

     $img put $data -to 0 0
     return $img
 }