#
# Copyright 2005-2013 the Boeing Company.
# See the LICENSE file included in this distribution.
#

array set left_tooltips {
	select	"selection tool"
	start	"start the session"
	link	"link tool"
	routers "network-layer virtual nodes"
	hubs	"link-layer nodes"
	bgobjs	"background annotation tools"
	routers0	"router"
	routers1	"host"
	routers2	"pc"
	hubs0	"ethernet hub"
	hubs1	"ethernet switch"
	hubs2	"wireless LAN"
	hubs3	"rj45 physical interface tool"
	hubs4	"tunnel tool"
	hubs5	"ktunnel tool"
	bgobjs0	"marker"
	bgobjs1	"oval"
	bgobjs2	"rectangle"
	bgobjs3	"text"
	stop	"stop the session"
	marker	"marker"
	mobility "add and remove static links"
	twonode	"run command from one node to another"
}

proc leftToolTip { w parent } {
    global left_tooltips g_prefs
    if { ! $g_prefs(gui_show_tooltips) } { return } ;# user has turned off ttips
    if { ![info exists left_tooltips($w)] } { return }
    balloon $parent.$w $left_tooltips($w)
}

#
# Show a sub-menu tooltip. This is called from a <<MenuSelect>> event.
proc leftToolTipSubMenu { w } {
    global left_tooltips g_prefs
    if { ! $g_prefs(gui_show_tooltips) } { return } ;# user has turned off ttips

    set index [$w index active]
    if { $index == "none" } { return }

    # fix window path for submenus
    if { [lindex [split $w .] end] == "menu" } {
	set newlen [expr {[string length $w] - 6}]
	set w [string range $w 0 $newlen]
    }
    # set ypos [$w yposition $index]
    set wmx [expr [winfo rootx $w] + ($index * 64)]
    set wmy [expr [winfo rooty $w]+int(1.5*[winfo height $w])]
    # puts "submenu: $index = $ypos"
    set submenu [lindex [split $w .] end]
    if { [info exists left_tooltips($submenu$index)] } {
	set caption $left_tooltips($submenu$index)
    } elseif { [info exists left_tooltips($w)] } {
	set caption $left_tooltips($w)
    } else {
	return
    }
    ::balloon::show2 $w $wmx $wmy $caption
}

proc floatingInfo3 { c node } {
    global zoom
#    if { $oper_mode != "exec" } {
#	return
#    }
    if { $node != "" } {
	# this floating info already exists
        if { [$c find withtag "floatinfo && $node"] != "" } {
	    return
        }
    } else {
	# popdown floating info
        $c delete -withtag floatinfo
	return
    }
    set coords [getNodeCoords $node]
    set x [expr {int([lindex $coords 0] * $zoom)}]
    set y [expr {int([lindex $coords 1] * $zoom)}]
    set w ""
    set wmx [expr [winfo rootx $c] + $x + 40]
    set wmy [expr [winfo rooty $c] + $y + 40]
# int(1.5*[winfo height $c])
    foreach n [$c find withtag "node && $node"] {
	::balloon::show2 $w $wmx $wmy "$node stuff"
    }
}

