[David Easton] ''2004-04-07''

Here is a package to reduce the colour depth of an image.

It uses the Optimised Median Cut algorithm.  This repeatedly subdivides colour space into smaller and smaller boxes.  Each colour in the new image represents the average of one of these boxes.

This is the algorithm:
   * Begin with a box that encloses the colour space used by all the pixels
   * For each new box:
   ** Sort enclosed points along the longest dimension (red, green or blue)
   ** Subdivide the points into two halves at the median point of the longest dimension

----
package provide mediancut 1.0
 
 namespace eval mediancut {
 }
 
 proc mediancut::reduce {src dest depth} {
 
     variable new
 
     set new(count) 0
 
     set w [image width $src]
     set h [image height $src]
 
     set pixList [list]
 
     for {set y 0} {$y < $h} {incr y} {
         for {set x 0} {$x < $w} {incr x} {
             
             lappend pixList [$src get $x $y]
         }
     }
 
     subdivide $pixList $depth
 
     apply $src $dest
 
     return $new(count)
 }
 
 proc mediancut::subdivide {pixList depth} {
     
     variable new
     
     set num [llength $pixList]
     
     for {set i 0} {$i < 256} {incr i} {
         set n(r,$i) 0
         set n(g,$i) 0
         set n(b,$i) 0
     }
     
     foreach pix $pixList {
         foreach {r g b} $pix break
         incr n(r,$r)
         incr n(g,$g)
         incr n(b,$b)
     }
     
     # Work out which colour has the widest range
     
     foreach col [list r g b] {
         
         set l($col) [list]
         
         for {set i 0} {$i < 256} {incr i} {
             
             if { $n($col,$i) != 0 } {
                 lappend l($col) $i
             }
         }
         
         set range($col) [expr {[lindex $l($col) end] - [lindex $l($col) 0]}]
     }
     
     if { $depth == 0 || ($range(r) == 0 && $range(g) == 0 && $range(b) == 0) } {
         
         # Average colours
         
         # puts "Average colour for $num pixels"
         # puts "Range: $range(r) $range(g) $range(b)"
         
         foreach col [list r g b] {
             set tot 0
             foreach entry $l($col) {
                 incr tot [expr {$n($col,$entry) * $entry}]
             }
             set av($col) [expr {$tot / $num}]
         }
         
         set newpixel [list $av(r) $av(g) $av(b)]
         set fpixel [format "#%02x%02x%02x" $av(r) $av(g) $av(b)]
         
         # puts "Colour: $newpixel"
         
         foreach entry $pixList {
             
             set new($entry) $fpixel
         }
         incr new(count)
         
     } else {
         
         # Find out which colour has the maximum range (green, red, blue in order of importance)
         set maxrange -1
         foreach col [list g r b] {
             
             if { $range($col) > $maxrange } {
                 set splitcol $col
                 set maxrange $range($col)
             }
         }
         
         # Now work out where to split it
         set thres [expr {$num / 2}]
         
         set pn 0
         set tn 0
         set pl [lindex $l($splitcol) 0]
         
         foreach tl $l($splitcol) {
             
             incr tn $n($splitcol,$tl)
             
             if { $tn > $thres } {
                 
                 if { $tn - $thres < $thres - $pn } {
                     set cutnum $tl
                 } else {
                     set cutnum $pl
                 }
                 break
             }
             
             set pn $tn
             set pl $tl
         }
         
         # puts "Need to split $splitcol at $cutnum"
         
         # Now split the pixels into the 2 lists
         
         set hiList [list]
         set loList [list]
         
         set i [lsearch [list r g b] $splitcol]
         foreach entry $pixList {
             if { [lindex $entry $i] <= $cutnum } {
                 lappend loList $entry
             } else {
                 lappend hiList $entry
             }
         }
         
         incr depth -1
         
         subdivide $loList $depth
         subdivide $hiList $depth
     }
 }
 
 proc mediancut::apply {src dest} {
     
     variable new
     
     set w [image width $src]
     set h [image height $src]
     $dest configure -width $w -height $h
     
     for {set y 0} {$y < $h} {incr y} {
         
         set row [list]
         
         for {set x 0} {$x < $w} {incr x} {
             
             lappend row $new([$src get $x $y])
         }
         $dest put -to 0 $y [list $row]
         update idletasks
     }
 }
----
'''Example'''

 # Create and pack a canvas
 pack [canvas .c] -expand true -fill both

 # Create image
 set img [image create photo -file image.jpg]
 .c create image 0 0 -anchor nw -image $img

 package require mediancut

 # Reduce the image to 256 colours (8 bit)
 mediancut::reduce $img $img 8
----

[Category Graphics]
|
[Category Image Processing]
|
[Category Example]