# This software is distributed under the Lesser General Public License
#
# inspector/label_anchor_ctl.tcl
#
# Control for modifying label anchors
#
#------------------------------------------ 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/label_anchor_ctl.tcl,v $
# $Author: forster $
# $Revision: 1.2 $
# $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]

namespace eval ::GT::IS::label_anchor_ctl {

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

    proc create { IS ctl attrs } {
	
	define_attrs $IS $ctl $attrs { lanchor anchor }
	variable ::GT::IS::_Options

	frame $ctl

	set c $ctl.c
	
	pack [canvas $c \
		   -width 0 \
		   -height 0 \
		   -takefocus 1 \
		  ] \
	    -fill both -expand true

	# node
	
	$c create rectangle 0 0 0 0 \
	    -tags [list node:outline node_parts] \
	    -fill $_Options(color,template,outline) \
	    -outline {}

	$c create rectangle 0 0 0 0 \
	    -tags [list node:fill node_parts] \
	    -fill $_Options(color,template,fill) \
	    -outline {}
	
	$c create line 0 0 0 0 \
	    -tags [list node:vertical node_parts] \
	    -fill $_Options(color,template,outline)
	
	$c create line 0 0 0 0 \
	    -tags [list node:horizontal node_parts] \
	    -fill $_Options(color,template,outline) 

	# label

	$c create rectangle 0 0 0 0 \
	    -tags [list label label_parts]\
	    -fill $_Options(color,label,fill) \
	    -outline $_Options(color,label,outline)
	
	$c create line 0 0 0 0 \
	    -tags [list label:vertical label_parts] \
	    -fill $_Options(color,label,outline)
	
	$c create line 0 0 0 0 \
	    -tags [list label:horizontal label_parts] \
	    -fill $_Options(color,label,outline)

	# anchor

	$c create rectangle 0 0 0 0 \
	    -tags [list anchor label_parts] \
	    -fill $_Options(color,marker,fill,selected) \
	    -outline $_Options(color,marker,outline,selected)

	#bindings
	
	bind $c <Configure>	[namespace code "update $IS $ctl"]
	
	bind $c <Up>		[namespace code "move $IS $ctl  0 -1"]
	bind $c <Down>		[namespace code "move $IS $ctl  0 +1"]
	bind $c <Left>		[namespace code "move $IS $ctl -1  0"]
	bind $c <Right>		[namespace code "move $IS $ctl +1  0"]
	
	$c bind label_parts <ButtonPress-1> [namespace code "start_dragging $IS $ctl %x %y"]
	$c bind label_parts <B1-Motion> [namespace code "drag_to $IS $ctl %x %y"]
	
	return $ctl
    }

    proc update { IS ctl } {
	bind_attrs $IS $ctl
	variable ::GT::IS::_Options
	variable ::GT::IS::_HaveNodes

	# enable / disable

	if { $_HaveNodes($IS) } {
	    $ctl.c itemconfigure node_parts -stipple {}
	} {
	    $ctl.c itemconfigure node_parts -stipple gray50
	}
	
	# canvas size
	
	set bw 26.0			;# border width
	set bh 16.0			;# border height

	set ow [winfo width $ctl.c]	;# outer widht
	set iw [expr $ow - 2*$bw]	;# inner width
	set ih $iw			;# inner height
	set oh [expr $iw + 2*$bh]	;# outer height

	$ctl.c configure -height $oh

	# node coordinates
	
	$ctl.c coords node:outline \
	    $bw $bh \
	    [expr $ow - $bw] [expr $oh - $bh]

	$ctl.c coords node:fill \
	    [expr $bw + 1] [expr $bh + 1] \
	    [expr $ow - $bw - 1] [expr $oh - $bh - 1]
	
	$ctl.c coords node:vertical \
	    [expr $ow/2] $bh \
	    [expr $ow/2] [expr $oh - $bh]
	
	$ctl.c coords node:horizontal \
	    $bw [expr $oh/2] \
	    [expr $ow - $bw] [expr $oh/2]

	if { $_HaveNodes($IS) } {
	    # anchor coordinates
	
	    anchor_to_coords $lanchor lrelx lrely
	    anchor_to_coords $anchor relx rely
	    
	    GT::pset { aw ah } $_Options(marker_size)
	    set ax [expr $bw + (1-$lrelx)*$iw/2]
	    set ay [expr $bh + (1-$lrely)*$ih/2]

	    $ctl.c coords anchor \
		[expr $ax - $aw/2] [expr $ay - $ah/2] \
		[expr $ax + $aw/2] [expr $ay + $ah/2]

	    # label coordinates
	    
	    set lw 24.0			;# label width
	    set lh 12.0 			;# label height

	    set lx [expr $ax - (1+$relx)*$lw/2]
	    set ly [expr $ay - (1+$rely)*$lh/2]

	    $ctl.c coords label \
		$lx $ly \
		[expr $lx+$lw] [expr $ly+$lh]
	    
	    $ctl.c coords label:vertical \
		[expr $lx+$lw/2] $ly \
		[expr $lx+$lw/2] [expr $ly+$lh]
	    
	    $ctl.c coords label:horizontal \
		$lx [expr $ly+$lh/2] \
		[expr $lx+$lw] [expr $ly+$lh/2]
	    
	} else {
	    $ctl.c coords label -1 -1 -1 -1
	    $ctl.c coords label:vertical -1 -1 -1 -1
	    $ctl.c coords label:horizontal -1 -1 -1 -1
	    $ctl.c coords anchor -1 -1 -1 -1
	}
    }

