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.
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
- Is more platform independent in how it handles fonts.
- Bugs are fixed. That's right, there are none left :-)
- Handling failure to create edges between boxes.
- 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.
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.