proc analyze 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
 
     # Find the second color (assumes just two!)
     catch {
         foreach line $raw {
             foreach pix $line {
                 if {$pix ne $clr} {
                     set clr1 $pix
                     return; #double break
                 }
             }
         }
         set clr1 $clr0
     }
 
     # Compute a sequence of bytes encoding the color
     # transitions (bit 1 marks a transition)
     set mask 128
     set byte 0
     set bytes [list]
     foreach line $raw {
         foreach pix $line {
             if {$pix ne $clr} {
                 incr byte $mask
                 set clr $pix
             }
             if {$mask != 1} {
                 set mask [expr {$mask >> 1}]
             } else {
                 lappend bytes $byte
                 set byte 0
                 set mask 128
             }
         }
     }
     if {$mask!=128} {
         lappend bytes $byte
     }
 
     return [list $w $h $clr0 $clr1 $bytes]
 }
 
 proc stats nums {
     foreach num $nums {
         if {[info exists a($num)]} {
             incr a($num)
         } else {
             set a($num) 1
         }
     }
     set tally [list]
     foreach {num ct} [array get a] {
         lappend tally [list $num $ct]
     }
     lsort -decreasing -index 1 -integer $tally
     
 }
 
 proc encode img {
     foreach {w h clr0 clr1 bytes} [analyze $img] break
     set data [list $w $h]
     lappend data [expr {[string replace $clr0 0 0 0x]}]
     lappend data [expr {[string replace $clr1 0 0 0x]}]
 
     set tally [stats $bytes]
     set len [llength $tally]
     lappend data $len
 
     # Compute the map: the most frequent byte is encoded
     # as 1, the secondmost frequent as 2, ...
     set i 0
     foreach item $tally {
         set byte [lindex $item 0]
         set rmap($byte) [incr i]
         lappend data $byte
     }
 
     # Fibonacci-encode the byte sequence
     set toEnc [list]
     foreach byte $bytes {
         lappend toEnc $rmap($byte)
     }
     lappend data [fiboEncodeList $toEnc]
 
     # Convert the data stream to binary
     set clen [string repeat c $len]
     set cmd [linsert $data 0 binary format ssiii${clen}B*]
     return [eval $cmd]
 }
 
 proc decode bin {
     set empty [list]
     
     # Read the map and fibo sequence together, separate
     # them and convert the map to 0/1 strings.
     # Note that the map will be read with 1-based indices,
     # hence add a dummy 0-th value
 
     binary scan $bin ssiiiB* w h clr0 clr1 len fib
     set map [list *]
     set lim [expr {$len*8-1}]
     set bmap [string range $fib 0 $lim]
     set fib [string range $fib [incr lim] end]
     for {set i 0} {$i < $len} {incr i} {
         lappend map [string range $bmap 0 7]
         set bmap [string range $bmap 8 end]
     }
 
     # Decode the Fibonacci-encoded bits
     set fibData [fiboDecodeString $fib]
     set bits {}
     foreach num $fibData {
         append bits [lindex $map $num]
     }
     set bits [string range $bits 0 [expr {$w*$h-1}]]
     set fibdata {}
 
     # Regenerate the img data
     set clrs [list \#[format %06x $clr0] \#[format %06x $clr1]]
     set nclr 0
     set clr [lindex $clrs 0]
     set i 0
     set data $empty
     set line $empty
     foreach bit [split $bits {}] {
         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
         }
     }
 
     # Create the image
     set img [image create photo -width $w -height $h]
     $img put $data -to 0 0
     return $img
 }