# # Interface for dith # Siome Klein Goldenstein # Time-stamp: <30 Jul 96 --- 11:53:35 siome> # # global variables # image size set glb_tx [image width original] set glb_ty [image height original] # bottom-left coordinates of image set glb_tx_1 [expr $glb_tx -1] set glb_ty_1 [expr $glb_ty -1] # corners of rectangle set glb_cor1 {0 0} set glb_cor2 [list [expr $glb_tx_1] [expr $glb_ty_1]] # size of "dith strip" set glb_dithsize 7 # widgets canvas .c -bd 2 -relief raised -width $glb_tx\ -height $glb_ty \ -scrollregion "0 0 $glb_tx_1 $glb_ty_1" frame .but -bd 2 -relief flat button .but.bye -text "Bye" -command "exit" button .but.sav -text "Save" -command "original write result.ppm -format PPM" button .but.dit -text "Dith" -command "dither" pack .c .but -side top -expand yes -fill x pack .but.bye .but.sav .but.dit -side left -expand yes -fill x # some initialization and event bindings .c create image 0 0 -anchor nw -image original -tags "image" bind .c <Button-1> "firstcorner %x %y" bind .c <B1-Motion> "moving %x %y" bind .c <ButtonRelease-1> "secondcorner %x %y" bind .c <Button-2> "clearrec" # the procedures proc firstcorner {xi yi} { global glb_cor1 global glb_message global glb_dithsize set glb_cor1 [list [expr round([.c canvasx $xi])] \ [expr round([.c canvasy $yi $glb_dithsize])]] .c delete selrec } proc moving {xm ym} { global glb_cor1 global glb_cor2 global glb_tx global glb_ty global glb_dithsize set x [expr round([.c canvasx $xm])] set y [expr round([.c canvasy $ym $glb_dithsize])] if { $x >= 0 && $x < $glb_tx && $y >= 0 && $y < $glb_ty } { .c delete selrec .c create rectangle [lindex $glb_cor1 0] [lindex $glb_cor1 1] \ $x $y -outline red -tags selrec set glb_cor2 [list $x $y] } } proc secondcorner {xf yf} { global glb_cor1 global glb_cor2 global glb_tx global glb_ty global glb_dithsize set x [expr round([.c canvasx $xf])] set y [expr round([.c canvasy $yf $glb_dithsize])] if { $x >= 0 && $x < $glb_tx && $y >= 0 && $y < $glb_ty } { .c delete selrec set glb_cor2 [list $x $y] .c create rectangle [lindex $glb_cor1 0] [lindex $glb_cor1 1] \ $x $y -outline red -tags selrec } } proc clearrec {} { global glb_cor1 global glb_cor2 global glb_tx_1 global glb_ty_1 .c delete selrec set glb_cor1 [list 0 0] set glb_cor2 [list $glb_tx_1 $glb_ty_1] } proc dither {} { global glb_cor1 global glb_cor2 global glb_dithsize set p1x [lindex $glb_cor1 0] set p1y [lindex $glb_cor1 1] set p2x [lindex $glb_cor2 0] set p2y [lindex $glb_cor2 1] # make sure corner 1 is upper left one if {$p1x > $p2x} { set tmp $p2x; set p2x $p1x; set p1x $tmp } if {$p1y > $p2y} { set tmp $p2y; set p2y $p1y; set p1y $tmp } # so that image copy include last row and column incr p2x; incr p2y # create an temportary image, so that the C routine will always # work on all the image image create photo todither todither copy original -from $p1x $p1y $p2x $p2y CDith todither $glb_dithsize # The C routine could write directly to the original image, but # I found this way more robust. original copy todither -to $p1x $p1y # erase tmp image, otherwise if the next rectangle is smaller its # size wouldn't shrink image delete todither .c delete selrec }