[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). Original images (~25600 colors) [http://perso.wanadoo.fr/maurice.ulis/tcl/image7.png] [http://perso.wanadoo.fr/maurice.ulis/tcl/image4.png] [http://perso.wanadoo.fr/maurice.ulis/tcl/image5.png] [http://perso.wanadoo.fr/maurice.ulis/tcl/image6.png] Reduced images (256 colors) [http://perso.wanadoo.fr/maurice.ulis/tcl/image-7.gif] [http://perso.wanadoo.fr/maurice.ulis/tcl/image-4.gif] [http://perso.wanadoo.fr/maurice.ulis/tcl/image-5.gif] [http://perso.wanadoo.fr/maurice.ulis/tcl/image-6.gif] ---- '''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.) ---- '''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 exit update } ---- '''See also''' * [Reduce Colour Depth - Median Cut] ---- [Category Graphics] | [Category Image Processing] | [Category Example]