Playing UML

Finished Code

Given that this page has been quite for some time, I decided to put the finished evolved immediately code below. Below that further you can see the development history. I think this is most useful if one can grab the code and work with it in one shot. Kevin Buchs

Here is RS's Introduction

Richard Suchenwirth 2001-10-02 - UML, the Unified Modeling Language, is a convention for drawing diagrams in object-oriented analysis and design. After an OOA/D course (without a CASE tool at hand), I felt tempted to draw UML graphic objects on a canvas.

WikiDbImage uml.jpg

Here's a set of graphic elements used in UML diagrams: boxes that represent classes, with class name in bold, attribute and method names each in a sub-box; ovals that represent use cases, and stylized human figures that represent actors, both with the name below; plus edges connecting such nodes without running into their bounding boxes.

In the graph rendered on a canvas, you may move nodes with the mouse, and all edges are updated accordingly.

What is added to RS's code

  1. Is more platform independent in how it handles fonts.
  2. Bugs are fixed. That's right, there are none left :-)
  3. Handling failure to create edges between boxes.
  4. Saving capability added (at least a start)

Here is the Modified Code

 proc defaultfont {} {
    set f [[button ._] cget -font]
    destroy ._
    set f
 }
 proc ladd {_list what} {
    upvar $_list list
    if {![info exists list] || [lsearch $list $what] == -1} {
        lappend list $what
    }
 }
 namespace eval UML {
    variable a
    #set a(font)     [defaultfont]
    #set a(boldfont) [concat $a(font) bold]
    #  the following two are suggestions as more platform independent
    set a(font)     [eval font create fontNormal [font actual [defaultfont]]]
    set a(boldfont) [eval font create fontBold   [font actual [defaultfont]] -weight bold]

    proc box {c x y class {fill white}} {
        variable a
        foreach {name atts meths} $class break
        if {"$atts$meths"==""} {append name \n} ;# don't make box too low
        set id0 [$c create text $x $y -text $name -anchor nw -font $a(boldfont)]
        $c itemconfig $id0 -tag [set id node$id0]
        set y1 [lindex [$c bbox $id] 3]
        if {$atts!=""} {
            $c create text $x $y1 -text [join $atts \n] -anchor nw\
                -font $a(font) -tag $id
        }
        set y2 [lindex [$c bbox $id] 3]
        if {$meths!=""} {
            $c create text $x $y2 -text [join $meths ()\n]() -anchor nw\
                -font $a(font) -tag $id
        }
        foreach {x0 y0 x3 y3} [$c bbox $id] break
        set x0 [expr {$x0-2}]
        set x3 [expr {$x3+2}]
        if {$meths!=""} {set y3 [expr {$y3+2}]}
        set id1 [$c create rect $x0 $y0 $x3 $y3 -tag $id \
            -fill grey -outline grey]
        $c move $id1 4 4
        set id2 [$c create rect $x0 $y0 $x3 $y3 -tag $id -fill $fill]
        $c lower $id2; $c lower $id1
        $c create line $x0 $y1 $x3 $y1 -tag $id
        $c create line $x0 $y2 $x3 $y2 -tag $id
        foreach {x0 y0 x1 y1} [$c bbox $id] break
        $c move $id [expr {($x0-$x1)/2}] [expr {($y0-$y1)/2}]
        set a(edges,$id) {}

        # lines to add saving by jima
        set a(TyS,$id) box
        set a(NaS,$id) $name
        set a(ClS,$id) $class
        set a(FiS,$id) $fill
        set a(XS,$id) $x
        set a(YS,$id) $y
        return $id
    }
    proc oval {c x y text {fill white}} {
        variable a
        set id0 [$c create oval [expr {$x-20}] [expr {$y-20}] \
            [expr {$x+20}] $y -fill grey -outline grey]
        $c move $id0 4 4
        set id1 [$c create oval [expr {$x-20}] [expr {$y-20}] \
            [expr {$x+20}] $y -fill $fill]
        $c itemconfig $id1 -tag [set id node$id1]
        $c itemconfig $id0 -tag $id
        $c create text $x [expr {$y+5}] -text $text \
            -font $a(font) -tag $id -anchor n
        set a(edges,$id) {}
        return $id
    }
    proc actor {c x y {text ""}} {
        variable a
        set id0 [$c create oval [expr {$x-5}] [expr {$y-5}] \
            [expr {$x+5}] [expr {$y+5}] -fill white]
        $c itemconfig $id0 -tag [set id node$id0]
        $c create line [expr {$x-15}] [expr {$y+7}] \
            [expr {$x+15}] [expr {$y+7}] -tag $id
        $c create line $x [expr {$y+5}] $x [expr {$y+15}] -tag $id
        $c create line $x [expr {$y+15}] [expr {$x-10}] [expr {$y+25}] -tag $id
        $c create line $x [expr {$y+15}] [expr {$x+10}] [expr {$y+25}] -tag $id
        $c create text $x [expr {$y+25}] -text $text \
            -font $a(font) -tag $id -anchor n
        set a(edges,$id) {}
        return $id
    }
    proc rawEdge {c from to {dash ""}} {
        foreach {x0 y0 x2 y2} [$c bbox $from] break
        set x1 [expr {($x0+$x2)/2.}]
        set y1 [expr {($y0+$y2)/2.}]
        if {$from==$to} {
            set x3 [expr {$x2+5}]
            set y4 [set y3 [expr {$y2+5}]]
            set x4 $x2
            $c create line $x2 $y1 $x3 $y1 $x3 $y3 $x1 $y3 $x1 $y2 \
                -tag edge -dash $dash
        } else {
            foreach {x3 y3 x5 y5} [$c bbox $to] break
            set x4 [expr {($x3+$x5)/2.}]
            set y4 [expr {($y3+$y5)/2.}]
            if {$x1<$x2 && $x4>$x2} {set x1 $x2} ;# crop coordinates
            if {$x4>$x3 && $x1<$x3} {set x4 $x3}
            if {$y1<$y2 && $y4>$y2} {set y1 $y2}
            if {$y4>$y3 && $y1<$y3} {set y4 $y3}
            if {$x1>$x0 && $x4<$x0} {set x1 $x0}
            if {$x4<$x5 && $x1>$x5} {set x4 $x5}
            if {$y1>$y0 && $y4<$y0} {set y1 $y0}
            if {$y4<$y5 && $y1>$y5} {set y4 $y5}
            $c create line $x1 $y1 $x4 $y4 -tag edge -dash $dash
        }
        decorationPoints $x1 $y1 $x4 $y4
    }
    proc decorationPoints {x1 y1 x4 y4 {r 12}} {
        set a [expr {atan2($x4-$x1,$y4-$y1)}]
        set a1 [expr {$a-atan(1.)}]
        set x2 [expr {round($x4-cos($a1)*$r)}]
        set y2 [expr {round($y4+sin($a1)*$r)}]
        set a2 [expr {$a+atan(1.)}]
        set x3 [expr {round($x4+cos($a2)*$r)}]
        set y3 [expr {round($y4-sin($a2)*$r)}]
        set a3 [expr {$a+2*atan(1)}]
        set r2 [expr {$r*sqrt(2.)}]
        set x5 [expr {round($x4+cos($a3)*$r2)}]
        set y5 [expr {round($y4-sin($a3)*$r2)}]
        list $x2 $y2 $x4 $y4 $x3 $y3 $x5 $y5 ;# use 6 for a triangle
    }
    proc edge {c type from to} {
        variable a
        ladd a(edges) [list $type $from $to]
        set dash [expr {$type=="depend"||$type=="dotted"? ".": ""}]
        set deco [rawEdge $c $from $to $dash]
        switch -- $type {
          aggreg   {$c create poly $deco -fill white -outline black -tag edge}
          assoc    {}
          compose  {$c create poly $deco -fill black -outline black -tag edge}
          uniAssoc -
          depend   {$c create line [lrange $deco 0 5] -tag edge}
          dotted   {}
          inherit  {$c create poly [lrange $deco 0 5] -fill white \
            -outline black -tag edge}
        }
    }
    proc makeMovable c {
        variable a
        foreach i [$c find all] {
            if [regexp {node[1-9]} [$c itemcget $i -tags]] {
                $c addtag mv withtag $i
            }
        }
        $c bind mv <1> {
            set tag ""
            foreach i [%W itemcget current -tags] {
                if [regexp node $i] {set tag $i; break}
            }
            if {$tag!=""} {
                set ::UML::a(tag) $tag
                set ::UML::a(x) [%W canvasx %X]
                set ::UML::a(y) [%W canvasx %Y]
                #jima added lines.
                set ::UML::a(XS,$tag) [%W canvasx %X]
                set ::UML::a(YS,$tag) [%W canvasx %Y]
            }
        }
        $c bind mv <B1-Motion> {
            set x [%W canvasx %X]
            set y [%W canvasx %Y]
            %W move $::UML::a(tag) \
                [expr {$x-$::UML::a(x)}] [expr {$y-$::UML::a(y)}]
            set ::UML::a(x) $x
            set ::UML::a(y) $y
        }
        $c bind mv <B1-ButtonRelease> {
          %W delete withtag edge
          if {[array names ::UML::a -exact edges] != ""} {
            foreach i $::UML::a(edges) {
              eval UML::edge %W $i
            }
          }
        }

    }
 }

 proc save c {
   variable a
   set ThRes {}
   append ThRes "\n"
   append ThRes "#Setting canvas...\n"
   append ThRes "$c configure -width [$c cget -width] -height [$c cget -height]\n"
   append ThRes "\n"
   if {[array names ::UML::a -regexp {ClS,node[1-9]}] != ""} {
     foreach i [array names ::UML::a -regexp {NaS,node[1-9]}] {
       set ThNode [string range $i 4 end]
       set ThTy $UML::a(TyS,$ThNode)
       set ThNa $UML::a(NaS,$ThNode)
       set ThCl $UML::a(ClS,$ThNode)
       set ThFi $UML::a(FiS,$ThNode)
       set ThX $UML::a(XS,$ThNode)
       set ThY $UML::a(YS,$ThNode)

       append ThRes "\n"
       append ThRes "#Setting node ($ThTy) $ThNa\n"
       append ThRes "set $ThNa \[UML::$ThTy $ThX $ThY $ThCl $ThFi\]\n"
       append ThRes "\n"
     }
   }
   if {[array names ::UML::a -exact edges] != ""} {
     foreach i $::UML::a(edges) {
       set ThTy [lindex $i 0]
       set ThA $::UML::a(NaS,[lindex $i 1])
       set ThB $::UML::a(NaS,[lindex $i 2])
       append ThRes "\n"
       append ThRes "#Setting edge ($ThTy) $ThA $ThB\n"
       append ThRes "UML::edge $c $ThTy $ThA $ThB\n"
       append ThRes "\n"
     }
   }

   return $ThRes
 }