# Draw a square gray box on the canvas at the given node's coordinates
# containing the given caption. This is used by the Observer Widgets.
proc floatingInfo { c node caption } {
    global zoom oper_mode

    if { $oper_mode != "exec" } {
	return
    }
    if { $node != "" } {
	# this floating info already exists
        if { [$c find withtag "floatinfo && $node"] != "" } {
	    return
        }
    } else {
	# popdown floating info
        $c delete -withtag floatinfo
	return
    }
    # this controls the rectangle padding
    set offset 5 

    set coords [getNodeCoords $node]
    set x [expr {15 + [lindex $coords 0] * $zoom}]
    set y [expr {10 + [lindex $coords 1] * $zoom}]

    # only one floatinfo visible at a time
    $c delete -withtag floatinfo

    # text
    set float [$c create text $x $y \
			-text $caption -font "fixed 8" \
			-tag "floatinfo $node" -justify left -anchor nw]
    $c bind $float <Leave> "anyLeave $c"
    # text size is variable, base rectangle size on bounding box
    set bbox [$c bbox $float]
    set x1 [expr { [lindex $bbox 0] - $offset}]
    set y1 [expr { [lindex $bbox 1] - $offset}]
    set x2 [expr { [lindex $bbox 2] + $offset}]
    set y2 [expr { [lindex $bbox 3] + $offset}]

    # shadow
    roundRect $c $x1 $y1 [expr $x2 + 1] [expr $y2 + 1] 10.0 -fill black \
	-tag "floatinfo $node"
    # rounded rectangle
    roundRect $c $x1 $y1 $x2 $y2 10.0 -fill gray -tag "floatinfo $node"

    # raise floatinfo above everything else
    $c raise $float

    # check if the rectangle is drawn off the canvas, slide it into view
    set r [.c cget -scrollregion]
    set minx [expr { [lindex $r 0] * [lindex [.c xview] 0] }]
    set maxx [expr { $minx + ([lindex $r 2] * [lindex [.c xview] 1]) }]
    set miny [expr { [lindex $r 1] * [lindex [.c yview] 0] }]
    set maxy [expr { $miny + ([lindex $r 3] * [lindex [.c yview] 1]) }]

    set dx 0; set dy 0
    if { $x2 > $maxx } {	;# slide left
	set dx [expr {$maxx - $x2}]
    } elseif { $x1 < $minx } {	;# slide right
	set dx [expr {$minx - $x1}]
    }
    if { $y2 > $maxy } {	;# slide up
	set dy [expr {$maxy - $y2}]
    } elseif { $y1 < $miny } { 	;# slide down
	set dy [expr {$miny - $y1}]
    }
    if { $dx != 0 || $dy != 0 } {
	after 550 "floatingInfoSlide $c $node $float $dx $dy 200"
    }
}

# slide the floating info box into view
# recursively calls self with decaying function
proc floatingInfoSlide { c node float dx dy delay } {
    #puts "floatingInfoSlide $c $node $dx $dy"
    if { [$c type $float] == "" } {
	return; # this particular floatinfo text no longer exists
    }

    # calculate a new x,y amount to slide the info box, decaying somewhat
    set movex [expr {$dx/3}]; set movey [expr {$dy/3}]

    $c move "floatinfo && $node" $movex $movey

    # calculate amount left to move
    set newdx [expr {$dx - $movex}]; set newdy [expr {$dy - $movey}]
    # slightly increasing delay slows down the sliding effect
    set delay [expr {int($delay * 1.1)}]

    # recursively call self with new parameters, if any movement is left
    if {$newdx != 0 || $newdy != 0} {
	after $delay "floatingInfoSlide $c $node $float $newdx $newdy $delay"
    }
}

# return the width and height (in characters) of the given caption
proc textCharSize { txt } {
    set width 0
    set height 0
    foreach line [split $txt "\n"] {
	set len [string length $line]
	if { $len > $width } { set width $len }
	incr height
    }
    return [list $width $height]
}
# end Boeing


# This is contributed code from http://wiki.tcl.tk/3060
namespace eval balloon {set last 0 ; namespace export balloon}

proc ::balloon::balloon {args} {
   variable last
   variable tips

   set numArgs [llength $args]
   if { $numArgs < 1 || $numArgs > 2 } {
        return -code error "wrong # args: should be \"balloon widget ?text?\"";
      }

   set w [lindex $args 0]
   if { ![winfo exists $w] } {
        return -code error "bad window path name \"$w\""
      }

   if { [winfo class $w] == "Toplevel" } {
        return -code error "cannot create tooltip for toplevel windows";
      }

   if { $numArgs == "1" } {
        if { [info exists tips($w)] } {
             return $tips($w);
           } else {
             return "";
           }
      }

   set text [lindex $args 1]

   if { $text == "" } {
        # turn off tooltip
        if { [set x [lsearch [bindtags $w] "Balloon"]] >= 0 } {
             bindtags $w [lreplace [bindtags $w] $x $x]
           }
        unset -nocomplain tips($w)
        trace remove command $w delete ::balloon::autoclear
        return;
      }

   # OK, set up a (new?) tooltip

   if { [lsearch [bindtags $w] "Balloon"] < 0 } {
        bindtags $w [linsert [bindtags $w] 0 "Balloon"]
      }

   if { [lsearch [trace info command $w] {delete ::balloon::autoclear}] < 0 } {
        trace add command $w delete ::balloon::autoclear
      }

   set tips($w) $text

 };# balloon::balloon

 proc ::balloon::show {w} {
    variable tips
    if { ![info exists tips($w)] } {return}
    if {[eval winfo containing [winfo pointerxy .]]!=$w} {return}
     set top "$w.balloon"
     catch {destroy $top}
     toplevel $top -bd 0 -bg black
     wm overrideredirect $top 1
     pack [message $top.txt -aspect 10000 -bg lightyellow -relief raised \
             -text $tips($w)]
     set wmx [winfo rootx $w]
     set wmy [expr [winfo rooty $w]+[winfo height $w]]
     wm geometry $top \
       [winfo reqwidth $top.txt]x[winfo reqheight $top.txt]+$wmx+$wmy
     raise $top
 };# balloon::show

 proc ::balloon::delay {} {
   variable last

   set then $last
   set last [clock seconds]
   if { [expr {$last - $then}] < 3} {
        return 50
      } else {
        return 1000
      }

 };# balloon::delay

 proc ::balloon::autoclear {old new op} {
   variable tips

   unset -nocomplain tips([namespace tail $old]);

 };# balloon::autoclear

