# This software is distributed under the Lesser General Public License
#
# inspector/ports_ctl.tcl
#
# Control for modifying node portss
#
#------------------------------------------ CVS
#
# CVS Headers -- The following headers are generated by the CVS
# version control system. Note that especially the attribute
# Author is not necessarily the author of the code.
#
# $Source: /home/br/CVS/graphlet/lib/graphscript/inspector/ports_ctl.tcl,v $
# $Author: forster $
# $Revision: 1.5 $
# $Date: 1999/03/01 16:58:31 $
# $Locker:  $
# $State: Exp $
#
#------------------------------------------ CVS
#
# (C) University of Passau 1995-1999, Graphlet Project
#     Author: Michael Forster

package require Graphlet
package provide Graphscript [gt_version]

package require Numentry

namespace eval ::GT::IS::ports_ctl {

    namespace export create
    namespace import ::GT::IS::define_attrs
    namespace import ::GT::IS::bind_attrs

    #================================================== Inspector interface
    
    proc create { IS ctl attrs } {
	define_attrs $IS $ctl $attrs { ports }
	
	frame $ctl

	create_widgets   $IS $ctl
	create_layout    $IS $ctl
	create_bindings  $IS $ctl

	variable _Markers
	set _Markers($ctl) {}

	return $ctl
    }
    
    proc create_widgets { IS ctl } {

	# canvas

	::GT::IS::create_node_canvas $ctl.c
	bind $ctl.c <Configure> [namespace code "update $IS $ctl"]

	# port name entry

	entry $ctl.name \
	    -textvariable [namespace current]::_Selection($ctl,name)

	# numentries

	Numentry::create $ctl.x \
	    -textvariable [namespace current]::_Selection($ctl,x) \
	    -width 3 \
	    -min -1 -max 1 -step 0.01 -acceleration 5

	Numentry::create $ctl.y \
	    -textvariable [namespace current]::_Selection($ctl,y) \
	    -width 3 \
	    -min -1 -max 1 -step 0.01 -acceleration 5
    }

    proc create_layout { IS ctl } {
	
	grid columnconfigure $ctl { 0 1 } -weight 1

	grid $ctl.c    -
	grid $ctl.name -
	grid $ctl.x    $ctl.y

	eval grid [grid slaves $ctl] -stick news
    }

    proc create_bindings { IS ctl } {

 	trace var [namespace current]::_Selection($ctl,name) w \
	    [namespace code "ev_current_changed  $IS $ctl ;# "]
	
 	trace var [namespace current]::_Selection($ctl,x) w \
            [namespace code "ev_current_changed  $IS $ctl ;# "]
	
 	trace var [namespace current]::_Selection($ctl,y) w \
            [namespace code "ev_current_changed  $IS $ctl ;# "]

 	bind $ctl.c <Double-Button-1> \
	    [namespace code "ev_insert_or_delete $IS $ctl %x %y"]
	
	bind $ctl.c <Button-2> \
	    [namespace code "ev_insert_or_delete $IS $ctl %x %y"]
	
 	bind $ctl.c <Button-3> \
	    [namespace code "ev_menu             $IS $ctl %X %Y %x %y"]
    }

    proc update { IS ctl } {
	bind_attrs $IS $ctl

	variable ::GT::IS::_HaveNodes
	variable _Selection

	# numentries

	if { $_HaveNodes($IS) } {
	    $ctl.name configure -state normal
	    $ctl.x configure -state normal
	    $ctl.y configure -state normal
	} else {
	    $ctl.name configure -state disabled
	    $ctl.x configure -state disabled
	    $ctl.y configure -state disabled

	    set_selection $IS $ctl ""
	}

	# show markers
	
	bind_attrs $IS $ctl
	variable _Markers

	set port_count [llength $ports]
	set marker_count [llength $_Markers($ctl)]

	if { $port_count > $marker_count } {
	    for { set i 0 } { $i < $port_count-$marker_count } { incr i } {
		create_marker $IS $ctl
	    }
	}

	if { $marker_count > $port_count } {
	    for { set i 0 } { $i < $marker_count-$port_count } { incr i } {
		destroy_marker $IS $ctl [lindex $_Markers($ctl) end]
	    }
	}

	foreach port $ports m $_Markers($ctl) {
	    GT::pset { name x y } $port

	    set _Markers($ctl,$m,name) $name
	    set _Markers($ctl,$m,x) [expr $x]
 	    set _Markers($ctl,$m,y) [expr $y]
 	}

 	# selection

 	if { ![info exists _Selection($ctl)] || $_Selection($ctl) == {} } {
	    if { $port_count > 0 } {
		set_selection $IS $ctl [lindex $_Markers($ctl) 0]
	    } else {
		set_selection $IS $ctl ""
	    }
 	}
	
	update_markers $IS $ctl
    }
    