#------- self-test code, and demo
 if {[file tail [info script]]==[file tail $argv0]} {
   set c [canvas .c -bg white]
   pack .c -fill both -expand 1
   set b1 [UML::box   $c  50  50 {Class {att0 att1 att2} {method1 method2}}]
   set b2 [UML::box   $c 200  50 {AnotherClass {attrib} {method1 method2 method3}}]
   set o1 [UML::oval  $c 350  50 "Use a CASE tool"]
   set a1 [UML::actor $c 350 200 badActor]
   set b3 [UML::box   $c  50 200 {NoAttributes {} {butHas methods}} yellow]
   set b4 [UML::box   $c 200 200 {NoMethods {butHas attributes} {}}]
   set b5 [UML::box   $c 200 125 {{UML demo}} green]
   UML::edge $c aggreg   $b1 $b2
   UML::edge $c uniAssoc $b1 $b3
   UML::edge $c depend   $b1 $b4
   UML::edge $c dotted   $b4 $o1
   UML::edge $c assoc    $o1 $a1
   UML::edge $c assoc    $b2 $a1
   UML::edge $c inherit  $b3 $b4
   UML::edge $c compose  $b2 $b3
   UML::edge $c assoc    $b4 $b4
   UML::makeMovable $c
 }

Development History

Richard Suchenwirth 2001-10-02 - UML, the Unified Modeling Language, is a convention for drawing diagrams in object-oriented analysis and design. After an OOA/D course (without a CASE tool at hand), I felt tempted to draw UML graphic objects on a canvas.