# Boeing
# this is a modified form of ::balloon::show but accepts 
# x,y coordinates and a caption for the tooltip
 proc ::balloon::show2 {w x y caption} {
    variable tips
#    if { ![info exists tips($w)] } {return}
     set top "$w.balloon"
     catch {destroy $top}
     toplevel $top -bd 0 -bg black
     wm overrideredirect $top 1
     pack [message $top.txt -aspect 10000 -bg lightyellow -relief raised \
             -text $caption]
     wm geometry $top \
       [winfo reqwidth $top.txt]x[winfo reqheight $top.txt]+$x+$y
     raise $top
 };# balloon::show2
# end Boeing

 namespace import ::balloon::balloon
 if {[catch { bind Balloon <Enter> {after [::balloon::delay] \
					  [list ::balloon::show %W]}} err]} {
    # DISPLAY variable probably not set!
    if { ![info exists tk_patchLevel] } { 
	puts ""
	puts -nonewline " Error initializing Tcl/Tk. Make sure that you are "
	puts "running CORE from X.org or" 
	puts " that you have X11 forwarding turned on (via SSH). "
	puts ""
    }
    exit.real
}
 bind Balloon <Leave> {destroy %W.balloon}

# This is contributed code from http://wiki.tcl.tk/1416
 #----------------------------------------------------------------------
 #
 # roundRect --
 #
 #       Draw a rounded rectangle in the canvas.
 #
 # Parameters:
 #       w - Path name of the canvas
 #       x0, y0 - Co-ordinates of the upper left corner, in pixels
 #       x3, y3 - Co-ordinates of the lower right corner, in pixels
 #       radius - Radius of the bend at the corners, in any form
 #                acceptable to Tk_GetPixels
 #       args - Other args suitable to a 'polygon' item on the canvas
 #
 # Results:
 #       Returns the canvas item number of the rounded rectangle.
 #
 # Side effects:
 #       Creates a rounded rectangle as a smooth polygon in the canvas.
 #
 #----------------------------------------------------------------------
 proc roundRect { w x0 y0 x3 y3 radius args } {

    set r [winfo pixels $w $radius]
    set d [expr { 2 * $r }]

    # Make sure that the radius of the curve is less than 3/8
    # size of the box!

    set maxr 0.75

    if { $d > $maxr * ( $x3 - $x0 ) } {
        set d [expr { $maxr * ( $x3 - $x0 ) }]
    }
    if { $d > $maxr * ( $y3 - $y0 ) } {
        set d [expr { $maxr * ( $y3 - $y0 ) }]
    }

    set x1 [expr { $x0 + $d }]
    set x2 [expr { $x3 - $d }]
    set y1 [expr { $y0 + $d }]
    set y2 [expr { $y3 - $d }]

    set cmd [list $w create polygon]
    lappend cmd $x0 $y0
    lappend cmd $x1 $y0
    lappend cmd $x2 $y0
    lappend cmd $x3 $y0
    lappend cmd $x3 $y1
    lappend cmd $x3 $y2
    lappend cmd $x3 $y3
    lappend cmd $x2 $y3
    lappend cmd $x1 $y3
    lappend cmd $x0 $y3
    lappend cmd $x0 $y2
    lappend cmd $x0 $y1
    lappend cmd -smooth 1
    return [eval $cmd $args]
}