TkPhotoLab
if 0 {Richard Suchenwirth 2003-08-02 - This weekend I made another old wish come true - not only to read about image processing, but to try it hands-on. Tcl is not the fastest in heavy number-crunching, as needed when going over many thousands of pixels, but I wouldn't consider C for a fun project ;) So take your time, or get a real CPU. At least you can watch the progress, as the target image is updated after every row.
The demo UI shows two images, the original on the left, the processing result on the right. You can push the result to the left with Options/Accept. See the menus for what goodies I have supplied. But what most interested me were "convolutions", for which you can edit the matrix (fixed at 3x3 - slow enough..) and click "Apply" to run it over the input image. "C" to set the matrix to all zeroes.
Convolution is a technique where a target pixel is colored according to the sum of the product of a given matrix and its neighbors. As an example, the convolution matrix
1 1 1 1 1 1 1 1 1
colors the pixel in the middle with the average of itself and its eight neighbors, which will myopically blur the picture.
0 0 0 0 1 0 0 0 0
should just faithfully repeat the input picture. These
0 -1 0 -1 -1 -1 -1 5 -1 or: -1 9 -1 0 -1 0 -1 -1 -1
enhance {horizont,vertic}al edges, and make the image look "crispier". }
proc convolute {inimg outimg matrix} {
set w [image width $inimg]
set h [image height $inimg]
set matrix [normalize $matrix]
set shift [expr {[matsum $matrix]==0? 128: 0}]
set imat [photo2matrix $inimg]
for {set i 1} {$i<$h-1} {incr i} {
set row {}
for {set j 1} {$j<$w-1} {incr j} {
foreach var {rsum gsum bsum} {set $var 0.0}
set y [expr {$i-1}]
foreach k {0 1 2} {
set x [expr {$j-1}]
foreach l {0 1 2} {
if {[set fac [lindex $matrix $k $l]]} {
foreach {r g b} [lindex $imat $y $x] {}
set rsum [expr {$rsum + $r * $fac}]
set gsum [expr {$gsum + $g * $fac}]
set bsum [expr {$bsum + $b * $fac}]
}
incr x
}
incr y
}
if {$shift} {
set rsum [expr {$rsum + $shift}]
set gsum [expr {$gsum + $shift}]
set bsum [expr {$bsum + $shift}]
}
lappend row [rgb [clip $rsum] [clip $gsum] [clip $bsum]]
}
$outimg put [list $row] -to 1 $i
update idletasks
}
}
proc alias {name args} {eval [linsert $args 0 interp alias {} $name {}]}
alias rgb format #%02x%02x%02x
proc lambda {argl body} {K [set n [info level 0]] [proc $n $argl $body]}
proc K {a b} {set a}
proc clip x {expr {$x>255? 255: $x<0? 0: int($x)}}
proc photo2matrix image {
set w [image width $image]
set h [image height $image]
set res {}
for {set y 0} {$y<$h} {incr y} {
set row {}
for {set x 0} {$x<$w} {incr x} {
lappend row [$image get $x $y]
}
lappend res $row
}
set res
}
proc normalize matrix {
#-- make sure all matrix elements add up to 1.0
set sum [matsum $matrix]
if {$sum==0} {return $matrix} ;# no-op on zero sum
set res {}
foreach inrow $matrix {
set row {}
foreach el $inrow {lappend row [expr {1.0*$el/$sum}]}
lappend res $row
}
set res
}
proc matsum matrix {expr [join [join $matrix] +]}# The following routines could also be generified into one:
proc color2gray image {
set w [image width $image]
set h [image height $image]
for {set i 0} {$i<$h} {incr i} {
set row {}
for {set j 0} {$j<$w} {incr j} {
foreach {r g b} [$image get $j $i] break
set y [expr {int(0.299*$r + 0.587*$g + 0.114*$b)}]
lappend row [rgb $y $y $y]
}
$image put [list $row] -to 0 $i
update idletasks
}
}
proc color2gray2 image {
set i -1
foreach inrow [photo2matrix $image] {
set row {}
foreach pixel $inrow {
foreach {r g b} $pixel break
set y [expr {int(($r + $g + $b)/3.)}]
lappend row [rgb $y $y $y]
}
$image put [list $row] -to 0 [incr i]
update idletasks
}
}# An experiment in classifying graylevels into unreal colors:
proc gray2color image {
set i -1
set colors {black darkblue blue purple red orange yellow white}
set n [llength $colors]
foreach inrow [photo2matrix $image] {
set row {}
foreach pixel $inrow {
set index [expr {[lindex $pixel 0]*$n/256}]
lappend row [lindex $colors $index]
}
$image put [list $row] -to 0 [incr i]
update idletasks
}
}
proc grayWedge image {
$image blank
for {set i 0} {$i<256} {incr i} {
$image put [rgb $i $i $i] -to $i 0 [expr {$i+1}] 127
}
}if 0 {A number of algorithms are very similar, distinguished only by a few commands in the center. Hence I made them generic, and they take a function name that is applied to every pixel rgb, resp. a pair of pixel rgb's. They are instantiated by an alias that sets the function fancily as a lambda (see Lambda in Tcl):}
proc generic_1 {f target source} {
set w [image width $source]
set h [image height $source]
for {set i 0} {$i<$h} {incr i} {
set row {}
for {set j 0} {$j<$w} {incr j} {
foreach {r g b} [$source get $j $i] break
lappend row [rgb [$f $r] [$f $g] [$f $b]]
}
$target put [list $row] -to 0 $i
update idletasks
}
}
alias invert generic_1 [lambda x {expr {255-$x}}]
alias contrast+ generic_1 [lambda x {clip [expr {128+($x-128)*1.25}]}]
alias contrast- generic_1 [lambda x {clip [expr {128+($x-128)*0.8}]}]
proc generic_2 {f target with} {
set w [image width $target]
set h [image height $target]
for {set i 0} {$i<$h} {incr i} {
set row {}
for {set j 0} {$j<$w} {incr j} {
foreach {r g b} [$target get $j $i] break
foreach {r1 g1 b1} [$with get $j $i] break
lappend row [rgb [$f $r $r1] [$f $g $g1] [$f $b $b1]]
}
$target put [list $row] -to 0 $i
update idletasks
}
}
alias blend generic_2 [lambda {a b} {expr {($a+$b)/2}}]
alias difference generic_2 [lambda {a b} {expr {255-abs($a-$b)}}]if 0 {A histogram is a count of which color value occurred how often in the current image, separately for red, green and blue. For graylevel images, the displayed "curves" should exactly overlap, so you see only the blue dots that are drawn last.}
proc histogram {image {channel 0}} {
set w [image width $image]
set h [image height $image]
for {set i 0} {$i<256} {incr i} {set hist($i) 0}
for {set i 0} {$i<$h} {incr i} {
for {set j 0} {$j<$w} {incr j} {
incr hist([lindex [$image get $j $i] $channel])
}
}
set res {}
for {set i 0} {$i<256} {incr i} {lappend res $hist($i)}
set res
}
proc drawHistogram {target input} {
$target blank
set a [expr {6000./([image height $input]*[image width $input])}]
foreach color {red green blue} channel {0 1 2} {
set i -1
foreach val [histogram $input $channel] {
$target put $color -to [incr i] \
[clip [expr {int(128-$val*$a)}]]
}
update idletasks
}
}# Demo UI:
if {[file tail [info script]]==[file tail $argv0]} {
package require Img ;# for JPEG etc.
proc setFilter {w matrix} {
$w delete 1.0 end
foreach row $matrix {$w insert end [join $row \t]\n}
set ::info "Click 'Apply' to use this filter"
}
label .title -text TkPhotoLab -font {Helvetica 14 italic} -fg blue
label .( -text ( -font {Courier 32}
set txt [text .t -width 20 -height 3]
setFilter .t {{0 -1 0} {-1 5 -1} {0 -1 0}}
label .) -text ) -font {Courier 32}
button .c -text C -command {setFilter .t {{0 0 0} {0 0 0} {0 0 0}}}
grid .title .( .t .) .c -sticky news
button .apply -text Apply -command applyConv
grid x ^ ^ ^ .apply -sticky ew
grid [label .0 -textvar info] - - -sticky w
grid [label .1] - [label .2] - - -sticky new
proc loadImg {{fn ""}} {
if {$fn==""} {set fn [tk_getOpenFile]}
if {$fn != ""} {
cd [file dirname [file join [pwd] $fn]]
set ::im1 [image create photo -file $fn]
.1 config -image $::im1
set ::im2 [image create photo]
.2 config -image $::im2
$::im2 copy $::im1 -shrink
set ::info "Loaded image 1 from $fn"
}
}
proc saveImg {{fn ""}} {
if {$fn==""} {set fn [tk_getSaveFile]}
if {$fn != ""} {
$::im2 write $fn -format JPEG
set ::info "Saved image 2 to $fn"
}
}
proc applyConv {} {
set ::info "Convolution running, have patience..."
set t0 [clock clicks -milliseconds]
convolute $::im1 $::im2 [split [$::txt get 1.0 end] \n]
set dt [expr {([clock click -milliseconds]-$t0)/1000.}]
set ::info "Ready after $dt sec"
}if 0 {m+ is a little wrapper for simplified menu creation - see below for its use:}
proc m+ {head name {cmd ""}} {
if {![winfo exists .m.m$head]} {
.m add cascade -label $head -menu [menu .m.m$head -tearoff 0]
}
if [regexp ^-+$ $name] {
.m.m$head add separator
} else {.m.m$head add command -label $name -comm $cmd}
}
. config -menu [menu .m]
m+ File Open.. loadImg
m+ File Save.. saveImg
m+ File ---
m+ File Exit exit
m+ Edit Blend {blend $im2 $im1}
m+ Edit Difference {difference $im2 $im1}
m+ Edit ---
m+ Edit Negative {invert $im2 $im1}
m+ Edit Contrast+ {contrast+ $im2 $im1}
m+ Edit Contrast- {contrast- $im2 $im1}
m+ Edit ---
m+ Edit Graylevel {$im2 copy $im1 -shrink; color2gray $im2}
m+ Edit Graylevel2 {$im2 copy $im1 -shrink; color2gray2 $im2}
m+ Edit "Add Noise" {
generic_1 [lambda x {expr {rand()<.01? int(rand()*255):$x}}] $im2 $im1
}
m+ Edit gray2color {$im2 copy $im1 -shrink; gray2color $im2}
m+ Edit Octary {generic_1 [lambda x {expr {$x>127? 255:0}}] $im2 $im1}
m+ Edit ---
m+ Edit HoriMirror {$im2 copy $im1 -shrink -subsample -1 1}
m+ Edit VertMirror {$im2 copy $im1 -shrink -subsample 1 -1}
m+ Edit "Upside down" {$im2 copy $im1 -shrink -subsample -1 -1}
m+ Edit ---
m+ Edit "Zoom x 2" {$im2 copy $im1 -shrink -zoom 2}
m+ Edit "Zoom x 3" {$im2 copy $im1 -shrink -zoom 3}
m+ Options "Accept (1<-2)" {$im1 copy $im2 -shrink}
m+ Options ---
m+ Options "Gray wedge" {grayWedge $im2}
m+ Options Histogram {drawHistogram $im2 $im1}
m+ Filter Clear {setFilter .t {{0 0 0} {0 0 0} {0 0 0}}}
m+ Filter ---
m+ Filter Blur0 {setFilter .t {{1 1 1} {1 0 1} {1 1 1}}}
m+ Filter Blur1 {setFilter .t {{1 1 1} {1 1 1} {1 1 1}}}
m+ Filter Gauss2 {setFilter .t {{1 2 1} {2 4 2} {1 2 1}}}
m+ Filter ---
m+ Filter Laplace5 {setFilter .t {{0 -1 0} {-1 5 -1} {0 -1 0}}}
m+ Filter Laplace9 {setFilter .t {{-1 -1 -1} {-1 9 -1} {-1 -1 -1}}}
m+ Filter LaplaceX {setFilter .t {{1 -2 1} {-2 5 -2} {1 -2 1}}}
m+ Filter ---
m+ Filter Emboss {setFilter .t {{2 0 0} {0 -1 0} {0 0 -1}}}
m+ Filter HoriEdge {setFilter .t {{-1 -1 -1} {0 0 0} {1 1 1}}}
m+ Filter VertEdge {setFilter .t {{-1 0 1} {-1 0 1} {-1 0 1}}}
m+ Filter SobelH {setFilter .t {{1 2 1} {0 0 0} {-1 -2 -1}}}
m+ Filter SobelV {setFilter .t {{1 0 -1} {2 0 -2} {1 0 -1}}}
bind . <Escape> {exec wish $argv0 &; exit}
bind . <F1> {console show}
loadImg aaa.jpg
}See also Arts and crafts of Tcl-Tk programming