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 Optimized 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 dimension06 Jan 2005 DPE - Fixed namespace export bug. Now works with package require.
package provide mediancut 1.0
namespace eval mediancut {
namespace export 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 colours (2 bit) mediancut::reduce $img $img2 2
See also
