Why? edit
I was interested to compare the histogram of a reduced image with the histogram of the original image.How it does? edit
The proc counts the occurrence of each color component (RGB) for all of the image colors.Proc edit
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
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 edit
# 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]
See also