WikiDbImage uml.jpg

Here's a set of graphic elements used in UML diagrams: boxes that represent classes, with class name in bold, attribute and method names each in a sub-box; ovals that represent use cases, and stylized human figures that represent actors, both with the name below; plus edges connecting such nodes without running into their bounding boxes.

In the graph rendered on a canvas, you may move nodes with the mouse, and all edges are updated accordingly. }

 proc defaultfont {} {
    set f [[button ._] cget -font]
    destroy ._
    set f
 }
 proc ladd {_list what} {
    upvar $_list list
    if {![info exists list] || [lsearch $list $what] == -1} {
        lappend list $what
    }
 }
 namespace eval UML {
    variable a
    set a(font)     [defaultfont]
    set a(boldfont) [concat $a(font) bold]
    
    proc box {c x y class {fill white}} {
        variable a
        foreach {name atts meths} $class break
        if {"$atts$meths"==""} {append name \n} ;# don't make box too low
        set id0 [$c create text $x $y -text $name -anchor nw -font $a(boldfont)]
        $c itemconfig $id0 -tag [set id node$id0]
        set y1 [lindex [$c bbox $id] 3]
        if {$atts!=""} {
            $c create text $x $y1 -text [join $atts \n] -anchor nw\
                -font $a(font) -tag $id
        }
        set y2 [lindex [$c bbox $id] 3]
        if {$meths!=""} {
            $c create text $x $y2 -text [join $meths ()\n]() -anchor nw\
                -font $a(font) -tag $id
        }
        foreach {x0 y0 x3 y3} [$c bbox $id] break
        set x0 [expr {$x0-2}]
        set x3 [expr {$x3+2}]
        if {$meths!=""} {set y3 [expr {$y3+2}]}
        set id1 [$c create rect $x0 $y0 $x3 $y3 -tag $id \
            -fill grey -outline grey]
        $c move $id1 4 4
        set id2 [$c create rect $x0 $y0 $x3 $y3 -tag $id -fill $fill]
        $c lower $id2; $c lower $id1
        $c create line $x0 $y1 $x3 $y1 -tag $id
        $c create line $x0 $y2 $x3 $y2 -tag $id
        foreach {x0 y0 x1 y1} [$c bbox $id] break
        $c move $id [expr {($x0-$x1)/2}] [expr {($y0-$y1)/2}]
        set a(edges,$id) {}
        return $id
    }
    proc oval {c x y text {fill white}} {
        variable a
        set id0 [$c create oval [expr {$x-20}] [expr {$y-20}] \
            [expr {$x+20}] $y -fill grey -outline grey]
        $c move $id0 4 4
        set id1 [$c create oval [expr {$x-20}] [expr {$y-20}] \
            [expr {$x+20}] $y -fill $fill]
        $c itemconfig $id1 -tag [set id node$id1]
        $c itemconfig $id0 -tag $id
        $c create text $x [expr {$y+5}] -text $text \
            -font $a(font) -tag $id -anchor n
        set a(edges,$id) {}
        return $id
    }
    proc actor {c x y {text ""}} {
        variable a
        set id0 [$c create oval [expr {$x-5}] [expr {$y-5}] \
            [expr {$x+5}] [expr {$y+5}] -fill white]
        $c itemconfig $id0 -tag [set id node$id0]
        $c create line [expr {$x-15}] [expr {$y+7}] \
            [expr {$x+15}] [expr {$y+7}] -tag $id
        $c create line $x [expr {$y+5}] $x [expr {$y+15}] -tag $id
        $c create line $x [expr {$y+15}] [expr {$x-10}] [expr {$y+25}] -tag $id
        $c create line $x [expr {$y+15}] [expr {$x+10}] [expr {$y+25}] -tag $id
        $c create text $x [expr {$y+25}] -text $text \
            -font $a(font) -tag $id -anchor n
        set a(edges,$id) {}
        return $id
    }
    proc rawEdge {c from to {dash ""}} {
        foreach {x0 y0 x2 y2} [$c bbox $from] break
        set x1 [expr {($x0+$x2)/2.}]
        set y1 [expr {($y0+$y2)/2.}]
        if {$from==$to} {
            set x3 [expr {$x2+5}]
            set y4 [set y3 [expr {$y2+5}]]
            set x4 $x2
            $c create line $x2 $y1 $x3 $y1 $x3 $y3 $x1 $y3 $x1 $y2 \
                -tag edge -dash $dash
        } else {
            foreach {x3 y3 x5 y5} [$c bbox $to] break
            set x4 [expr {($x3+$x5)/2.}]
            set y4 [expr {($y3+$y5)/2.}]
            if {$x1<$x2 && $x4>$x2} {set x1 $x2} ;# crop coordinates
            if {$x4>$x3 && $x1<$x3} {set x4 $x3}
            if {$y1<$y2 && $y4>$y2} {set y1 $y2}
            if {$y4>$y3 && $y1<$y3} {set y4 $y3}
            if {$x1>$x0 && $x4<$x0} {set x1 $x0}
            if {$x4<$x5 && $x1>$x5} {set x4 $x5}
            if {$y1>$y0 && $y4<$y0} {set y1 $y0}
            if {$y4<$y5 && $y1>$y5} {set y4 $y5}
            $c create line $x1 $y1 $x4 $y4 -tag edge -dash $dash
        }
        decorationPoints $x1 $y1 $x4 $y4
    }
    proc decorationPoints {x1 y1 x4 y4 {r 12}} {
        set a [expr {atan2($x4-$x1,$y4-$y1)}]
        set a1 [expr {$a-atan(1.)}]
        set x2 [expr {round($x4-cos($a1)*$r)}]
        set y2 [expr {round($y4+sin($a1)*$r)}]
        set a2 [expr {$a+atan(1.)}]
        set x3 [expr {round($x4+cos($a2)*$r)}]
        set y3 [expr {round($y4-sin($a2)*$r)}]
        set a3 [expr {$a+2*atan(1)}]
        set r2 [expr {$r*sqrt(2.)}]
        set x5 [expr {round($x4+cos($a3)*$r2)}]
        set y5 [expr {round($y4-sin($a3)*$r2)}]
        list $x2 $y2 $x4 $y4 $x3 $y3 $x5 $y5 ;# use 6 for a triangle        
    }
    proc edge {c type from to} {
        variable a
        ladd a(edges) [list $type $from $to]
        set dash [expr {$type=="depend"||$type=="dotted"? ".": ""}]
        set deco [rawEdge $c $from $to $dash]
        switch -- $type {
          aggreg   {$c create poly $deco -fill white -outline black -tag edge}
          assoc    {}
          compose  {$c create poly $deco -fill black -outline black -tag edge}
          uniAssoc -
          depend   {$c create line [lrange $deco 0 5] -tag edge}
          dotted   {}
          inherit  {$c create poly [lrange $deco 0 5] -fill white \
            -outline black -tag edge}
        }
    }
    proc makeMovable c {
        variable a
        foreach i [$c find all] {
            if [regexp {node[1-9]} [$c itemcget $i -tags]] {
                $c addtag mv withtag $i
            }
        }
        $c bind mv <1> {
            set tag ""
            foreach i [%W itemcget current -tags] {
                if [regexp node $i] {set tag $i; break}
            }
            if {$tag!=""} {
                set ::UML::a(tag) $tag
                set ::UML::a(x) [%W canvasx %X]
                set ::UML::a(y) [%W canvasx %Y]
            }
        }
        $c bind mv <B1-Motion> {
            set x [%W canvasx %X]
            set y [%W canvasx %Y]
            %W move $::UML::a(tag) \
                [expr {$x-$::UML::a(x)}] [expr {$y-$::UML::a(y)}]
            set ::UML::a(x) $x
            set ::UML::a(y) $y
        }
        $c bind mv <B1-ButtonRelease> {
            %W delete withtag edge
            foreach i $::UML::a(edges) {eval UML::edge %W $i}
        }
    }
 }