    proc update_markers { IS ctl } {
	
	variable _Markers
	variable _Selection
	variable ::GT::IS::_Options
	bind_attrs $IS $ctl

	GT::pset { bx by iw ih } [::GT::IS::get_canvas_coords $ctl.c]
	GT::pset { mw mh } $_Options(marker_size)

	foreach m $_Markers($ctl) {

	    set mx $_Markers($ctl,$m,x)
	    set my $_Markers($ctl,$m,y)

	    set mx [expr $bx + $iw*($mx+1)/2.0]
	    set my [expr $by + $ih*($my+1)/2.0]

	    $ctl.c coords $m \
		[expr $mx - $mw/2] [expr $my - $mh/2] \
		[expr $mx + $mw/2] [expr $my + $mh/2]

 	    if { $_Selection($ctl) == $m } {
 		$ctl.c itemconfigure $m \
 		    -fill $_Options(color,marker,fill,selected) \
 		    -outline $_Options(color,marker,outline,selected)
		
 	    } else {
		
 		$ctl.c itemconfigure $m \
 		    -fill $_Options(color,marker,fill) \
 		    -outline $_Options(color,marker,outline)
 	    }
	}
    }

    #================================================== Event handling

    proc ev_current_changed { IS ctl } {
	variable _Selection
	variable _Markers
	
	bind_attrs $IS $ctl

	if { [info exists _Selection($ctl,notrace)] } {
	    return
	}

	set m $_Selection($ctl)

	set _Markers($ctl,$m,name) $_Selection($ctl,name)
	set_marker_pos $IS $ctl $m $_Selection($ctl,x) $_Selection($ctl,y)
    }	
    
    proc ev_insert_or_delete { IS ctl mx my } {
	variable ::GT::IS::_HaveNodes

	if { $_HaveNodes($IS) } {
	
	    set m [$ctl.c find withtag current]
	    set tags [$ctl.c itemcget $m -tags]
	    
	    if { $m == {} || ![GT::lcontains $tags markers]  } {
		ev_insert_marker $IS $ctl $mx $my
	    } else {
		ev_delete_marker $IS $ctl $m
	    }
	}
    }
    
    proc ev_insert_marker { IS ctl mx my } {
	variable _Markers

	GT::pset { x y w h } [::GT::IS::get_canvas_coords $ctl.c]
	GT::pset { mx my } [abs_to_rel [list $mx $my] $x $y $w $h]

	if { $mx >= -1 && $mx <=  1 && $my >= -1 && $my <=  1 } {

	    set numbers {}
	    foreach m $_Markers($ctl) {
		set name $_Markers($ctl,$m,name)
		if [regexp {Port([0-9]+)} $name - number] {
		    lappend numbers $number
		}
	    }

	    set number 0
	    set last_number -1
	    foreach number [lsort -integer $numbers] {
		if { $number > $last_number+1 } {
		    set number [expr $last_number+1]
		    break
		}
		set last_number $number
		incr number
	    }
	    
	    set m [create_marker $IS $ctl]
	    set _Markers($ctl,$m,name) "Port$number"
	    set_marker_pos $IS $ctl $m $mx $my
	}
    }
    
    proc ev_delete_marker { IS ctl m } {
	bind_attrs $IS $ctl
	variable _Markers

	destroy_marker $IS $ctl $m
	
 	update_markers $IS $ctl
    }

    proc ev_move_marker { IS ctl m mx my } {

 	GT::pset { x y w h } [::GT::IS::get_canvas_coords $ctl.c]
	GT::pset { mx my } [abs_to_rel [list $mx $my] $x $y $w $h]
	
	if { $mx < -1	} { set mx -1 }
	if { $mx >  1	} { set mx  1 }
	if { $my < -1	} { set my -1 }
	if { $my >  1	} { set my  1 }

	set_marker_pos $IS $ctl $m $mx $my
    }
    
