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
}