    proc move { IS ctl dx dy } {
	bind_attrs $IS $ctl

	anchor_to_coords $anchor x y
	anchor_to_coords $lanchor lx ly

	set x [expr $x - $dx ]
	set y [expr $y - $dy ]

	while { $lx > -1 && $x < -1 } {
	    set x [expr $x + 3]
	    set lx [expr $lx - 1]
	}
	while { $lx < +1 && $x > +1 } {
	    set x [expr $x - 3]
	    set lx [expr $lx + 1]
	}
	while { $ly > -1 && $y < -1 } {
	    set y [expr $y + 3]
	    set ly [expr $ly - 1]
	}
	while { $ly < +1 && $y > +1 } {
	    set y [expr $y - 3]
	    set ly [expr $ly + 1]
	}
	
	coords_to_anchor $x $y anchor
	coords_to_anchor $lx $ly lanchor

	update $IS $ctl
    }
    
    proc start_dragging { IS ctl x y } {
	variable _DragX
	variable _DragY
	
	set coords [$ctl.c coords label]
	set _DragX($ctl) [expr $x - [lindex $coords 0]]
	set _DragY($ctl) [expr $y - [lindex $coords 1]]
    }
    
    proc drag_to { IS ctl x y } {
	variable _DragX
	variable _DragY
	bind_attrs $IS $ctl

	set bw 26.0					;# border width
	set bh 16.0					;# border height

	set ow [winfo width $ctl.c]			;# outer widht
	set oh [winfo height $ctl.c]			;# outer height
	set iw [expr $ow - 2*$bw]			;# inner width
	set ih [expr $oh - 2*$bh]			;# inner height

	set lw 24.0					;# label width
	set lh 12.0 					;# label height

	set lcx [expr $x - $_DragX($ctl) + $lw/2]	;# label center x
	set lcy [expr $y - $_DragY($ctl) + $lh/2]	;# label center y

	# label_anchor
	
	set relx [abs_to_rel $lcx [expr $bw + $iw/2.0] $bw]
	set rely [abs_to_rel $lcy [expr $bh + $ih/2.0] $bh]

	coords_to_anchor $relx $rely new_lanchor

	# anchor
	
	set lanchor_x [expr $bw + (1-$relx)*$iw/2]
	set lanchor_y [expr $bh + (1-$rely)*$ih/2]

	set relx [abs_to_rel $lcx $lanchor_x [expr $lanchor_x - $lw/2.0]]
	set rely [abs_to_rel $lcy $lanchor_y [expr $lanchor_y - $lh/2.0]]

	coords_to_anchor $relx $rely new_anchor

	# set new values
	
	if { $new_anchor != $anchor } {
	    set anchor $new_anchor
	}
	if { $new_lanchor != $lanchor } {
	    set lanchor $new_lanchor
	}
	
	update $IS $ctl
    }

    proc anchor_to_coords { anchor relxName relyName } {
	upvar 1 $relxName relx
	upvar 1 $relyName rely

	array set convert {
	    nw {-1 -1}	    n   {0 -1}	    ne {1 -1}
	    w  {-1  0}	    c   {0  0}	    e  {1  0}
	    sw {-1  1}	    s   {0  1}	    se {1  1}
	}
	
	GT::pset { relx rely } $convert($anchor)
    }

    proc coords_to_anchor { relx rely anchorName } {
	upvar 1 $anchorName anchor

	array set convert {
	    -1,-1 nw	0,-1 n		1,-1 ne
	    -1,0   w	0,0  c		1,0   e
	    -1,1  sw	0,1  s		1,1  se
	}

	set anchor $convert($relx,$rely)
    }

    proc abs_to_rel { val to_zero to_one } {
	set rel [expr round(($val-$to_zero)/($to_one-$to_zero))]
	
	if { $rel != 0 } {
	    set rel [expr $rel/abs($rel)]
	}
	
	return $rel
    }
}

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