[ulis], 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). [http://perso.wanadoo.fr/maurice.ulis/tcl/image1.png] [http://perso.wanadoo.fr/maurice.ulis/tcl/image2.png] [http://perso.wanadoo.fr/maurice.ulis/tcl/image3.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] [http://perso.wanadoo.fr/maurice.ulis/tcl/image7.png] [http://perso.wanadoo.fr/maurice.ulis/tcl/image-1.gif] [http://perso.wanadoo.fr/maurice.ulis/tcl/image-2.gif] [http://perso.wanadoo.fr/maurice.ulis/tcl/image-3.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] [http://perso.wanadoo.fr/maurice.ulis/tcl/image-7.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. ---- '''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]