path: root/vendor/x11iraf/guidemo/marker.gui

# 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: \
	    <Btn1Down>: call(polyMarker, $x, $y) \n\
	 <EnterWindow>: enter-window()           \n\
	 <LeaveWindow>: leave-window()           \n\
	    <KeyPress>: graphics-input()         \n\
	      <Motion>: 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 <Btn1Motion>:     m_rotateResize()
              <Btn1Motion>:     m_moveResize()
         !Shift <Btn1Down>:     m_raise()  m_markpos()
                <Btn1Down>:     m_raise()  m_markposAdd()
                  <Btn1Up>:     m_redraw() m_destroyNull()
                <Btn2Down>:     m_lower()
                <Btn3Down>:     popup(markerMenu)
                  <Btn3Up>:     popdown(markerMenu)
            <Key>BackSpace:     m_deleteDestroy()
               <Key>Delete:     m_deleteDestroy()
                <KeyPress>:     m_input()
                  <Motion>:     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
}