# REGION.GUI -- Demo the use of region markers.
# This GUI can be run as "cl> hello gui=region.gui".

reset-server
appInitialize regions Regions {
    *objects:\
	toplevel	Paned		panel\
	panel		Box		control\
	panel		Gterm		graphics\
	panel		AsciiText	output\
	control		Command		quitButton\
	control		Command		measureButton\
	control		Toggle		skyButton

    *background:				gray
    *foreground:				black
    *menubar.showGrip:				False
    *menubar.skipAdjust:			True
    *menubar.width:				480
    *skyButton.label:				Annulus
    *measureButton.label:			Measure
    *quitButton.label:				Quit

    *graphics.resizable:			true
    *graphics.ginmodeCursor:			circle
    *graphics.width:				640
    *graphics.height:				480

    *output.width:				480

    *graphics.translations:	\
		 <Btn1Down>:  call(makeMarker,$name,$x,$y) m_create() \n\
	  !Shift <Btn2Down>:  crosshair(on)	\n\
	!Shift <Btn2Motion>:  crosshair(on)	\n\
		   <Btn2Up>:  crosshair(off)	\n\
	      <EnterWindow>:  enter-window()	\n\
	      <LeaveWindow>:  leave-window()	\n\
		 <KeyPress>:  graphics-input()	\n\
		   <Motion>:  track-cursor()

    *allowShellResize:				true
    *shapeStyle:				Rectangle
    *beNiceToColormap:				False
    *Label*shadowWidth:				2
}

# Start up the GUI.
createObjects
send graphics setGterm
activate

# Global variables
set marker objMarker			;# only one marker currently
set skyGap 10				;# gap to sky annulus
set skyWidth 15				;# width of sky annulus


# Procedures.
# -------------------------

proc quit args { send client gkey q; deactivate unmap }
send quitButton addCallback quit

# Get a description of the region and print it in the output window.
proc measure args {
    global marker

    # getRegion unmap will reverse any mappings and return raster coords.
    set region [send $marker getRegion unmap]
    send output set string $region

}; send measureButton addCallback measure


# Draw/erase sky annulus.  Once created these are not tied to the object
# region and the user is expected to toggle the skyButton to erase and
# redraw the annulus markers if the object marker is moved.  If we wanted
# to be fancier about this we could register a move callback with the object
# marker and redraw the annulus markers at the new location if the object
# marker is moved.  Currently there is no way to group markers so that they
# behave as one object.

proc annulus args {
    global skyGap skyWidth
    global marker

    # In this case we use getRegion with no args, which returns window coords.
    set region [send $marker getRegion]

    if [send skyButton get state] {
	set x [lindex $region 2]
	set y [lindex $region 3]
	set width [lindex $region 4]
	set height [lindex $region 5]
	set rotangle [lindex $region 6]

	# Create a marker outlining the inner boundary of the annulus region.
	# See obm/ObmW/Gterm.h for a list of marker attributes.

	send graphics createMarker sky1 \
	    type		ellipse \
	    createMode		noninteractive \
	    lineColor		blue \
	    highlightColor	blue \
	    x			$x \
	    y			$y \
	    width		[expr "$width + $skyGap"] \
	    height		[expr "$height + $skyGap"] \
	    rotangle		$rotangle \
	    activated		True \
	    visible		True \
	    sensitive		False

	# Create a marker outlining the outer boundary of the annulus region.
	send graphics createMarker sky2 \
	    type		ellipse \
	    createMode		noninteractive \
	    lineColor		blue \
	    highlightColor	blue \
	    x			$x \
	    y			$y \
	    width		[expr "$width + $skyGap + $skyWidth"] \
	    height		[expr "$height + $skyGap + $skyWidth"] \
	    rotangle		$rotangle \
	    activated		True \
	    visible		True \
	    sensitive		False

	send sky1 "redraw noerase; lower"
	send sky2 "redraw noerase; lower"

    } else {
	send sky1 destroy
	send sky2 destroy
    }

}; send skyButton addCallback annulus


# Support routines.
# -------------------------

# Create marker action.  Makes a new marker.
proc makeMarker { parent x y } \
{
	global markerTranslations marker

	send $parent createMarker $marker \
	    type		ellipse \
	    createMode		interactive \
	    translations	$markerTranslations \
	    lineColor		green \
	    x			$x \
	    y			$y

	send $marker addCallback moveResize moveResize
}

proc moveResize args {
    print "moveResize called: $args"
}


# Translations when pointer is inside a marker.
set markerTranslations { \
       !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()
}

# Popup menu in effect when inside marker.
createMenu markerMenu graphics {
    {	Object		f.title			}
    {			f.dblline		}
    {	Measure		f.exec {
			    measure
			}			}
    {	Dummy1		f.exec {
			    print dummy1  ;# (replace by real code)
			}			}
    {	Dummy2		f.exec {
			    print dummy2  ;# (replace by real code)
			}			}
    {			f.line			}
    {	Destroy		f.exec {
			    send $marker destroy
			}			}
}