#------- self-test code, and demo
 if {[file tail [info script]]==[file tail $argv0]} {
   set c [canvas .c -bg white]
   pack .c -fill both -expand 1
   set b1 [UML::box   $c  50  50 {Class {att0 att1 att2} {method1 method2}}]
   set b2 [UML::box   $c 200  50 {AnotherClass {attrib} {method1 method2 method3}}]
   set o1 [UML::oval  $c 350  50 "Use a CASE tool"]
   set a1 [UML::actor $c 350 200 badActor]
   set b3 [UML::box   $c  50 200 {NoAttributes {} {butHas methods}} yellow]
   set b4 [UML::box   $c 200 200 {NoMethods {butHas attributes} {}}]
   set b5 [UML::box   $c 200 125 {{UML demo}} green]
   UML::edge $c aggreg   $b1 $b2
   UML::edge $c uniAssoc $b1 $b3
   UML::edge $c depend   $b1 $b4
   UML::edge $c dotted   $b4 $o1
   UML::edge $c assoc    $o1 $a1
   UML::edge $c assoc    $b2 $a1
   UML::edge $c inherit  $b3 $b4
   UML::edge $c compose  $b2 $b3
   UML::edge $c assoc    $b4 $b4
   UML::makeMovable $c
 }

Removed an extra square bracket in the defaultfont proc. Ro Tuesday, May 7th, 2002 - RS: thanks! I test scripts before wikifying them (by copy&paste), but occasionally I have to edit stuff that prevents its acceptance, and there this glitch may have happened. Ro: Wednesday, July 10th, 2002: You're welcome... I love to read your posts ;)


