Reducing the color depth of an image
ulis, 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-18: reduce2: a slightly slower but more baldy Leo respectful algorithm.
ulis: For a better result, please use the David Easton package: Reduce Colour Depth - Median Cut
Original images (~25600 colors)
Reduced images (256 colors)
reduce2 (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.)
DS - Very Useful, thanks.
The proc
namespace eval ::reduce \
{
namespace export reduce reduce2
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
}
# A slightly slower but more baldy Leo respectful algorithm
proc reduce2 {Image {max 256}} \
{
# get the image sizes
# ------------------------
set Width [image width $Image]
set Height [image height $Image]
if {$Width * $Height == 0} { error "bad image" }
# compute hexa patterns
# ------------------------
set patterns {0xfefefe 0xfcfcfc 0xf8f8f8 0xf0f0f0 0xe0e0e0}
# get image colors
# ------------------------
set Data1 [$Image data]
# loop to reduce the image
# ------------------------
for {set level 0} {$level < 5} {incr level} \
{
# get pattern
set pattern [lindex $patterns $level]
# get shades and crude colors
set Data2 {}
array unset colors *
array unset crudes *
array unset shades *
foreach row1 $Data1 \
{
set row2 {}
foreach pixel $row1 \
{
set colors($pixel) 1
set color [scan $pixel #%6x]
set crude [format #%06x [expr {$color & $pattern}]]
# append shade to crude color
if {$pixel != $crude} \
{
set crudes($crude) 1
set shades($crude:$pixel) 1
}
# save crude color
lappend row2 $crude
}
lappend Data2 $row2
}
set total [llength [array names colors]]
set crudescount [llength [array names crudes]]
# again?
if {$total <= $max} { break }
if {$crudescount >= $max} \
{
# more crude colors than needed, get them
set Data1 $Data2
continue
} \
else \
{
# sort crude colors by shades count
set counts {}
foreach crude [array names crudes] \
{
set count [llength [array names shades $crude:*]]
lappend counts [list $crude $count]
}
set counts [lsort -decreasing -integer -index 1 $counts]
# try to reduce the total by removing shades
set finests {}
foreach item $counts \
{
# add crude to list of candidates
set crude [lindex $item 0]
lappend finests $crude
# compute resulting shades total
incr total -[lindex $item 1]
# adjust if the crude color is a new color
if {![info exists colors($crude)]
&& ![info exists shades($crude:$crude)]} \
{ set colors($crude) 1; incr total }
# again?
if {$total <= $max} { break }
}
# remove the shades and count
array unset colors *
set Data2 {}
foreach row1 $Data1 \
{
set row2 {}
foreach pixel $row1 \
{
# compute the crude color
set color [scan $pixel #%6x]
set crude [format #%06x [expr {$color & $pattern}]]
# to be reduced?
if {$crude != $pixel && [lsearch -exact $finests $crude] > -1} \
{
# yes, replace the shade by the crude color
set pixel $crude
}
set colors($pixel) 1
lappend row2 $pixel
}
lappend Data2 $row2
}
set Data1 $Data2
set total [llength [array names colors]]
# again?
if {$total <= $max} { break }
}
}
if {$total > $max} { error "$max colors for $Image: can't do that!" }
# 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
ulis: The result of David Easton package (median cut) is better than reduce2.