Version 6 of Reducing the color depth of an image
Updated 2004-04-16 16:06:22ulis, In Shrinking an image, MPJ asked for a Tcl proc reducing the colors count of an image (to be able to make a gif file).
2004-04-16: Added sweetness parameter. Increasing the sweetness helps to obtain better results when a color dominates. At the price of a longer wait.
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 :)
DKF: Very cool stuff. Of course, the next thing to think about is using dithering. There, you spread the mistakes made in shading one pixel into the surrounding pixels. This would help a lot with the lion's mane (as it turns out, the other images aren't too badly damaged by the process on this page.)
ulis: Increasing the sweetness to 3 would give a far better result for the lion.
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}} \
{
# sweetness parameter
set sweetness 2
# 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)) - $sweetness}]
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