    proc ev_menu { IS ctl X Y x y } {
	variable ::GT::IS::_HaveNodes

	if { $_HaveNodes($IS) } {
	    set menu $ctl.menu

	    if { ![winfo exists $menu] } {
		set menu [menu $menu -tearoff false]
	    }

	    $menu delete 0 end

	    set m [$ctl.c find withtag current]
	    set tags [$ctl.c itemcget $m -tags]
	    
	    if { $m == {} || ![GT::lcontains $tags markers]  } {
		
		variable _LastX $x
		variable _LastY $y
		
		$menu add command \
		    -label "Add Port" \
		    -command [namespace code "ev_insert_marker $IS $ctl \$_LastX \$_LastY"]
		
	    } else {
		
		variable _LastM $m
		
		$menu add command \
		    -label "Delete Port" \
		    -command [namespace code "ev_delete_marker $IS $ctl \$_LastM"]
		
	    }	

	    tk_popup $menu $X $Y
	}
    }

    proc ev_select_marker { IS ctl m } {
	set_selection $IS $ctl $m
    }

    #================================================== Polygon Markers

    proc create_marker { IS ctl { before {} } } {
	variable _Markers
	variable ::GT::IS::_Options
	variable _Selection

	# create canvas items
	
	set m [$ctl.c create rectangle \
		   0 0 0 0 \
		   -fill $_Options(color,marker,fill) \
		   -outline $_Options(color,marker,outline) \
		   -tag markers \
		  ]

	lappend _Markers($ctl) $m
	set _Markers($ctl,$m,name) ""
	set _Markers($ctl,$m,x) 0
	set _Markers($ctl,$m,y) 0
	
	# bindings
	
 	$ctl.c bind $m <Button-1>	[namespace code "ev_select_marker           $IS $ctl $m         "]
 	$ctl.c bind $m <B1-Motion>	[namespace code "ev_move_marker             $IS $ctl $m    %x %y"]

	return $m
    }

    proc destroy_marker { IS ctl m } {
	variable _Markers
	variable _Selection

	# delete canvas items
	
	$ctl.c delete $m

	# update _Markers($ctl)
	
	GT::ldelete _Markers($ctl) $m
	foreach entry [array names _Markers $ctl,$m,*] {
	    unset _Markers($entry)
	}
 	if { $_Selection($ctl) == $m } {
 	    set_selection $IS $ctl [lindex $_Markers($ctl) 0]
 	}

	write_ports $IS $ctl
    }

    proc set_selection { IS ctl m } {
	variable _Selection
	variable _Markers

	set _Selection($ctl,notrace) 1
	set _Selection($ctl) $m
	if { $m != {} } {
	    set _Selection($ctl,name) $_Markers($ctl,$m,name)
	    set _Selection($ctl,x) $_Markers($ctl,$m,x)
	    set _Selection($ctl,y) $_Markers($ctl,$m,y)
	} else {
	    set _Selection($ctl,name) ""
	    set _Selection($ctl,x) ""
	    set _Selection($ctl,y) ""
	}
	unset _Selection($ctl,notrace)
	
 	update_markers $IS $ctl
    }

    proc set_marker_pos { IS ctl m mx my } {
	variable _Markers

	set _Markers($ctl,$m,x) $mx
	set _Markers($ctl,$m,y) $my

	set_selection $IS $ctl $m

	GT::pset { x y w h } [::GT::IS::get_canvas_coords $ctl.c]

	write_ports $IS $ctl
    }
    
    proc write_ports { IS ctl } {
	variable _Markers
	bind_attrs $IS $ctl

	set p {}
	foreach m $_Markers($ctl) {
	    lappend p [list \
			    $_Markers($ctl,$m,name) \
			    $_Markers($ctl,$m,x) \
			    $_Markers($ctl,$m,y)\
			   ]
	}
	set ports $p
	
	update_markers $IS $ctl
    }
    
    # convert absolute to relative coordinates
    proc abs_to_rel { abs x y w h } {

	set rel {}
	foreach { ax ay } $abs {
	    
	    set rx [expr 2.0 * ($ax - $x) / $w - 1]
	    set ry [expr 2.0 * ($ay - $y) / $h - 1]

	    set rx [expr round($rx*100)*0.01]
	    set ry [expr round($ry*100)*0.01]
	    
	    lappend rel $rx $ry
	}
	return $rel
    }
}

#---------------------------------------------------------------------------
#   Set emacs variables
#---------------------------------------------------------------------------
# ;;; Local Variables: ***
# ;;; mode: tcl ***
# ;;; tcl-indent-level: 4 ***
# ;;; End: ***
#---------------------------------------------------------------------------
#   end of file
#---------------------------------------------------------------------------
