# MTEST.GUI -- reset-server appInitialize mtest Mtest { ! ! Application defaults for the hello world program. ! Mtest*objects:\ toplevel Layout imgLayout \ imgLayout Frame imviewFrame \ imviewFrame Gterm gterm \ imgLayout Layout tclLayout\ tclLayout Group tclCmdGroup\ tclLayout Frame tclFrame\ tclFrame AsciiText tclEntry\ tclCmdGroup Layout tclCmd\ tclCmd Command tclClear\ tclCmd Command tclExecute\ tclCmd Command quitButton\ *shrinkToFit: True *imgLayout*borderWidth: 0 *imgLayout*highlightThickness: 0 *imgLayout*background: ivory3 *imgLayout*Frame*background: ivory3 *imgLayout*Frame*frameWidth: 2 *imgLayout*Command.highlightThickness: 2 *imgLayout.layout: vertical { \ imviewFrame < +inf -inf * +inf -inf > \ tclLayout < +inf -inf * +inf -inf > \ } *imgLayout*imviewFrame.outerOffset: 5 *imgLayout*imviewFrame.innerOffset: 0 *imgLayout*imviewFrame.frameWidth: 3 *imgLayout*imviewFrame.frameType: sunken *gterm.cmapName: image *gterm.width: 400 *gterm.height: 300 *gterm.borderColor: black *gterm.resizable: True *gterm.copyOnResize: False *gterm.ginmodeCursor: circle *gterm.dialogBgColor: cyan *gterm.dialogFgColor: black *gterm.crosshairCursorColor: cyan *gterm.translations: \ : call(polyMarker, $x, $y) \n\ : enter-window() \n\ : leave-window() \n\ : graphics-input() \n\ : track-cursor() call(wcsUpdate,$x,$y) ! Define a Debug Tcl shell. !-------------------------- *tclLayout*borderWidth: 0 *tclLayout*Frame.frameType: sunken *tclLayout*Frame.frameWidth: 2 *tclLayout*Frame.outerOffset: 5 *imgLayout*tclLayout*Text*foreground: wheat2 *imgLayout*tclLayout*Text*background: gray35 *tclLayout*Text*height: 90 *tclLayout*Text*editType: edit *tclLayout.layout: vertical { \ tclFrame < +inf -inf * > \ tclCmdGroup < +inf -inf * > \ } ! Do the command bar group resources. !------------------------------------ *tclCmdGroup.width: 300 *tclCmdGroup.height: 40 *tclCmdGroup.label: *tclCmdGroup.outerOffset: 0 *tclCmdGroup.innerOffset: 5 *tclCmdGroup*Command.background: ivory3 *tclCmd.layout: horizontal { \ 5 \ tclClear tclExecute \ 50 < +inf -inf > \ quitButton \ 5 \ } *tclClear.label: Clear *tclExecute.label: Execute *quitButton.label: Quit } createObjects activate proc Quit args { send client gkey q ; deactivate unmap }; send quitButton addCallback Quit # Define some TCL debug procedures send tclClear addCallback "send tclEntry set string \"\"" proc tclExec args { send server [send tclEntry get string] } ; send tclExecute addCallback tclExec # Define a WCS box to track coords proc makeWCSMarker { args } { send gterm createMarker wcsbox { type text createMode noninteractive width 20ch height 1ch lineWidth 0 imageText true textBgColor black textColor yellow visible false } set box_width [send wcsbox get width] set box_height [send wcsbox get height] set defGeom [format "%sx%s-5-5" $box_width $box_height] send gterm parseGeometry "-5-5" $defGeom x y width height send wcsbox setAttributes \ x $x \ y $y \ activated true \ visible true \ sensitive true } ; makeWCSMarker proc wcsUpdate {x y} \ { # Update coords box. set text [ format " %7.2f %7.2f " $x $y ] send wcsbox "set text \{$text\}; redraw noerase" } createMenu markerMenu toplevel { { "Marker Type" f.title } { f.dblline } { "Box" f.exec "set_mtype box" } { "Circle" f.exec "set_mtype circle" } { "Ellipse" f.exec "set_mtype ellipse" } { "Polygon" f.exec "set_poly polygon" } { "Rectangle" f.exec "set_mtype rectangle" } { "Text" f.exec "set_mtype text" } { f.dblline } { "Print geometry" f.exec "print [send objmarker getRegion]" } } proc set_mtype { type } { send objmarker "markpos; set type $type; redraw" } proc set_poly args { send objmarker getAttributes x xcur y ycur set poly "{ { [expr "$xcur+00"] [expr "$ycur+00"] } \ { [expr "$xcur-50"] [expr "$ycur+20"] } \ { [expr "$xcur-50"] [expr "$ycur-30"] } \ { [expr "$xcur+00"] [expr "$ycur-50"] } \ { [expr "$xcur+50"] [expr "$ycur-30"] } \ { [expr "$xcur+50"] [expr "$ycur+20"] } }" send objmarker "markpos; set type polygon; redraw" #print "input vertices=" $poly #send objmarker setVertices $poly #send objmarker getVertices tpoly #print "output vertices=" $tpoly send objmarker getAttributes x x y y width w height h type t rotangle r } # Translations when pointer is inside a marker. Notice I have turned of # all resizeing and rotating options set objmarkerTranslations { \ !Shift : m_rotateResize() : m_moveResize() !Shift : m_raise() m_markpos() : m_raise() m_markposAdd() : m_redraw() m_destroyNull() : m_lower() : popup(markerMenu) : popdown(markerMenu) BackSpace: m_deleteDestroy() Delete: m_deleteDestroy() : m_input() : track-cursor() } set mtype ellipse set mtype text set mtype rectangle set mtype polygon set mtype box set mtype circle proc polyMarker { xcur ycur } { global objmarkerTranslations mtype print "marker type=" $mtype print "position =" $xcur " " $ycur set posangle 0 send gterm createMarker objmarker \ type $mtype \ createMode noninteractive \ translations $objmarkerTranslations \ lineColor red \ knotSize 1 \ knotColor yellow \ x [expr $xcur + 000] \ y [expr $ycur + 000] \ width 50 \ height 50 \ rotangle $posangle \ rotIndicator True \ highlightColor green \ textBgColor black \ imageText True \ activated True \ visible False \ sensitive True # Closed polygon. set poly "{ { [expr "$xcur+00"] [expr "$ycur+00"] } \ { [expr "$xcur-50"] [expr "$ycur+20"] } \ { [expr "$xcur-50"] [expr "$ycur-30"] } \ { [expr "$xcur+00"] [expr "$ycur-50"] } \ { [expr "$xcur+50"] [expr "$ycur-30"] } \ { [expr "$xcur+50"] [expr "$ycur+20"] } \ { [expr "$xcur+00"] [expr "$ycur+00"] } }" # Unclosed polygon. set poly "{ { [expr "$xcur+00"] [expr "$ycur+00"] } \ { [expr "$xcur-50"] [expr "$ycur+20"] } \ { [expr "$xcur-50"] [expr "$ycur-30"] } \ { [expr "$xcur+00"] [expr "$ycur-50"] } \ { [expr "$xcur+50"] [expr "$ycur-30"] } \ { [expr "$xcur+50"] [expr "$ycur+20"] } }" if { $mtype == "polygon" } { print "input vertices=" $poly # Note a setVertices resets the initial rotation angle to 0.0 send objmarker setVertices $poly send objmarker setAttribute rotangle $posangle send objmarker setAttributes x $xcur y $ycur send objmarker getVertices tpoly print "output vertices=" $tpoly print [send objmarker getRegion] } send objmarker getAttributes x x y y width w height h type t rotangle r print "initial attributes " $x $y $w $h $t $r #send objmarker addCallback markerConstraint constraint if { $mtype == "text" } { set text "This is a test string" send objmarker "set text \{$text\}; redraw noerase" } send objmarker set visible True print "AFter visible - " print "getRegions= " [send objmarker getRegion] send objmarker getVertices tpoly print "getVertices= " $tpoly send objmarker getAttributes x x y y width w height h type t rotangle r print "visible attributes " $x $y $w $h $t $r } proc markerConstraint { marker event attributes } { set constraints [ ] #print $marker $event $attributes # Constrain X and Y to not move. foreach i $attributes { set old [lindex $i 1] set new [lindex $i 2] switch [lindex $i 0] { x { if {[send $marker get type] == "rectangle "} { lappend constraints "x $old" } else { lappend constraints "x $new" } } y { if {[send $marker get type] == "rectangle "} { lappend constraints "y $old" } else { lappend constraints "y $new" } } width { lappend constraints "width $new" } height { lappend constraints "height $new" } rotangle { lappend constraints "rotangle $new" } } } return $constraints }