Version 3 of Reducing the color depth of an image
Updated 2004-04-15 13:26:32ulis, In Shrinking an image, MG asked for a Tcl proc reducing the colors count of an image (to be able to make a gif file).
Original images (~25600 colors)
Reduced images (256 colors)
How it works?
It works by choosing the nearest crude color.
A crude color is a color where the least significant bits are set to zero, thus reducing the color depth.
A first pass makes all colors crude but not too heavily: If the colors map contains 2^24 colors (8/8/8) and should become 2^8 colors (3/3/2), the first pass makes it a 2^15 colors map (5/5/5) by 'cruding' each color.
A second pass counts the shades for each crude color and 'crudes' the more numerous shades.
MG - Very nice, and extremely useful. Thanks for sharing it :)
The proc
namespace eval ::reduce \
{
namespace export reduce
package require Tk
# the extraction of the data is inspired from DKF shrink3
proc reduce {Image {depth 8}} \
{
# get the image sizes
set Width [image width $Image]
set Height [image height $Image]
if {$Width * $Height == 0} { error "bad image" }
# compute hexa pattern & max palette
# ------------------------
set shift [expr {(8 - (($depth + 2) / 3)) - 2}]
if {$shift < 0} { set shift 0 }
set pattern1 0xf0f0f0; set pattern2 0xc0c0c0; set pattern3 0x808080
switch -- $shift \
{
0 { set pattern1 0xffffff; set pattern2 0xfcfcfc; set pattern3 0xf8f8f8 }
1 { set pattern1 0xfefefe; set pattern2 0xf8f8f8; set pattern3 0xf0f0f0 }
2 { set pattern1 0xfcfcfc; set pattern2 0xf0f0f0; set pattern3 0xe0e0e0 }
3 { set pattern1 0xf8f8f8; set pattern2 0xe0e0e0; set pattern3 0xc0c0c0 }
}
set max [expr {pow(2,$depth)}]
# compute a x/x/x new image
# ------------------------
foreach oldrow [$Image data] \
{
set row1 {}
set row2 {}
set row3 {}
foreach oldpixel $oldrow \
{
# compute new shade
set pixel1 [expr {[scan $oldpixel #%6x] & $pattern1}]
# save shade
set color1 [format #%06x $pixel1]
set shades($color1) 1
# compute crude colors
set pixel2 [expr {$pixel1 & $pattern2}]
set color2 [format #%06x $pixel2]
set pixel3 [expr {$pixel1 & $pattern3}]
set color3 [format #%06x $pixel3]
# append shade to crude color
if {$color2 != $color1} \
{
if {![info exists colors2($color2)]} \
{ lappend colors2($color2) $color1 } \
else \
{
if {[lsearch -exact $colors2($color2) $color1] == -1} \
{ lappend colors2($color2) $color1 } \
}
}
if {$color3 != $color1 && $color3 != $color2} \
{
if {![info exists colors3($color3)]} \
{ lappend colors3($color3) $color1 } \
else \
{
if {[lsearch -exact $colors3($color3) $color1] == -1} \
{ lappend colors3($color3) $color1 } \
}
}
lappend row1 $color1
lappend row2 $color2
lappend row3 $color3
}
lappend data1 $row1
lappend data2 $row2
lappend data3 $row3
}
# find the slightest shades
# ------------------------
# total count of shades
set total [llength [array names shades]]
# crude colors with count of shades
foreach color [array names colors2] \
{ lappend counts2 [list $color [llength $colors2($color)]] }
foreach color [array names colors3] \
{ lappend counts3 [list $color [llength $colors3($color)]] }
# sort colors by count of shades
set counts2 [lsort -decreasing -integer -index 1 $counts2]
set counts3 [lsort -decreasing -integer -index 1 $counts3]
# get the finest shades list
set finests2 {}
foreach item $counts2 \
{
if {$total < $max} { break }
set crude [lindex $item 0]
eval lappend finests2 $colors2($crude)
incr total -[lindex $item 1]
if {![info exists shades($crude)]} { incr total }
}
set finests3 {}
foreach item $counts3 \
{
if {$total < $max} { break }
set crude [lindex $item 0]
eval lappend finests3 $colors3($crude)
incr total -[lindex $item 1]
if {![info exists shades($crude)]} { incr total }
}
# suppress the slightest shades
# ------------------------
set y 0
foreach row $data1 \
{
set x 0
set row3 {}
foreach color $row \
{
if {[lsearch -exact $finests2 $color] != -1} \
{
# reduce
set crude [lindex $data2 $y $x]
lset data1 $y $x $crude
} \
elseif {[lsearch -exact $finests3 $color] != -1} \
{
# reduce
set crude [lindex $data3 $y $x]
lset data1 $y $x $crude
}
incr x
}
incr y
}
# create the new image
# ------------------------
set image [image create photo]
# fill the new image
$image put $data1
# return the new image
set ::count $total
return $image
}
}The demo
# to download the images:
# http://perso.wanadoo.fr/maurice.ulis/tcl/image1.png
# ...
# http://perso.wanadoo.fr/maurice.ulis/tcl/image7.png
package require Tk
package require Img
image create photo Photo -file image2.png
namespace import ::reduce::reduce
wm withdraw .
for {set n 1} {$n < 8} {incr n} \
{
set image [reduce [image create photo -file image$n.png]]
$image write image-$n.gif -format gif
toplevel .$n
wm title .$n "$::count"
canvas .$n.c -bd 0 -highlightt 0
.$n.c create image 0 0 -anchor nw -image $image
foreach {- - width height} [.$n.c bbox all] break
.$n.c config -width $width -height $height
pack .$n.c
bind .$n.c <Destroy> exit
update
}See also
Category Graphics | Category Image Processing | Category Example