Version 0 of Colors histogram

ulis A proc to display or export the colors histogram of an image.

How it does?

The proc counts the occurrence of each color component (RGB) for all of the image colors.

Proc

  namespace eval ::histo \
  {
    namespace export histo

    package require Tk

    proc histo {image {cmd -display}} \
    {
      # get options
      switch -glob -- $cmd \
      {
        -dis*   { set cmd -display }
        -exp*   { set cmd -export }
        default \
        { error "use\n\t[histo image ?-display|-export?" }
      }
      # get the image size
      set width [image width $image]
      set height [image height $image]
      if {$width * $height == 0} { error "bad image" }
      # count colors components
      for {set i 0} {$i < 256} {incr i} \
      { foreach c {r g b} { set counts($c:$i) 0 } }
      set max 0
      set pixels {}
      for {set y 0} {$y < $height} {incr y} \
      {
        for {set x 0} {$x < $width} {incr x} \
        {
          foreach {r g b} [$image get $x $y] break
          foreach c {r g b} \
          { 
            set n [incr counts($c:[set $c])] 
            if {$max < $n} { set max $n }
          }
        }
      }
      if {$cmd == "-display"} \
      {
      # display
        # compute the coef
        set coef [expr {256.0 / $max}]
        # create toplevel
        set t _$image
        toplevel .$t
        wm title .$t $image
        # draw the histogram
        set c .$t.c
        canvas $c -width [expr {256 * 3 + 40}] -height [expr {256 + 40}]
        set x0 9
        set y0 267
        $c create rectangle $x0 9 [incr x0 258] $y0 -outline black -fill white
        incr x0 8
        $c create rectangle $x0 9 [incr x0 258] $y0 -outline black -fill white
        incr x0 8
        $c create rectangle $x0 9 [incr x0 258] $y0 -outline black -fill white
        set y1 272
        set x0 10
        for {set i 0} {$i < 17} {incr i} \
        {
          $c create line $x0 $y0 $x0 $y1
          incr x0 16
        }
        set x0 276
        for {set i 0} {$i < 17} {incr i} \
        {
          $c create line $x0 $y0 $x0 $y1
          incr x0 16
        }
        set x0 542
        for {set i 0} {$i < 17} {incr i} \
        {
          $c create line $x0 $y0 $x0 $y1
          incr x0 16
        }
        incr y0 -1
        set xr 10
        set xg 276
        set xb 542
        for {set i 0} {$i < 256} {incr i} \
        {
          set yr [expr {10 + 256 - round($counts(r:$i) * $coef)}]
          set yg [expr {10 + 256 - round($counts(g:$i) * $coef)}]
          set yb [expr {10 + 256 - round($counts(b:$i) * $coef)}]
          $c create line $xr $y0 $xr $yr -fill red
          $c create line $xg $y0 $xg $yg -fill green
          $c create line $xb $y0 $xb $yb -fill blue
          incr xr; incr xg; incr xb
        }
        $c create text 10 276 -anchor nw -text "image: $image, max count: $max"
        pack $c
      } \
      else \
      {
      # export
        for {set i 0} {$i < 256} {incr i} \
        { foreach c {r g b} { lappend list$c $counts($c:$i) } }
        return [list $listr $listg $listb]
      }
    }
  }

Demo

  # example
  # -----------
  # to download the image:
  # http://perso.wanadoo.fr/maurice.ulis/tcl/image1.png

  package require Tk
  package require Img
  wm withdraw .
  namespace import ::histo::histo
  histo [image create photo -file image1.png]