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

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

Use:
 mediancut::reduce <src> <dest> <bits>
where:
 <src>   is a source image
 <dest>  is a destination image (that may be the same as the source image)
 <bits>  is the colour depth in bits (i.e. use 8 for 256 colours)

An image containing more than 256 colours must be reduced to 8-bit (256 colours) before it can be saved as a GIF image.  This provides a method for doing that.

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:
   .1 Sort enclosed points along the longest dimension (red, green or blue)
   .2 Subdivide the points into two halves at the median point of the longest dimension

----
 package provide mediancut 1.0
 
 namespace eval mediancut {
     namespace export mediancut::reduce
 }
 
 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 source image
 set img [image create photo -file image.jpg]
 .c create image 0 0 -anchor nw -image $img

 # Create destination image
 set img2 [image create photo]
 $img2 blank

 set h [image height $img]
 .c create image 0 $h -anchor nw -image $img2

 package require mediancut

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

 # Reduce the image to 16 colours (4 bit)
 mediancut::reduce $img $img2 4

 # Reduce the image to 4 colouts (2 bit)
 mediancut::reduce $img $img2 2
----

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