afonso/core-extra
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

initial import (Boeing r1752, NRL r878)

Browse source
This commit is contained in:
ahrenholz 2013-08-29 14:21:13 +00:00
commit f8f46d28be
394 changed files with 99738 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

390
gui/tooltips.tcl Executable file
View file

@ -0,0 +1,390 @@
#
# 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]
}