[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.

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]

reduce2 (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 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'''

   * [Reduce Colour Depth - Median Cut]

----

[Category Graphics] | [Category Image Processing] | [Category Example]