# TITLE: 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. [http://mini.net/files/tkphotolab.jpg] 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 Edit/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 [eval concat $matrix] +]} 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)}}] 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" } 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 . {exec wish $argv0 &; exit} bind . {console show} loadImg aaa.jpg } ---- [Arts and crafts of Tcl-Tk programming]