1 #*************************************************************************
3 #* NAME : imagepp.tcl * PROJECT : MARACAS *
4 #* AUTHOR : Leonardo Flórez/Kyron * TYPE : TCL/TK widget def. *
5 #* VERSION : v1.0 * CREATION : 06/05/2001 *
6 #* LANGUAGE : TCL * REVISION : 16/07/2001 *
8 #*************************************************************************
10 #* Description : This file defines a new TCL/TK widget that allows the *
11 #* user to work with an image, it's a viewer. It has a *
12 #* dinamical scroll bar, so, don't worry about use one. *
14 #* The basic use of this widget is: *
16 #* 1. Create a new widget: "imagepp <name> <options>" *
17 #* Options given are a list of '-<option> <value>' pairs. *
18 #* Supported options are: *
19 #* +-----------------+--------------------------------------+ *
20 #* | OPTION | DESCRIPTION | *
21 #* +-----------------+--------------------------------------+ *
22 #* | -background | Background color. | *
23 #* | -borderwidth | Border width. | *
24 #* | -height | Height. | *
25 #* +-----------------+--------------------------------------+ *
26 #* | -initialroi | Initial Region Of Interest. | *
27 #* | -relief | Relief. | *
28 #* | -takefocus | Take focus? | *
29 #* +-----------------+--------------------------------------+ *
30 #* | -width | Width | *
31 #* +-----------------+--------------------------------------+ *
33 #* 2. Pack this new widget in your hierarchy: *
34 #* (pack/place/grid) <name> <pack options> *
36 #* 3. Interact with the new widget by using their sub-commands *
37 #* interface. Sub-commands defined are: *
38 #* add , addtext, cget, clean, configure, delete, *
39 #* find, getprofildata, resetroi, roi, show, *
40 #* setlinear, setarea, setnone. *
42 #* 4. Optional: use the <<AfterProfil>> event definition to *
43 #* grab mouse interaction. Mouse events supported are: *
46 #*************************************************************************
51 #*************************************************************************
54 #* (NOTE: Please, don't let this file became a mess. ;-) ) *
56 #* +------------+----------------+-------------------------------------+ *
57 #* | DATE | AUTHOR | DESCRIPTION | *
58 #* +------------+----------------+-------------------------------------+ *
59 #* | 06/05/2001 | Kyron | Initial implementation. | *
60 #* +------------+----------------+-------------------------------------+ *
61 #* | 16/07/2001 | Kyron | Documentation & conflicts revision. | *
62 #* +------------+----------------+-------------------------------------+ *
64 #*************************************************************************
66 package require Tk 8.0
68 #* NAMESPACE DESCRIPTION *************************************************
70 #* ::imagepp (namespace) *
72 #* DESCRIPTION : Global namespace that contains all imagepp widgets in *
73 #* current interpreter (actual TCL work instance). *
78 #* EXPORTS : proc imagepp { name options } *
81 #* Namespace components : *
82 #* widgetOptions : list. List of supported options. *
83 #* widgetCommands : list. List of supported sub-commands. *
85 #******************************************************* END DESCRIPTION *
86 package provide imagepp 1.0
87 namespace eval ::imagepp {
90 namespace export imagepp
93 variable widgetOptions
94 variable widgetCommands
98 #* PROCEDURE DESCRIPTION *************************************************
100 #* ::imagepp::imagepp (procedure) *
102 #* DESCRIPTION : Creator of new widgets. Call it in an TK hierarchy *
103 #* creation process. *
105 #* SYNTAX : imagepp <name> -<option1> <value1> ... -<optionn> <valuen> *
107 #* RETURN : New widget name, if success. *
110 #* name : string. Name for the new widget. To use it in a TK widget *
111 #* hierarchy, this name should be ".<f1>.<f2>...<n>" *
113 #******************************************************* END DESCRIPTION *
114 proc ::imagepp::imagepp { name args } {
116 # Namespace variables used in this procedure
117 upvar ::imagepp::widgetOptions widgetOptions
119 # If global namespace doesn't exists yet then initialize it
120 if { ![ info exists widgetOptions ] } initImagePP
122 # Given name exists?. If so, raise an error and finish
123 if { [ winfo exists $name ] } {
124 error "Widget \"$name\" already exists."
127 # Create the new command and return success
128 set name [ eval ::imagepp::buildImagePP $name $args ]
133 #* PROCEDURE DESCRIPTION *************************************************
135 #* ::imagepp::initImagePP (procedure) *
137 #* DESCRIPTION : Initializes the class manager, i.e., creates the global *
139 #* This is a dummy proc, don't call it in your code. *
141 #* SYNTAX : ::imagepp::initImagePP *
148 #******************************************************* END DESCRIPTION *
149 proc ::imagepp::initImagePP { } {
151 # Namespace variables used in this procedure
152 upvar ::imagepp::widgetOptions widgetOptions
153 upvar ::imagepp::widgetCommands widgetCommands
155 # All posible options for the widget
156 array set widgetOptions [ list \
157 -background { background Background } \
158 -borderwidth { borderWidth BorderWidth } \
159 -height { height Height } \
160 -initialroi { initialROI InitialROI } \
161 -relief { relief Relief } \
162 -takefocus { takeFocus TakeFocus } \
163 -width { width Width } \
166 # All posible commands for the widget
167 set widgetCommands [ list \
168 add addtext cget clean \
169 configure delete find getprofildata \
170 resetroi roi show setlinear \
174 event add <<AfterProfil>> \
178 # Default initialization... only if Tk exists
179 if { [ lsearch -exact [ package names ] "Tk" ] != -1 } {
181 option add *ImagePP.background #c0c0c0 widgetDefault
182 option add *ImagePP.borderWidth 0 widgetDefault
183 option add *ImagePP.height 100 widgetDefault
184 option add *ImagePP.initialROI "-1 -1 -1 -1" widgetDefault
185 option add *ImagePP.relief flat widgetDefault
186 option add *ImagePP.takeFocus 0 widgetDefault
187 option add *ImagePP.width 100 widgetDefault
191 # set global bindings
192 ::imagepp::setClassImagePPBindings
196 #* PROCEDURE DESCRIPTION *************************************************
198 #* ::imagepp::setClassImagePPBindings (procedure) *
200 #* DESCRIPTION : Default namespace bindings. *
201 #* This is a dummy proc, don't call it in your code. *
203 #* SYNTAX : ::imagepp::setClassImagePPBindings *
210 #******************************************************* END DESCRIPTION *
211 proc ::imagepp::setClassImagePPBindings { } {
213 bind ImagePP <Destroy> [ list ::imagepp::imagePPDestroyHandler %W ]
217 #* PROCEDURE DESCRIPTION *************************************************
219 #* ::imagepp::buildImagePP (procedure) *
221 #* DESCRIPTION : This does all of the work necessary to create a basic *
222 #* imagepp widget. Creates a new command (widget) with *
223 #* the given name. Also creates a new namespace as a child *
224 #* namespace of ::imagepp. *
225 #* This is a dummy proc, don't call it in your code. *
227 #* SYNTAX : set wname [ ::imagepp::buildImagePP $name $options ] *
229 #* RETURN : New widget hierarchy name *
232 #* w : string. New widget name. *
233 #* args : list. Option/value pairs list. *
235 #******************************************************* END DESCRIPTION *
236 proc ::imagepp::buildImagePP { w args } {
238 variable widgetOptions
241 namespace eval ::imagepp::$w {
257 # import variables, for programming facilities
258 upvar ::imagepp::${w}::widgets widgets
259 upvar ::imagepp::${w}::options options
261 # definition of TK widgets...
262 set widgets(this) [ frame $w -class ImagePP \
267 set widgets(canvas) [ canvas $w.canvas -takefocus 1 ]
270 set widgets(profildata) ""
271 set widgets(movingroi) 0
273 # set all the default values...
274 foreach name [ array names widgetOptions ] {
276 set optName [ lindex $widgetOptions($name) 0 ]
277 set optClass [ lindex $widgetOptions($name) 1 ]
278 set value [ option get $w $optName $optClass ]
279 set options($name) $value
284 if { [ llength $args ] > 0 } { array set options $args }
286 # move the name to imagepp class' namespace...
287 set widgets(frame) ::imagepp::${w}::$w
288 rename ::$w $widgets(frame)
290 # set canvas options...
291 $widgets(canvas) configure -background $options(-background)
292 $widgets(canvas) configure -borderwidth $options(-borderwidth)
293 $widgets(canvas) configure -height $options(-height)
294 $widgets(canvas) configure -relief $options(-relief)
295 $widgets(canvas) configure -takefocus $options(-takefocus)
296 $widgets(canvas) configure -width $options(-width)
299 pack $widgets(canvas) -fill both -expand 1
301 # local event stuff...
302 bind $widgets(canvas) <Configure> "::imagepp::resize $widgets(this) %w %h"
304 # >>>>>>>>>>>>>>>>>>> HERE, AT LAST, THE NEW COMMAND IS DEFINED <<<<<<<<<<<<<<<<<< #
305 proc ::$w { command args } "eval ::imagepp::imagePPWidgetProc $w \$command \$args"
306 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< #
308 # Last configuration stuff
309 if { [ catch "::imagepp::configureImagePP $widgets(this) [ array get options ]" \
323 #* PROCEDURE DESCRIPTION *************************************************
325 #* ::imagepp::configureImagePP (procedure) *
327 #* DESCRIPTION : This does the configuration process, i.e., change of *
329 #* This is a dummy proc, don't call it in your code. *
331 #* SYNTAX : set ret [ ::imagepp::configureImagePP $widget $options ] *
333 #* RETURN : All options, if args is empty. If length args == 1 then *
334 #* returns current value. Empty string otherwise. *
337 #* w : string. Widget name. *
338 #* args : list. Option/value pairs list. *
340 #******************************************************* END DESCRIPTION *
341 proc ::imagepp::configureImagePP { w args } {
343 variable widgetOptions
345 # For namespace access
346 upvar ::imagepp::${w}::options options
347 upvar ::imagepp::${w}::widgets widgets
348 upvar ::imagepp::${w}::localIds localIds
349 upvar ::imagepp::${w}::hNeed hNeed
350 upvar ::imagepp::${w}::vNeed vNeed
351 upvar ::imagepp::${w}::actROI actROI
352 upvar ::imagepp::${w}::lastX lastX
353 upvar ::imagepp::${w}::lastY lastY
355 # Sends all information to the user...
356 if { [ llength $args ] == 0 } {
359 foreach opt [ lsort [ array names widgetOptions ] ] {
361 if { [ llength $widgetOptions($opt) ] == 1 } {
363 set alias $widgetOptions($opt)
364 set optName $widgetOptions($alias)
365 lappend results [ list $opt $optName ]
369 set optName [ lindex $widgetOptions($opt) 0 ]
370 set optClass [ lindex $widgetOptions($opt) 1 ]
371 set default [ option get $w $optName $optClass ]
372 lappend results [ list $opt $optName $optClass $default $options($opt) ]
381 # or single information...
382 if { [ llength $args ] == 1 } {
384 set opt [ ::imagepp::canonizeImagePP $w option [ lindex $args 0 ] ]
385 set optName [ lindex $widgetOptions($opt) 0 ]
386 set optClass [ lindex $widgetOptions($opt) 1 ]
387 set default [ option get $w $optName $optClass ]
388 set results [ list $opt $optName $optClass $default $options($opt) ]
393 if { [ expr { [ llength $args ] % 2 } ] == 1 } {
394 error "some values for \"$args\" are missing"
397 # check if all given options exists...
398 foreach { name value } $args {
400 set name [ ::imagepp::canonizeImagePP $w option $name ]
401 set opts($name) $value
406 foreach option [ array names opts ] {
408 set newValue $opts($option)
413 if { [ llength $newValue ] == 4 } {
414 set options(-initialroi) $newValue
415 } else { error "wrong ROI value" }
418 default { eval "$widgets(canvas) configure $option $newValue" }
426 #* PROCEDURE DESCRIPTION *************************************************
428 #* ::imagepp::canonizeImagePP (procedure) *
430 #* DESCRIPTION : Takes a option or command and canonizes it. Returns *
431 #* either the canonical form of an option or command, or *
432 #* raises an error if the option or command is unknown or *
434 #* This is a dummy proc, don't call it in your code. *
436 #* SYNTAX : set c [ ::imagepp::canonizeImagePP $w option $args ] *
438 #* RETURN : Option or command canonical form *
441 #* w : string. Widget name. *
442 #* object : string. option/command id. *
443 #* opt : string. Option/command value. *
445 #******************************************************* END DESCRIPTION *
446 proc ::imagepp::canonizeImagePP { w object opt } {
448 variable widgetOptions
449 variable widgetCommands
455 if { [ lsearch -exact $widgetCommands $opt ] >= 0 } { return $opt }
456 set list $widgetCommands
457 foreach element $list { set tmp($element) "" }
458 set matches [ array names tmp ${opt}* ]
463 if { [ info exists widgetOptions($opt) ] && \
464 [ llength $widgetOptions($opt) ] == 2 \
466 set list [ array names widgetOptions ]
467 set matches [ array names widgetOptions ${opt}* ]
472 if { [ llength $matches ] == 0 } {
473 error "unknown $object \"$opt\"; must be one of $list"
474 } elseif { [ llength $matches ] == 1 } {
476 set opt [ lindex $matches 0 ]
482 set opt [ lindex $matches 0 ]
483 if { [ llength $widgetOptions($opt) ] == 1 } { set opt $widgetOptions($opt) }
490 } else { error "ambiguous $object \"$opt\"; must be one of $list" }
494 #* PROCEDURE DESCRIPTION *************************************************
496 #* ::imagepp::imagePPDestroyHandler (procedure) *
498 #* DESCRIPTION : Handles the destroy event. *
499 #* This is a dummy proc, don't call it in your code. *
501 #* SYNTAX : ::imagepp::imagePPDestroyHandler $w *
506 #* w : string. Widget name. *
508 #******************************************************* END DESCRIPTION *
509 proc ::imagepp::imagePPDestroyHandler { w } {
511 if { [ string compare [ winfo class $w ] "ImagePP" ] == 0 } {
513 # For namespace access
514 upvar ::imagepp::${w}::options options
515 upvar ::imagepp::${w}::widgets widgets
516 upvar ::imagepp::${w}::localIds localIds
517 upvar ::imagepp::${w}::hNeed hNeed
518 upvar ::imagepp::${w}::vNeed vNeed
519 upvar ::imagepp::${w}::actROI actROI
520 upvar ::imagepp::${w}::lastX lastX
521 upvar ::imagepp::${w}::lastY lastY
524 namespace delete ::imagepp::$w
532 #* PROCEDURE DESCRIPTION *************************************************
534 #* ::imagepp::imagePPWidgetProc (procedure) *
536 #* DESCRIPTION : Main procedure. This executes all sub-commands for the *
539 #* SYNTAX : ::imagepp::imagePPWidgetProc $widget $command $args *
540 #* This is a dummy proc, don't call it in your code. *
542 #* RETURN : Depends on each sub-command *
545 #* w : string. Widget name. *
546 #* command : string. Sub-command name. *
547 #* args : list. Arguments for sub-command. *
549 #******************************************************* END DESCRIPTION *
550 proc ::imagepp::imagePPWidgetProc { w command args } {
552 # For namespace access
553 upvar ::imagepp::${w}::options options
554 upvar ::imagepp::${w}::widgets widgets
555 upvar ::imagepp::${w}::localIds localIds
556 upvar ::imagepp::${w}::hNeed hNeed
557 upvar ::imagepp::${w}::vNeed vNeed
558 upvar ::imagepp::${w}::actROI actROI
559 upvar ::imagepp::${w}::lastX lastX
560 upvar ::imagepp::${w}::lastY lastY
562 # given command exists?
563 set command [ ::imagepp::canonizeImagePP $w command $command ]
567 # execute subcommands
570 add { set result [ eval ::imagepp::addImagePP {$w} $args ] }
571 addtext { set result [ eval ::imagepp::addTextImagePP {$w} $args ] }
572 cget { set result [ eval ::imagepp::cgetImagePP {$w} $args ] }
573 clean { set result [ eval ::imagepp::cleanImagePP {$w} $args ] }
574 configure { set result [ eval ::imagepp::configureImagePP {$w} $args ] }
575 delete { set result [ eval ::imagepp::deleteImagePP {$w} $args ] }
576 find { set result [ eval ::imagepp::findImagePP {$w} $args ] }
577 getprofildata { set result [ eval ::imagepp::getprofildataImagePP {$w} $args ] }
578 resetroi { set result [ eval ::imagepp::resetROIImagePP {$w} $args ] }
579 roi { set result [ eval ::imagepp::ROIImagePP {$w} $args ] }
580 setroi { set result [ eval ::imagepp::setROIImagePP {$w} $args ] }
581 show { set result [ eval ::imagepp::showImagePP {$w} $args ] }
582 setlinear { set result [ eval ::imagepp::setlinearImagePP {$w} $args ] }
583 setarea { set result [ eval ::imagepp::setareaImagePP {$w} $args ] }
584 setnone { set result [ eval ::imagepp::setnoneImagePP {$w} $args ] }
591 #* PROCEDURE DESCRIPTION *************************************************
593 #* ::imagepp::addImagePP (procedure) *
595 #* DESCRIPTION : Executes the "add" sub-command. This can add a tkimage, *
596 #* load an image from disk, make references with id's. *
597 #* This is a dummy proc, don't call it in your code. *
598 #* Use your widget definition and the sub-command. *
600 #* SYNTAX : set ret [ ::imagepp::addImagePP $w $args ] *
602 #* ?-image <tkimage>? *
603 #* ?-file <filename> -format <fileformat>? *
606 #* RETURN : Empty string on error. *
609 #* w : string. Widget name. *
610 #* args : list. Arguments for sub-command. *
612 #******************************************************* END DESCRIPTION *
613 proc ::imagepp::addImagePP { w args } {
615 # For namespace access
616 upvar ::imagepp::${w}::options options
617 upvar ::imagepp::${w}::widgets widgets
618 upvar ::imagepp::${w}::localIds localIds
619 upvar ::imagepp::${w}::hNeed hNeed
620 upvar ::imagepp::${w}::vNeed vNeed
621 upvar ::imagepp::${w}::actROI actROI
622 upvar ::imagepp::${w}::lastX lastX
623 upvar ::imagepp::${w}::lastY lastY
624 upvar ::imagepp::${w}::s_width s_width
625 upvar ::imagepp::${w}::s_height s_height
627 # arguments parsing...
628 if { [ llength $args ] == 4 } {
631 set l_opc [ array names opc ]
632 if { [ lsearch -exact $l_opc "-image" ] != -1 && \
633 [ lsearch -exact $l_opc "-id" ] != -1 \
636 set new_img $opc(-image)
639 } else { error "error in \"add\" command arguments" }
641 } elseif { [ llength $args ] == 6 } {
644 set l_opc [ array names opc ]
645 if { [ lsearch -exact $l_opc "-file" ] != -1 && \
646 [ lsearch -exact $l_opc "-format" ] != -1 && \
647 [ lsearch -exact $l_opc "-id" ] != -1 \
650 set new_img [ image create photo -file $opc(-file) -format $opc(-format) ]
653 } else { error "error in \"add\" command arguments" }
655 } else { error "error in \"add\" command arguments" }
657 # given id already exists?
658 array set ids $localIds
659 set l_localIds [ array names ids ]
660 if { [ lsearch -exact $l_localIds $new_id ] == -1 } {
663 set s_width [ image width $new_img ]
664 set s_height [ image height $new_img ]
666 $widgets(canvas) create image 0 0 \
671 lappend localIds $new_id
672 lappend localIds $canvas_id
673 set hNeed [ expr ( $s_width > $hNeed )? $s_width : $hNeed ]
674 set vNeed [ expr ( $s_height > $vNeed )? $s_height: $vNeed ]
675 $widgets(canvas) configure -scrollregion "0 0 $hNeed $vNeed"
676 foreach e $actROI { $widgets(canvas) raise $e }
680 set item [ $widgets(canvas) find withtag "id_$new_id" ]
681 $widgets(canvas) itemconfigure $item -image $new_img
682 $widgets(canvas) raise $item
683 foreach e $actROI { $widgets(canvas) raise $e }
690 #* PROCEDURE DESCRIPTION *************************************************
692 #* ::imagepp::addTextImagePP (procedure) *
694 #* DESCRIPTION : Executes the "addtext" sub-command. *
695 #* This is a dummy proc, don't call it in your code. *
696 #* Use your widget definition and the sub-command. *
698 #* SYNTAX : set ret [ ::imagepp::addTextImagePP $w $args ] *
699 #* <widget> addtext <text> <x> <y> *
704 #* w : string. Widget name. *
705 #* args : list. Arguments for sub-command. *
707 #******************************************************* END DESCRIPTION *
708 proc ::imagepp::addTextImagePP { w args } {
710 # For namespace access
711 upvar ::imagepp::${w}::options options
712 upvar ::imagepp::${w}::widgets widgets
713 upvar ::imagepp::${w}::localIds localIds
714 upvar ::imagepp::${w}::hNeed hNeed
715 upvar ::imagepp::${w}::vNeed vNeed
716 upvar ::imagepp::${w}::actROI actROI
717 upvar ::imagepp::${w}::lastX lastX
718 upvar ::imagepp::${w}::lastY lastY
720 catch { $widgets(canvas) delete "textErase" }
721 $widgets(canvas) create text \
724 -text [ lindex $args 0 ] \
729 -font { Helvetica -12 bold }
733 #* PROCEDURE DESCRIPTION *************************************************
735 #* ::imagepp::cgetImagePP (procedure) *
737 #* DESCRIPTION : Executes the "cget" sub-command. Returns information *
738 #* about certain widget option. *
739 #* This is a dummy proc, don't call it in your code. *
740 #* Use your widget definition and the sub-command. *
742 #* SYNTAX : set ret [ ::imagepp::cgetImagePP $w $args ] *
743 #* <widget> cget ?-<option>? *
745 #* RETURN : Option value. *
748 #* w : string. Widget name. *
749 #* args : list. Arguments for sub-command. *
751 #******************************************************* END DESCRIPTION *
752 proc ::imagepp::cgetImagePP { w args } {
754 # For namespace access
755 upvar ::imagepp::${w}::options options
756 upvar ::imagepp::${w}::widgets widgets
757 upvar ::imagepp::${w}::localIds localIds
758 upvar ::imagepp::${w}::hNeed hNeed
759 upvar ::imagepp::${w}::vNeed vNeed
760 upvar ::imagepp::${w}::actROI actROI
761 upvar ::imagepp::${w}::lastX lastX
762 upvar ::imagepp::${w}::lastY lastY
765 if { [ llength $args ] == 1 } {
767 set opt [ ::imagepp::canonizeImagePP $w option $args ]
768 set ret $options($opt)
770 } else { error "\"cget\" command only accepts one argument" }
775 #* PROCEDURE DESCRIPTION *************************************************
777 #* ::imagepp::cleanImagePP (procedure) *
779 #* DESCRIPTION : Executes the "clean" sub-command. *
780 #* This is a dummy proc, don't call it in your code. *
781 #* Use your widget definition and the sub-command. *
783 #* SYNTAX : set ret [ ::imagepp::cleanImagePP $w $args ] *
789 #* w : string. Widget name. *
790 #* args : list. Arguments for sub-command. *
792 #******************************************************* END DESCRIPTION *
793 proc ::imagepp::cleanImagePP { w args } {
795 # For namespace access
796 upvar ::imagepp::${w}::options options
797 upvar ::imagepp::${w}::widgets widgets
798 upvar ::imagepp::${w}::localIds localIds
799 upvar ::imagepp::${w}::hNeed hNeed
800 upvar ::imagepp::${w}::vNeed vNeed
801 upvar ::imagepp::${w}::actROI actROI
802 upvar ::imagepp::${w}::lastX lastX
803 upvar ::imagepp::${w}::lastY lastY
805 catch { $widgets(canvas) delete $widgets(actual_line) }
806 catch { $widgets(canvas) delete "textErase" }
810 #* PROCEDURE DESCRIPTION *************************************************
812 #* ::imagepp::deleteImagePP (procedure) *
814 #* DESCRIPTION : Executes the "delete" sub-command. *
815 #* This is a dummy proc, don't call it in your code. *
816 #* Use your widget definition and the sub-command. *
818 #* SYNTAX : set ret [ ::imagepp::deleteImagePP $w $args ] *
819 #* <widget> delete -id <id/all> *
824 #* w : string. Widget name. *
825 #* args : list. Arguments for sub-command. *
827 #******************************************************* END DESCRIPTION *
828 proc ::imagepp::deleteImagePP { w args } {
830 # For namespace access
831 upvar ::imagepp::${w}::options options
832 upvar ::imagepp::${w}::widgets widgets
833 upvar ::imagepp::${w}::localIds localIds
834 upvar ::imagepp::${w}::hNeed hNeed
835 upvar ::imagepp::${w}::vNeed vNeed
836 upvar ::imagepp::${w}::actROI actROI
837 upvar ::imagepp::${w}::lastX lastX
838 upvar ::imagepp::${w}::lastY lastY
842 # arguments parsing...
843 if { [ llength $args ] == 2 } {
845 if { [ string compare [ lindex $args 0 ] "-id" ] == 0 } {
847 if { [ string compare [ lindex $args 1 ] "all" ] == 0 } {
849 set all_items [ $widgets(canvas) find withtag all ]
850 foreach item $all_items { $widgets(canvas) delete $item }
855 } else { error "wrong argument for \"delete\" command" }
857 } else { error "wrong number of arguments for \"delete\" command" }
862 #* PROCEDURE DESCRIPTION *************************************************
864 #* ::imagepp::findImagePP (procedure) *
866 #* DESCRIPTION : Executes the "find" sub-command. *
867 #* This is a dummy proc, don't call it in your code. *
868 #* Use your widget definition and the sub-command. *
870 #* SYNTAX : set ret [ ::imagepp::findImagePP $w $args ] *
871 #* <widget> delete -id <id> *
876 #* w : string. Widget name. *
877 #* args : list. Arguments for sub-command. *
879 #******************************************************* END DESCRIPTION *
880 proc ::imagepp::findImagePP { w args } {
882 # For namespace access
883 upvar ::imagepp::${w}::options options
884 upvar ::imagepp::${w}::widgets widgets
885 upvar ::imagepp::${w}::localIds localIds
886 upvar ::imagepp::${w}::hNeed hNeed
887 upvar ::imagepp::${w}::vNeed vNeed
888 upvar ::imagepp::${w}::actROI actROI
889 upvar ::imagepp::${w}::lastX lastX
890 upvar ::imagepp::${w}::lastY lastY
894 # arguments parsing...
895 if { [ llength $args ] == 2 } {
897 if { [ string compare [ lindex $args 0 ] "-id" ] == 0 } {
899 array set ids $localIds
900 set l_localIds [ array names ids ]
901 set ret [ lsearch -exact $l_localIds [ lindex $args 1 ] ]
903 } else { error "wrong argument for \"find\" command" }
905 } else { error "wrong number of arguments for \"find\" command" }
910 #* PROCEDURE DESCRIPTION *************************************************
912 #* ::imagepp::getprofildataImagePP (procedure) *
914 #* DESCRIPTION : Executes the "find" sub-command. *
915 #* This is a dummy proc, don't call it in your code. *
916 #* Use your widget definition and the sub-command. *
918 #* SYNTAX : set ret [ ::imagepp::getprofildataImagePP $w $args ] *
919 #* <widget> getprofildata -id <id> *
921 #* RETURN : Limits for a profil measure. *
924 #* w : string. Widget name. *
925 #* args : list. Arguments for sub-command. *
927 #******************************************************* END DESCRIPTION *
928 proc ::imagepp::getprofildataImagePP { w args } {
930 # For namespace access
931 upvar ::imagepp::${w}::options options
932 upvar ::imagepp::${w}::widgets widgets
933 upvar ::imagepp::${w}::localIds localIds
934 upvar ::imagepp::${w}::hNeed hNeed
935 upvar ::imagepp::${w}::vNeed vNeed
936 upvar ::imagepp::${w}::actROI actROI
937 upvar ::imagepp::${w}::lastX lastX
938 upvar ::imagepp::${w}::lastY lastY
940 return $widgets(profildata)
944 #* PROCEDURE DESCRIPTION *************************************************
946 #* ::imagepp::resetROIImagePP (procedure) *
948 #* DESCRIPTION : Executes the "resetroi" sub-command. *
949 #* This is a dummy proc, don't call it in your code. *
950 #* Use your widget definition and the sub-command. *
952 #* SYNTAX : set ret [ ::imagepp::resetROIImagePP $w $args ] *
953 #* <widget> resetroi *
958 #* w : string. Widget name. *
959 #* args : list. Arguments for sub-command. *
961 #******************************************************* END DESCRIPTION *
962 proc ::imagepp::resetROIImagePP { w args } {
964 # For namespace access
965 upvar ::imagepp::${w}::options options
966 upvar ::imagepp::${w}::widgets widgets
967 upvar ::imagepp::${w}::localIds localIds
968 upvar ::imagepp::${w}::hNeed hNeed
969 upvar ::imagepp::${w}::vNeed vNeed
970 upvar ::imagepp::${w}::actROI actROI
971 upvar ::imagepp::${w}::lastX lastX
972 upvar ::imagepp::${w}::lastY lastY
975 foreach e $actROI { $widgets(canvas) delete $e }
978 set ux [ lindex $options(-initialroi) 0 ]
979 set uy [ lindex $options(-initialroi) 1 ]
980 set bx [ lindex $options(-initialroi) 2 ]
981 set by [ lindex $options(-initialroi) 3 ]
987 lappend actROI [ $widgets(canvas) create rectangle \
988 [ expr $ux - 6 ] [ expr $uy - 6 ] \
989 [ expr $ux + 0 ] [ expr $uy + 0 ] \
995 lappend actROI [ $widgets(canvas) create rectangle \
996 [ expr $bx - 0 ] [ expr $uy - 6 ] \
997 [ expr $bx + 6 ] [ expr $uy + 0 ] \
1003 lappend actROI [ $widgets(canvas) create rectangle \
1004 [ expr $bx - 0 ] [ expr $by - 0 ] \
1005 [ expr $bx + 6 ] [ expr $by + 6 ] \
1011 lappend actROI [ $widgets(canvas) create rectangle \
1012 [ expr $ux - 6 ] [ expr $by - 0 ] \
1013 [ expr $ux + 0 ] [ expr $by + 6 ] \
1018 # rectangle for area
1019 lappend actROI [ $widgets(canvas) create rectangle \
1020 [ expr $ux ] [ expr $uy ] \
1021 [ expr $bx ] [ expr $by ] \
1028 $widgets(canvas) bind [ lindex $actROI 0 ] <Enter> "$widgets(canvas) itemconfigure current -fill #ff0000"
1029 $widgets(canvas) bind [ lindex $actROI 0 ] <Leave> "$widgets(canvas) itemconfigure current -fill #ffff00"
1030 $widgets(canvas) bind [ lindex $actROI 0 ] <Button-1> "::imagepp::startMotion $w %x %y"
1031 $widgets(canvas) bind [ lindex $actROI 0 ] <B1-Motion> "::imagepp::moveCorner $w %x %y 0"
1033 $widgets(canvas) bind [ lindex $actROI 1 ] <Enter> "$widgets(canvas) itemconfigure current -fill #ff0000"
1034 $widgets(canvas) bind [ lindex $actROI 1 ] <Leave> "$widgets(canvas) itemconfigure current -fill #ffff00"
1035 $widgets(canvas) bind [ lindex $actROI 1 ] <Button-1> "::imagepp::startMotion $w %x %y"
1036 $widgets(canvas) bind [ lindex $actROI 1 ] <B1-Motion> "::imagepp::moveCorner $w %x %y 1"
1038 $widgets(canvas) bind [ lindex $actROI 2 ] <Enter> "$widgets(canvas) itemconfigure current -fill #ff0000"
1039 $widgets(canvas) bind [ lindex $actROI 2 ] <Leave> "$widgets(canvas) itemconfigure current -fill #ffff00"
1040 $widgets(canvas) bind [ lindex $actROI 2 ] <Button-1> "::imagepp::startMotion $w %x %y"
1041 $widgets(canvas) bind [ lindex $actROI 2 ] <B1-Motion> "::imagepp::moveCorner $w %x %y 2"
1043 $widgets(canvas) bind [ lindex $actROI 3 ] <Enter> "$widgets(canvas) itemconfigure current -fill #ff0000"
1044 $widgets(canvas) bind [ lindex $actROI 3 ] <Leave> "$widgets(canvas) itemconfigure current -fill #ffff00"
1045 $widgets(canvas) bind [ lindex $actROI 3 ] <Button-1> "::imagepp::startMotion $w %x %y"
1046 $widgets(canvas) bind [ lindex $actROI 3 ] <B1-Motion> "::imagepp::moveCorner $w %x %y 3"
1048 $widgets(canvas) bind [ lindex $actROI 4 ] <Enter> "$widgets(canvas) itemconfigure current -outline #ff0000"
1049 $widgets(canvas) bind [ lindex $actROI 4 ] <Leave> "$widgets(canvas) itemconfigure current -outline #ffff00"
1050 $widgets(canvas) bind [ lindex $actROI 4 ] <Button-1> "::imagepp::startMotion $w %x %y"
1051 $widgets(canvas) bind [ lindex $actROI 4 ] <B1-Motion> "::imagepp::moveRect $w %x %y"
1053 foreach e $actROI { $widgets(canvas) raise $e }
1057 #* PROCEDURE DESCRIPTION *************************************************
1059 #* ::imagepp::ROIImagePP (procedure) *
1061 #* DESCRIPTION : Executes the "roi" sub-command. *
1062 #* This is a dummy proc, don't call it in your code. *
1063 #* Use your widget definition and the sub-command. *
1065 #* SYNTAX : set ret [ ::imagepp::ROIImagePP $w $args ] *
1068 #* RETURN : Actual Region Of Interest. *
1071 #* w : string. Widget name. *
1072 #* args : list. Arguments for sub-command. *
1074 #******************************************************* END DESCRIPTION *
1075 proc ::imagepp::ROIImagePP { w args } {
1077 # For namespace access
1078 upvar ::imagepp::${w}::options options
1079 upvar ::imagepp::${w}::widgets widgets
1080 upvar ::imagepp::${w}::localIds localIds
1081 upvar ::imagepp::${w}::hNeed hNeed
1082 upvar ::imagepp::${w}::vNeed vNeed
1083 upvar ::imagepp::${w}::actROI actROI
1084 upvar ::imagepp::${w}::lastX lastX
1085 upvar ::imagepp::${w}::lastY lastY
1086 upvar ::imagepp::${w}::s_width s_width
1087 upvar ::imagepp::${w}::s_height s_height
1089 set ux $s_width; set uy $s_height
1090 set bx -1; set by -1
1091 set c [ $widgets(canvas) coords [ lindex $actROI 4 ] ]
1092 set ux [ expr ( [ lindex $c 0 ] < $ux )? [ lindex $c 0 ]: $ux ]
1093 set uy [ expr ( [ lindex $c 1 ] < $uy )? [ lindex $c 1 ]: $uy ]
1094 set bx [ expr ( [ lindex $c 2 ] > $bx )? [ lindex $c 2 ]: $bx ]
1095 set by [ expr ( [ lindex $c 3 ] > $by )? [ lindex $c 3 ]: $by ]
1097 set ux [ expr ( $ux < 0 )? 0: $ux ]
1098 set uy [ expr ( $uy < 0 )? 0: $uy ]
1099 set bx [ expr ( $bx > $s_width )? $s_width - 1: $bx ]
1100 set by [ expr ( $by > $s_height )? $s_height - 1: $by ]
1102 set ret [ list $ux $uy $bx $by ]
1107 #* PROCEDURE DESCRIPTION *************************************************
1109 #* ::imagepp::showImagePP (procedure) *
1111 #* DESCRIPTION : Executes the "show" sub-command. *
1112 #* This is a dummy proc, don't call it in your code. *
1113 #* Use your widget definition and the sub-command. *
1115 #* SYNTAX : set ret [ ::imagepp::showImagePP $w $args ] *
1118 #* RETURN : -NONE- *
1121 #* w : string. Widget name. *
1122 #* args : list. Arguments for sub-command. *
1124 #******************************************************* END DESCRIPTION *
1125 proc ::imagepp::showImagePP { w args } {
1127 # For namespace access
1128 upvar ::imagepp::${w}::options options
1129 upvar ::imagepp::${w}::widgets widgets
1130 upvar ::imagepp::${w}::localIds localIds
1131 upvar ::imagepp::${w}::hNeed hNeed
1132 upvar ::imagepp::${w}::vNeed vNeed
1133 upvar ::imagepp::${w}::actROI actROI
1134 upvar ::imagepp::${w}::lastX lastX
1135 upvar ::imagepp::${w}::lastY lastY
1137 # arguments parsing...
1138 if { [ llength $args ] == 2 } {
1140 if { [ string compare [ lindex $args 0 ] "-id" ] == 0 } {
1142 array set ids $localIds
1143 set l_localIds [ array names ids ]
1144 set local_id [ lindex $args 1 ]
1145 if { [ lsearch -exact $l_localIds $local_id ] != -1 } {
1147 $widgets(canvas) raise $ids($local_id)
1148 foreach e $actROI { $widgets(canvas) raise $e }
1152 } else { error "wrong argument for \"show\" command" }
1154 } else { error "wrong number of arguments for \"show\" command" }
1159 #* PROCEDURE DESCRIPTION *************************************************
1161 #* ::imagepp::setlinearImagePP (procedure) *
1163 #* DESCRIPTION : Executes the "setlinear" sub-command. *
1164 #* This is a dummy proc, don't call it in your code. *
1165 #* Use your widget definition and the sub-command. *
1167 #* SYNTAX : set ret [ ::imagepp::setlinearImagePP $w $args ] *
1168 #* <widget> setlinear *
1170 #* RETURN : -NONE- *
1173 #* w : string. Widget name. *
1174 #* args : list. Arguments for sub-command. *
1176 #******************************************************* END DESCRIPTION *
1177 proc ::imagepp::setlinearImagePP { w args } {
1179 # For namespace access
1180 upvar ::imagepp::${w}::options options
1181 upvar ::imagepp::${w}::widgets widgets
1182 upvar ::imagepp::${w}::localIds localIds
1183 upvar ::imagepp::${w}::hNeed hNeed
1184 upvar ::imagepp::${w}::vNeed vNeed
1185 upvar ::imagepp::${w}::actROI actROI
1186 upvar ::imagepp::${w}::lastX lastX
1187 upvar ::imagepp::${w}::lastY lastY
1189 catch { $widgets(canvas) delete $widgets(actual_line) }
1190 catch { $widgets(canvas) delete "textErase" }
1191 bind $widgets(canvas) <ButtonPress-3> "::imagepp::startMotion $widgets(this) %x %y 1"
1192 bind $widgets(canvas) <B3-Motion> "::imagepp::goMotion $widgets(this) %x %y 1"
1193 bind $widgets(canvas) <ButtonRelease-3> "::imagepp::finishMotion $widgets(this) %x %y 1"
1197 #* PROCEDURE DESCRIPTION *************************************************
1199 #* ::imagepp::setareaImagePP (procedure) *
1201 #* DESCRIPTION : Executes the "setarea" sub-command. *
1202 #* This is a dummy proc, don't call it in your code. *
1203 #* Use your widget definition and the sub-command. *
1205 #* SYNTAX : set ret [ ::imagepp::setareaImagePP $w $args ] *
1206 #* <widget> setarea *
1208 #* RETURN : -NONE- *
1211 #* w : string. Widget name. *
1212 #* args : list. Arguments for sub-command. *
1214 #******************************************************* END DESCRIPTION *
1215 proc ::imagepp::setareaImagePP { w args } {
1217 # For namespace access
1218 upvar ::imagepp::${w}::options options
1219 upvar ::imagepp::${w}::widgets widgets
1220 upvar ::imagepp::${w}::localIds localIds
1221 upvar ::imagepp::${w}::hNeed hNeed
1222 upvar ::imagepp::${w}::vNeed vNeed
1223 upvar ::imagepp::${w}::actROI actROI
1224 upvar ::imagepp::${w}::lastX lastX
1225 upvar ::imagepp::${w}::lastY lastY
1227 catch { $widgets(canvas) delete $widgets(actual_line) }
1228 catch { $widgets(canvas) delete "textErase" }
1229 bind $widgets(canvas) <ButtonPress-3> "::imagepp::startMotion $widgets(this) %x %y 2"
1230 bind $widgets(canvas) <B3-Motion> "::imagepp::goMotion $widgets(this) %x %y 2"
1231 bind $widgets(canvas) <ButtonRelease-3> "::imagepp::finishMotion $widgets(this) %x %y 2"
1235 #* PROCEDURE DESCRIPTION *************************************************
1237 #* ::imagepp::setnoneImagePP (procedure) *
1239 #* DESCRIPTION : Executes the "setnone" sub-command. *
1240 #* This is a dummy proc, don't call it in your code. *
1241 #* Use your widget definition and the sub-command. *
1243 #* SYNTAX : set ret [ ::imagepp::setnoneImagePP $w $args ] *
1244 #* <widget> setnone *
1246 #* RETURN : -NONE- *
1249 #* w : string. Widget name. *
1250 #* args : list. Arguments for sub-command. *
1252 #******************************************************* END DESCRIPTION *
1253 proc ::imagepp::setnoneImagePP { w args } {
1255 # For namespace access
1256 upvar ::imagepp::${w}::options options
1257 upvar ::imagepp::${w}::widgets widgets
1258 upvar ::imagepp::${w}::localIds localIds
1259 upvar ::imagepp::${w}::hNeed hNeed
1260 upvar ::imagepp::${w}::vNeed vNeed
1261 upvar ::imagepp::${w}::actROI actROI
1262 upvar ::imagepp::${w}::lastX lastX
1263 upvar ::imagepp::${w}::lastY lastY
1265 catch { $widgets(canvas) delete $widgets(actual_line) }
1266 catch { $widgets(canvas) delete "textErase" }
1267 bind $widgets(canvas) <ButtonPress-1> "::imagepp::startMotion $widgets(this) %x %y 3"
1268 bind $widgets(canvas) <B1-Motion> "::imagepp::goMotion $widgets(this) %x %y 3"
1269 bind $widgets(canvas) <ButtonRelease-1> "::imagepp::finishMotion $widgets(this) %x %y 3"
1273 #* PROCEDURE DESCRIPTION *************************************************
1275 #* ::imagepp::resize (procedure) *
1277 #* DESCRIPTION : Event callback. Resize widget. *
1278 #* This is a dummy proc, don't call it in your code. *
1280 #* SYNTAX : ::imagepp::resize %W %w %h *
1282 #* RETURN : -NONE- *
1285 #* w : string. Widget name. *
1286 #* width : string. Widget width. *
1287 #* height : string. Widget height. *
1289 #******************************************************* END DESCRIPTION *
1290 proc ::imagepp::resize { w width height } {
1292 # For namespace access
1293 upvar ::imagepp::${w}::options options
1294 upvar ::imagepp::${w}::widgets widgets
1295 upvar ::imagepp::${w}::localIds localIds
1296 upvar ::imagepp::${w}::hNeed hNeed
1297 upvar ::imagepp::${w}::vNeed vNeed
1298 upvar ::imagepp::${w}::actROI actROI
1299 upvar ::imagepp::${w}::lastX lastX
1300 upvar ::imagepp::${w}::lastY lastY
1302 if { $options(-width) != $width || $options(-height) != $height } {
1304 set options(-width) $width
1305 set options(-height) $height
1306 $widgets(canvas) configure -width $options(-width)
1307 ::imagepp::configureSlider $w
1313 #* PROCEDURE DESCRIPTION *************************************************
1315 #* ::imagepp::configureSlider (procedure) *
1317 #* DESCRIPTION : Puts or erases a slider, if necessary. *
1318 #* This is a dummy proc, don't call it in your code. *
1320 #* SYNTAX : ::imagepp::configureSlider $widget *
1322 #* RETURN : -NONE- *
1325 #* w : string. Widget name. *
1327 #******************************************************* END DESCRIPTION *
1328 proc ::imagepp::configureSlider { w } {
1330 # For namespace access
1331 upvar ::imagepp::${w}::options options
1332 upvar ::imagepp::${w}::widgets widgets
1333 upvar ::imagepp::${w}::localIds localIds
1334 upvar ::imagepp::${w}::hNeed hNeed
1335 upvar ::imagepp::${w}::vNeed vNeed
1336 upvar ::imagepp::${w}::actROI actROI
1337 upvar ::imagepp::${w}::lastX lastX
1338 upvar ::imagepp::${w}::lastY lastY
1340 set rh $options(-height)
1341 set rw $options(-width)
1343 if { $vNeed >= $rh && ! [ winfo exists $w.vs ] } {
1345 set widgets(vs) [ scrollbar $w.vs -command "$widgets(canvas) yview" ]
1346 $widgets(canvas) configure -yscrollcommand "$widgets(vs) set"
1347 grid $widgets(canvas) \
1348 -in $widgets(this) \
1354 grid $widgets(vs) -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news
1355 grid rowconfig $widgets(this) 0 -weight 1 -minsize 0
1356 grid columnconfig $widgets(this) 0 -weight 1 -minsize 0
1358 } elseif { $vNeed < $rh && [ winfo exists $w.vs ] } {
1360 $widgets(canvas) configure -yscrollcommand ""
1366 if { $hNeed >= $rw && ! [ winfo exists $w.hs ] } {
1368 set widgets(hs) [ scrollbar $w.hs -orient horizontal -command "$widgets(canvas) xview" ]
1369 $widgets(canvas) configure -xscrollcommand "$widgets(hs) set"
1370 grid $widgets(canvas) \
1371 -in $widgets(this) \
1377 grid $widgets(hs) -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news
1378 grid rowconfig $widgets(this) 0 -weight 1 -minsize 0
1379 grid columnconfig $widgets(this) 0 -weight 1 -minsize 0
1381 } elseif { $hNeed < $rw && [ winfo exists $w.hs ] } {
1383 $widgets(canvas) configure -xscrollcommand ""
1391 #* PROCEDURE DESCRIPTION *************************************************
1393 #* ::imagepp::startMotion (procedure) *
1395 #* DESCRIPTION : Event callback. Start mouse motion. *
1396 #* This is a dummy proc, don't call it in your code. *
1398 #* SYNTAX : ::imagepp::startMotion %W %x %y $typ *
1400 #* RETURN : -NONE- *
1403 #* w : string. Widget name. *
1404 #* x : string. x-coordinate. *
1405 #* y : string. y-coordinate. *
1406 #* typ : string. (optional) Motion type. *
1408 #******************************************************* END DESCRIPTION *
1409 proc ::imagepp::startMotion { w x y { typ 0 } } {
1411 # For namespace access
1412 upvar ::imagepp::${w}::options options
1413 upvar ::imagepp::${w}::widgets widgets
1414 upvar ::imagepp::${w}::localIds localIds
1415 upvar ::imagepp::${w}::hNeed hNeed
1416 upvar ::imagepp::${w}::vNeed vNeed
1417 upvar ::imagepp::${w}::actROI actROI
1418 upvar ::imagepp::${w}::lastX lastX
1419 upvar ::imagepp::${w}::lastY lastY
1424 catch { $widgets(canvas) delete $widgets(actual_line) }
1425 catch { $widgets(canvas) delete "textErase" }
1426 if { $widgets(movingroi) == 0 } {
1430 set widgets(actual_line) [ \
1431 $widgets(canvas) create line $lastX $lastY $lastX $lastY \
1437 } elseif { $typ == 2 } {
1439 set widgets(actual_line) [ \
1440 $widgets(canvas) create rectangle \
1441 $lastX $lastY $lastX $lastY \
1452 #* PROCEDURE DESCRIPTION *************************************************
1454 #* ::imagepp::goMotion (procedure) *
1456 #* DESCRIPTION : Event callback. Do mouse motion. *
1457 #* This is a dummy proc, don't call it in your code. *
1459 #* SYNTAX : ::imagepp::goMotion %W %x %y $typ *
1461 #* RETURN : -NONE- *
1464 #* w : string. Widget name. *
1465 #* x : string. x-coordinate. *
1466 #* y : string. y-coordinate. *
1467 #* typ : string. (optional) Motion type. *
1469 #******************************************************* END DESCRIPTION *
1470 proc ::imagepp::goMotion { w x y typ } {
1472 # For namespace access
1473 upvar ::imagepp::${w}::options options
1474 upvar ::imagepp::${w}::widgets widgets
1475 upvar ::imagepp::${w}::localIds localIds
1476 upvar ::imagepp::${w}::hNeed hNeed
1477 upvar ::imagepp::${w}::vNeed vNeed
1478 upvar ::imagepp::${w}::actROI actROI
1479 upvar ::imagepp::${w}::lastX lastX
1480 upvar ::imagepp::${w}::lastY lastY
1482 if { $widgets(movingroi) == 0 } {
1484 if { $typ == 1 || $typ == 2 } {
1486 $widgets(canvas) coords \
1487 $widgets(actual_line) \
1490 } elseif { $typ == 3 } {
1492 set widgets(profildata) [ list 3 $lastX $lastY $x $y ]
1493 event generate $widgets(this) <<AfterProfil>>
1500 #* PROCEDURE DESCRIPTION *************************************************
1502 #* ::imagepp::finishMotion (procedure) *
1504 #* DESCRIPTION : Event callback. Finish mouse motion. *
1505 #* This is a dummy proc, don't call it in your code. *
1507 #* SYNTAX : ::imagepp::finishMotion %W %x %y $typ *
1509 #* RETURN : -NONE- *
1512 #* w : string. Widget name. *
1513 #* x : string. x-coordinate. *
1514 #* y : string. y-coordinate. *
1515 #* typ : string. (optional) Motion type. *
1517 #******************************************************* END DESCRIPTION *
1518 proc ::imagepp::finishMotion { w x y typ } {
1520 # For namespace access
1521 upvar ::imagepp::${w}::options options
1522 upvar ::imagepp::${w}::widgets widgets
1523 upvar ::imagepp::${w}::localIds localIds
1524 upvar ::imagepp::${w}::hNeed hNeed
1525 upvar ::imagepp::${w}::vNeed vNeed
1526 upvar ::imagepp::${w}::actROI actROI
1527 upvar ::imagepp::${w}::lastX lastX
1528 upvar ::imagepp::${w}::lastY lastY
1530 if { $widgets(movingroi) == 0 } {
1532 if { $typ == 3 } { incr typ }
1533 set widgets(profildata) [ list $typ $lastX $lastY $x $y ]
1535 event generate $widgets(this) <<AfterProfil>>
1538 set widgets(movingroi) 0
1542 #* PROCEDURE DESCRIPTION *************************************************
1544 #* ::imagepp::moveRect (procedure) *
1546 #* DESCRIPTION : Event callback. Move a rectangle. *
1547 #* This is a dummy proc, don't call it in your code. *
1549 #* SYNTAX : ::imagepp::moveRect %W %x %y *
1551 #* RETURN : -NONE- *
1554 #* w : string. Widget name. *
1555 #* x : string. x-coordinate. *
1556 #* y : string. y-coordinate. *
1558 #******************************************************* END DESCRIPTION *
1559 proc ::imagepp::moveRect { w x y } {
1561 # For namespace access
1562 upvar ::imagepp::${w}::options options
1563 upvar ::imagepp::${w}::widgets widgets
1564 upvar ::imagepp::${w}::localIds localIds
1565 upvar ::imagepp::${w}::hNeed hNeed
1566 upvar ::imagepp::${w}::vNeed vNeed
1567 upvar ::imagepp::${w}::actROI actROI
1568 upvar ::imagepp::${w}::lastX lastX
1569 upvar ::imagepp::${w}::lastY lastY
1571 set widgets(movingroi) 1
1572 $widgets(canvas) move [ lindex $actROI 4 ] \
1573 [ expr $x - $lastX ] \
1574 [ expr $y - $lastY ]
1575 $widgets(canvas) move [ lindex $actROI 0 ] \
1576 [ expr $x - $lastX ] \
1577 [ expr $y - $lastY ]
1578 $widgets(canvas) move [ lindex $actROI 1 ] \
1579 [ expr $x - $lastX ] \
1580 [ expr $y - $lastY ]
1581 $widgets(canvas) move [ lindex $actROI 2 ] \
1582 [ expr $x - $lastX ] \
1583 [ expr $y - $lastY ]
1584 $widgets(canvas) move [ lindex $actROI 3 ] \
1585 [ expr $x - $lastX ] \
1586 [ expr $y - $lastY ]
1593 #* PROCEDURE DESCRIPTION *************************************************
1595 #* ::imagepp::moveCorner (procedure) *
1597 #* DESCRIPTION : Event callback. Move a rectangle corner. *
1598 #* This is a dummy proc, don't call it in your code. *
1600 #* SYNTAX : ::imagepp::moveCorner %W %x %y $i *
1602 #* RETURN : -NONE- *
1605 #* w : string. Widget name. *
1606 #* x : string. x-coordinate. *
1607 #* y : string. y-coordinate. *
1608 #* i : string. Corner index. *
1610 #******************************************************* END DESCRIPTION *
1611 proc ::imagepp::moveCorner { w x y i } {
1613 # For namespace access
1614 upvar ::imagepp::${w}::options options
1615 upvar ::imagepp::${w}::widgets widgets
1616 upvar ::imagepp::${w}::localIds localIds
1617 upvar ::imagepp::${w}::hNeed hNeed
1618 upvar ::imagepp::${w}::vNeed vNeed
1619 upvar ::imagepp::${w}::actROI actROI
1620 upvar ::imagepp::${w}::lastX lastX
1621 upvar ::imagepp::${w}::lastY lastY
1623 set widgets(movingroi) 1
1625 $widgets(canvas) move [ lindex $actROI $i ] \
1626 [ expr $x - $lastX ] \
1627 [ expr $y - $lastY ]
1631 $widgets(canvas) move [ lindex $actROI 1 ] \
1632 0 [ expr $y - $lastY ]
1634 $widgets(canvas) move [ lindex $actROI 3 ] \
1635 [ expr $x - $lastX ] 0
1637 } elseif { $i == 1 } {
1639 $widgets(canvas) move [ lindex $actROI 0 ] \
1640 0 [ expr $y - $lastY ]
1642 $widgets(canvas) move [ lindex $actROI 2 ] \
1643 [ expr $x - $lastX ] 0
1645 } elseif { $i == 2 } {
1647 $widgets(canvas) move [ lindex $actROI 3 ] \
1648 0 [ expr $y - $lastY ]
1650 $widgets(canvas) move [ lindex $actROI 1 ] \
1651 [ expr $x - $lastX ] 0
1653 } elseif { $i == 3 } {
1655 $widgets(canvas) move [ lindex $actROI 2 ] \
1656 0 [ expr $y - $lastY ]
1658 $widgets(canvas) move [ lindex $actROI 0 ] \
1659 [ expr $x - $lastX ] 0
1664 set c0 [ $widgets(canvas) coords [ lindex $actROI 0 ] ]
1665 set ux [ lindex $c0 0 ]; set uy [ lindex $c0 1 ]
1666 set bx [ lindex $c0 2 ]; set by [ lindex $c0 3 ]
1668 set c0 [ $widgets(canvas) coords [ lindex $actROI 1 ] ]
1669 set ux [ expr ( [ lindex $c0 0 ] < $ux )? [ lindex $c0 0 ]: $ux ]
1670 set uy [ expr ( [ lindex $c0 1 ] < $uy )? [ lindex $c0 1 ]: $uy ]
1671 set bx [ expr ( [ lindex $c0 2 ] > $bx )? [ lindex $c0 2 ]: $bx ]
1672 set by [ expr ( [ lindex $c0 3 ] > $by )? [ lindex $c0 3 ]: $by ]
1674 set c0 [ $widgets(canvas) coords [ lindex $actROI 2 ] ]
1675 set ux [ expr ( [ lindex $c0 0 ] < $ux )? [ lindex $c0 0 ]: $ux ]
1676 set uy [ expr ( [ lindex $c0 1 ] < $uy )? [ lindex $c0 1 ]: $uy ]
1677 set bx [ expr ( [ lindex $c0 2 ] > $bx )? [ lindex $c0 2 ]: $bx ]
1678 set by [ expr ( [ lindex $c0 3 ] > $by )? [ lindex $c0 3 ]: $by ]
1680 set c0 [ $widgets(canvas) coords [ lindex $actROI 3 ] ]
1681 set ux [ expr ( [ lindex $c0 0 ] < $ux )? [ lindex $c0 0 ]: $ux ]
1682 set uy [ expr ( [ lindex $c0 1 ] < $uy )? [ lindex $c0 1 ]: $uy ]
1683 set bx [ expr ( [ lindex $c0 2 ] > $bx )? [ lindex $c0 2 ]: $bx ]
1684 set by [ expr ( [ lindex $c0 3 ] > $by )? [ lindex $c0 3 ]: $by ]
1686 $widgets(canvas) coords [ lindex $actROI 4 ] \