Implement link splitting in GUI, so we can have pointer-type links

connecting nodes residing in a single canvas.

Bug found by:
Submitted by:
Requested by:
Reviewed by:
Approved by:
Obtained from:

diff --git a/editor.tcl b/editor.tcl
index 21847eece8eb749db1a805e75ef3dc24c0472c4f..adc8d1f7999c2c0f3a36a7585c1415e86bfd0bd5 100755 (executable)
--- a/editor.tcl
+++ b/editor.tcl
@@ -176,6 +176,7 @@ proc redrawAll {} {
 proc drawNode { node } {
     global showNodeLabels
     global router pc host lanswitch frswitch rj45 hub pseudo
+    global curcanvas
 
     set type [nodeType $node]
     set coords [getNodeCoords $node]
@@ -194,9 +195,15 @@ proc drawNode { node } {
        set pnode [getNodeName $node]
        set pcanvas [getNodeCanvas $pnode]
        set ifc [ifcByPeer $pnode [getNodeMirror $node]]
-       set label [.c create text $x $y -fill blue \
-           -text "$ifc@[getNodeName $pnode]\r([getCanvasName $pcanvas])" \
-           -tags "nodelabel $node" -justify center]
+       if { $pcanvas != $curcanvas } {
+           set label [.c create text $x $y -fill blue \
+               -text "[getNodeName $pnode]:$ifc\r@[getCanvasName $pcanvas]" \
+               -tags "nodelabel $node" -justify center]
+       } else {
+           set label [.c create text $x $y -fill blue \
+               -text "[getNodeName $pnode]:$ifc" \
+               -tags "nodelabel $node" -justify center]
+       }
     }
     if { $showNodeLabels == 0} {
        .c itemconfigure $label -state hidden
@@ -422,12 +429,12 @@ proc redrawLink { link } {
     .c coords $limage1 $x1 $y1 $x2 $y2
     .c coords $limage2 $x1 $y1 $x2 $y2
 
-    set lx [expr ($x1 + $x2) / 2]
-    set ly [expr ($y1 + $y2) / 2]
+    set lx [expr 0.5 * ($x1 + $x2)]
+    set ly [expr 0.5 * ($y1 + $y2)]
     .c coords "linklabel && $link" $lx $ly
 
     set n [expr sqrt (($x1 - $x2) * ($x1 - $x2) + \
-       ($y1 - $y2) * ($y1 - $y2)) / 64]
+       ($y1 - $y2) * ($y1 - $y2)) * 0.015]
     if { $n < 1 } { set n 1 }
 
     calcDxDy $lnode1
@@ -445,6 +452,42 @@ proc redrawLink { link } {
 }
 
 
+proc splitGUILink { link } {
+    global changed
+
+    set peer_nodes [linkPeers $link]
+    set new_nodes [splitLink $link pseudo]
+    set orig_node1 [lindex $peer_nodes 0]
+    set orig_node2 [lindex $peer_nodes 1]
+    set new_node1 [lindex $new_nodes 0]
+    set new_node2 [lindex $new_nodes 1]
+    set new_link1 [linkByPeers $orig_node1 $new_node1]
+    set new_link2 [linkByPeers $orig_node2 $new_node2]
+    setLinkMirror $new_link1 $new_link2
+    setLinkMirror $new_link2 $new_link1
+    setNodeMirror $new_node1 $new_node2
+    setNodeMirror $new_node2 $new_node1
+    setNodeName $new_node1 $orig_node2
+    setNodeName $new_node2 $orig_node1
+
+    set x1 [lindex [getNodeCoords $orig_node1] 0]
+    set y1 [lindex [getNodeCoords $orig_node1] 1]
+    set x2 [lindex [getNodeCoords $orig_node2] 0]
+    set y2 [lindex [getNodeCoords $orig_node2] 1]
+
+    setNodeCoords $new_node1 \
+       "[expr $x1 + 0.4 * ($x2 - $x1)] [expr $y1 + 0.4 * ($y2 - $y1)]"
+    setNodeCoords $new_node2 \
+       "[expr $x1 + 0.6 * ($x2 - $x1)] [expr $y1 + 0.6 * ($y2 - $y1)]"
+    setNodeLabelCoords $new_node1 [getNodeCoords $new_node1]
+    setNodeLabelCoords $new_node2 [getNodeCoords $new_node2]
+
+    set changed 1
+    updateUndoLog
+    redrawAll
+}
+
+
 proc selectNode { c obj } {
     set node [lindex [$c gettags $obj] 1]
     $c addtag selected withtag "node && $node"
@@ -494,6 +537,17 @@ proc button3link { c x y } {
            -state disabled
     }
 
+    #
+    # Split link
+    #
+    if { $oper_mode != "exec" && [getLinkMirror $link] == "" } {
+       .button3menu add command -label "Split" \
+           -command "splitGUILink $link"
+    } else {
+       .button3menu add command -label "Split" \
+           -state disabled
+    }
+
     set x [winfo pointerx .]
     set y [winfo pointery .]
     tk_popup .button3menu $x $y
@@ -551,6 +605,7 @@ proc button3node { c x y } {
            return
        }
     }
+    set mirror_node [getNodeMirror $node]
 
     if { [$c gettags "node && $node && selected"] == "" } {
        $c dtag node selected
@@ -610,7 +665,7 @@ proc button3node { c x y } {
     # Move to another canvas
     #
     .button3menu.moveto delete 0 end
-    if { [nodeType $node] == "pseudo" } {
+    if { $oper_mode == "exec" || [nodeType $node] == "pseudo" } {
        .button3menu add cascade -label "Move to" \
            -menu .button3menu.moveto -state disabled
     } else {
@@ -629,6 +684,18 @@ proc button3node { c x y } {
        }
     }
 
+    #
+    # Merge two pseudo nodes / links
+    #
+    if { [nodeType $node] == "pseudo" && \
+        [getNodeCanvas $mirror_node] == $curcanvas } {
+       .button3menu add command -label "Merge" \
+           -command "mergeGUINode $node"
+    } else {
+       .button3menu add command -label "Merge" \
+           -state disabled
+    }
+
     #
     # Delete selection
     #
@@ -1982,8 +2049,8 @@ proc rearrange { mode } {
                set p_fx [expr 1000.0 * $dx / ($d2 * $d + 100)]
                set p_fy [expr 1000.0 * $dy / ($d2 * $d + 100)]
                if {[linkByPeers $node $other] != ""} {
-                   set p_fx [expr $p_fx - $dx * $d2 / 2000000000.0]
-                   set p_fy [expr $p_fy - $dy * $d2 / 2000000000.0]
+                   set p_fx [expr $p_fx - $dx * $d2 * .0000000005]
+                   set p_fy [expr $p_fy - $dy * $d2 * .0000000005]
                }
                set fx_t($node) [expr $fx_t($node) + $p_fx]
                set fy_t($node) [expr $fy_t($node) + $p_fy]
@@ -1994,7 +2061,8 @@ proc rearrange { mode } {
            foreach link $link_list {
                set nodes [linkPeers $link]
                if { [getNodeCanvas [lindex $nodes 0]] != $curcanvas ||
-                   [getNodeCanvas [lindex $nodes 1]] != $curcanvas } {
+                   [getNodeCanvas [lindex $nodes 1]] != $curcanvas ||
+                   [getLinkMirror $link] != "" } {
                        continue
                }
                set peers [linkPeers $link]

diff --git a/initgui.tcl b/initgui.tcl
index bcb67bce3ceb6f440f12f8ddd26889713b8a7375..1c9370a14759f44b9b2874acde5cc3b4d050d602 100755 (executable)
--- a/initgui.tcl
+++ b/initgui.tcl
@@ -278,22 +278,37 @@ foreach b {router host pc hub lanswitch frswitch rj45} {
     set $b [image create photo -file $ROOTDIR/$LIBDIR/icons/normal/$b.gif]
 }
 set pseudo [image create photo]
+set text [image create photo]
 
 
+. configure -background #808080
 frame .grid
-set c [canvas .c -relief sunken -bd 1 \
+frame .hframe
+frame .vframe
+set c [canvas .c -bd 0 -relief sunken -highlightthickness 0\
+       -background gray \
        -scrollregion "-32 -32 [expr $sizex + 32] [expr $sizey + 32]" \
-       -xscrollcommand ".hscroll set" -yscrollcommand ".vscroll set"]
-scrollbar .hscroll -orient horiz -command "$c xview"
-scrollbar .vscroll -command "$c yview"
-pack .grid -expand yes -fill both -padx 0 -pady 0
+       -xscrollcommand ".hframe.scroll set" \
+       -yscrollcommand ".vframe.scroll set"]
+canvas .hframe.t -width 250 -height 18 -bd 0 -highlightthickness 0 \
+       -background gray
+scrollbar .hframe.scroll -orient horiz -command "$c xview" \
+       -bd 1 -width 14
+scrollbar .vframe.scroll -command "$c yview" \
+       -bd 1 -width 14
+scrollbar .hframe.ts -orient horiz -command "" \
+       -bd 1 -width 14
+#pack .hframe.ts .hframe.t -side left -padx 0 -pady 0
+pack .hframe.scroll -side left -padx 0 -pady 0 -fill both -expand true
+pack .vframe.scroll -side top -padx 0 -pady 0 -fill both -expand true
+pack .grid -expand yes -fill both -padx 1 -pady 1
 grid rowconfig .grid 0 -weight 1 -minsize 0
 grid columnconfig .grid 0 -weight 1 -minsize 0
-grid .c -padx 1 -in .grid -pady 0 -padx 0 -row 0 -column 0 \
+grid .c -in .grid -row 0 -column 0 \
        -rowspan 1 -columnspan 1 -sticky news
-grid .vscroll -in .grid -pady 0 -padx 0 -row 0 -column 1 \
+grid .vframe -in .grid -row 0 -column 1 \
        -rowspan 1 -columnspan 1 -sticky news
-grid .hscroll -in .grid -pady 0 -padx 0 -row 1 -column 0 \
+grid .hframe -in .grid -row 1 -column 0 \
        -rowspan 1 -columnspan 1 -sticky news
 
 frame .bottom
@@ -303,16 +318,18 @@ label .bottom.cpu_load -relief sunken -bd 1 -font helvetica -anchor w -width 9
 label .bottom.mbuf -relief sunken -bd 1 -font helvetica -anchor w -width 15
 label .bottom.oper_mode -relief sunken -bd 1 -font helvetica -anchor w -width 9
 pack .bottom.oper_mode .bottom.mbuf .bottom.cpu_load .bottom.textbox \
-       -side right -padx 1 -fill both
+       -side right -padx 0 -fill both
 
 
 #
 # Event bindings and procedures for main canvas:
 #
 $c bind node <Any-Enter> "nodeEnter $c"
+$c bind nodelabel <Any-Enter> "nodeEnter $c"
 $c bind link <Any-Enter> "linkEnter $c"
 $c bind linklabel <Any-Enter> "linkEnter $c"
 $c bind node <Any-Leave> "anyLeave $c"
+$c bind nodelabel <Any-Leave> "anyLeave $c"
 $c bind link <Any-Leave> "anyLeave $c"
 $c bind linklabel <Any-Leave> "anyLeave $c"
 $c bind node <Double-1> "popupConfigDialog $c"
@@ -320,6 +337,7 @@ $c bind nodelabel <Double-1> "popupConfigDialog $c"
 $c bind link <Double-1> "popupConfigDialog $c"
 $c bind linklabel <Double-1> "popupConfigDialog $c"
 $c bind node <3> "button3node $c %x %y"
+$c bind nodelabel <3> "button3node $c %x %y"
 $c bind link <3> "button3link $c %x %y"
 $c bind linklabel <3> "button3link $c %x %y"
 bind $c <1> "button1 $c %x %y none"

diff --git a/linkcfg.tcl b/linkcfg.tcl
index 8adf07b884f331b6b9cafa435f7cfed4c6f1d59d..a10ca07c9032e17ff96d06f522c72e3f70d01009 100755 (executable)
--- a/linkcfg.tcl
+++ b/linkcfg.tcl
@@ -159,6 +159,7 @@ proc getLinkDelay { link } {
     return [lindex $entry 1]
 }
 
+
 proc getLinkDelayString { link } {
     global $link
 
@@ -177,6 +178,7 @@ proc getLinkDelayString { link } {
     return $delstr
 }
 
+
 proc setLinkDelay { link value } {
     global $link
 
@@ -294,13 +296,30 @@ proc splitLink { link nodetype } {
        setNodeLabelCoords $new_node1 [getNodeCoords $orig_node2]
        setNodeLabelCoords $new_node2 [getNodeCoords $orig_node1]
     }
-    lappend $new_node1 "interface-peer {0 $orig_node2}"
-    lappend $new_node2 "interface-peer {0 $orig_node1}"
-
-    # XXX TODO: copy properties of orig to new links
+    lappend $new_node1 "interface-peer {0 $orig_node1}"
+    lappend $new_node2 "interface-peer {0 $orig_node2}"
+
+    setLinkBandwidth $new_link1 [getLinkBandwidth $link]
+    setLinkBandwidth $new_link2 [getLinkBandwidth $link]
+    setLinkDelay $new_link1 [getLinkDelay $link]
+    setLinkDelay $new_link2 [getLinkDelay $link]
+    setLinkBER $new_link1 [getLinkBER $link]
+    setLinkBER $new_link2 [getLinkBER $link]
+    setLinkDup $new_link1 [getLinkDup $link]
+    setLinkDup $new_link2 [getLinkDup $link]
 
     set i [lsearch -exact $link_list $link]
     set link_list [lreplace $link_list $i $i]
 
     return "$new_node1 $new_node2"
 }
+
+
+proc mergeLink { link } {
+
+    set mirror_link [getLinkMirror $link]
+    if { $mirror_link == "" } {
+       puts "XXX mergeLink called for non-pseudo link!!!"
+       return
+    }
+}