Listing 2
#
# 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
}
Copyright © 1994 - 2018 Linux Journal. All rights reserved.