MRS on 2005-06-26

Any *nix user out there? I allways have problems with scripts posted here at the wiki that set the font. In all cases (that I have problem) the screenshots showed Windows as the running OS. Here the error I got from this script (running on Linux):

 Error in startup script: expected integer but got "bold"
     (processing "-font" option)
     invoked from within
 "$c create text $x $y -text $name -anchor nw -font $a(boldfont)"
     (procedure "UML::box" line 5)
     invoked from within
 "UML::box   $c  50  50 {Class {att0 att1 att2} {method1 method2}}"
     invoked from within
 "if {[file tail [info script]]==[file tail $argv0]} {
   set c [canvas .c -bg white]
   pack .c -fill both -expand 1
   set b1 [UML::box   $c  50  50 {Cla..."
     (file "playUML.tcl" line 167)

Shouldn't Tcl/Tk scripts be platform independent?

MG If you replace the lines:

    set a(font)     [defaultfont]
    set a(boldfont) [concat $a(font) bold]

with

    set a(font)     [eval font create fontNormal [font actual [defaultfont]]]
    set a(boldfont) [eval font create fontBold   [font actual [defaultfont]] -weight bold]

then I think it'll work OK.

RS Hmm.. this can only be if you still have the old X *-*-*-* pattern for default fonts.. I thought that grew obsolescent after Tcl 8.1 :) You can find out in an interactive wish by typing

 % [text .t] cget -font

But I agree that MG's solution is more robust than my original.

MRS It worked! Thanks!

And here is my output from RS suggestion:

 % [text .t] cget -font # running wish on console
 fixed

 % [text .t] cget -font # running TkCon
 NormalFont

ctasada 2005-07-21 I found a dummy problem in the script. If you draw boxes, but don't create any "edge" between them, the script crashes when trying to move the boxes. To solve that I modified the makeMovable proc. Replace the <B1-ButtonRelease> bind by the next piece of code:

        $c bind mv <B1-ButtonRelease> {
            %W delete withtag edge
            if {[array names ::UML::a -exact edges] != ""} {
               foreach i $::UML::a(edges) {
                  eval UML::edge %W $i
               }
            }
        }

jima(30/10/2005): Thanks RS for this toy...I tried to add saving capabilities.

For the moment I just wanted to save box objects so I devised a save proc that would pass the widget re-creation script to a string.

Just in case anyone is interested here I post my modifications:

On proc box I added some state saving lines:

 set a(TyS,$id) box
 set a(NaS,$id) $name
 set a(ClS,$id) $class
 set a(FiS,$id) $fill
 set a(XS,$id) $x
 set a(YS,$id) $y

On proc makeMovable I added some lines to update the coordinates saved:

 $c bind mv <1> {
   set tag ""
   foreach i [%W itemcget current -tags] {
     if [regexp node $i] {set tag $i; break}
   }
   if {$tag!=""} {                
     set ::UML::a(tag) $tag
     set ::UML::a(x) [%W canvasx %X]
     set ::UML::a(y) [%W canvasx %Y]

     #jima added lines.
     set ::UML::a(XS,$tag) [%W canvasx %X]
     set ::UML::a(YS,$tag) [%W canvasx %Y]
   }
 }

And, finally, the save proc:

 proc save c {
   variable a
   set ThRes {}
   append ThRes "\n"
   append ThRes "#Setting canvas...\n"                    
   append ThRes "$c configure -width [$c cget -width] -height [$c cget -height]\n"
   append ThRes "\n"
   if {[array names ::UML::a -regexp {ClS,node[1-9]}] != ""} {
     foreach i [array names ::UML::a -regexp {NaS,node[1-9]}] {
       set ThNode [string range $i 4 end]               
       set ThTy $UML::a(TyS,$ThNode)
       set ThNa $UML::a(NaS,$ThNode)
       set ThCl $UML::a(ClS,$ThNode)
       set ThFi $UML::a(FiS,$ThNode)                   
       set ThX $UML::a(XS,$ThNode)
       set ThY $UML::a(YS,$ThNode)
                       
       append ThRes "\n"
       append ThRes "#Setting node ($ThTy) $ThNa\n"                    
       append ThRes "set $ThNa \[UML::$ThTy $ThX $ThY $ThCl $ThFi\]\n"
       append ThRes "\n"
     }
   }
   if {[array names ::UML::a -exact edges] != ""} {
     foreach i $::UML::a(edges) {
       set ThTy [lindex $i 0]
       set ThA $::UML::a(NaS,[lindex $i 1])
       set ThB $::UML::a(NaS,[lindex $i 2])
       append ThRes "\n"
       append ThRes "#Setting edge ($ThTy) $ThA $ThB\n"
       append ThRes "UML::edge $c $ThTy $ThA $ThB\n"
       append ThRes "\n"
     }
   }
                  
   return $ThRes       
 }

Despite the horror names for the variables should more or less do it.


Add:

 %W delete withtag edge
 foreach i $::UML::a(edges) {eval UML::edge %W $i}

to the end of the

 "$c bind mv <B1-Motion> {" 

proc and your lines will rubber band No idea if this breaks the save/load issue.