2
# next line is a comment in tcl \
3
exec wish "$0" ${1+"$@"}
5
package require Tkspline
8
# doted - dot graph editor - John Ellson (ellson@graphviz.org)
10
# Usage: doted <file.dot>
12
# doted displays the graph described in the input file and allows
13
# the user to add/delete nodes/edges, to modify their attributes,
14
# and to save the result.
16
global saveFill tk_library modified fileName printCommand g
18
# as the mouse moves over an object change its shading
19
proc mouse_anyenter {c} {
20
global tk_library saveFill
21
set item [string range [lindex [$c gettags current] 0] 1 end]
22
set saveFill [list $item [lindex [$c itemconfigure 1$item -fill] 4]]
23
$c itemconfigure 1$item -fill black \
24
-stipple @$tk_library/demos/images/gray25.bmp
27
# as the mouse moves out of an object restore its shading
28
proc mouse_anyleave {c} {
30
$c itemconfigure 1[lindex $saveFill 0] \
31
-fill [lindex $saveFill 1] -stipple {}
34
# if b1 is pressed over the brackground then start a node,
35
# if b1 is pressed over a node then start an edge
36
proc mouse_b1_press {c x y} {
37
global startObj graphtype
40
foreach item [$c find overlapping $x $y $x $y] {
41
foreach tag [$c gettags $item] {
42
if {[string first "node" $tag] == 1} {
43
set item [string range $tag 1 end]
44
if {[string equal $graphtype digraph]} {
45
set startObj [$c create line $x $y $x $y \
46
-tag $item -fill red -arrow last]
48
set startObj [$c create line $x $y $x $y \
55
set startObj [$c create oval [expr $x - 10] [expr $y - 10] \
56
[expr $x + 10] [expr $y + 10] -fill red -outline black]
59
# if node started by b1_press then move it,
61
proc mouse_b1_motion {c x y} {
63
set pos [$c coords $startObj]
64
if {[$c type $startObj] == "line"} {
65
$c coords $startObj [lindex $pos 0] [lindex $pos 1] \
66
[$c canvasx $x] [$c canvasy $y]
68
$c move $startObj [expr [$c canvasx $x] - [lindex $pos 0] - 10] \
69
[expr [$c canvasy $y] - [lindex $pos 1] - 10]
73
# complete node or edge construction.
74
proc mouse_b1_release {c x y} {
75
global startObj modified g
78
set t [$c type $startObj]
80
set tail [lindex [$c gettags $startObj] 0]
81
foreach item [$c find overlapping $x $y $x $y] {
82
foreach tag [$c gettags $item] {
83
set head [string range $tag 1 end]
84
if {[string first "node" $head] == 0} {
85
set e [$tail addedge $head]
86
$c dtag $startObj $tail
87
$c addtag 1$e withtag $startObj
88
$c itemconfigure $startObj -fill black
95
# if we get here then edge isn't terminating on a node
99
$c addtag 1$n withtag $startObj
100
$c itemconfigure $startObj -fill white
106
proc loadFileByName {c name} {
109
confirm "Current graph has been modified. Shall I overwrite it?" \
110
"loadFileByNameDontAsk $c $name"
112
loadFileByNameDontAsk $c $name
116
proc loadFileByNameDontAsk {c name} {
121
if {[string first / $name] == 0} {
127
set fileName [pwd]/$name
130
if {[catch {open $fileName r} f]} {
131
warning "Unable to open file: $fileName"
133
if {[catch {dotread $f} g]} {
134
warning "Invalid dot file: $fileName"
140
$c configure -scrollregion [$c bbox all]
143
proc resize_canvas {c w h} {
144
$c configure -scrollregion [$c bbox all]
147
proc update_entry {w x y} {
148
$w.entry delete 0 end
149
$w.entry insert end [$w.l.list get @$x,$y]
152
# doesn't work well with window managers that position initial window
153
# on the left because then all popups get obscured
155
#proc positionWindow {w} {
156
# set pos [split [wm geometry .] +]
157
# set x [expr [lindex $pos 1] - 350]
158
# set y [expr [lindex $pos 2] + 20]
159
# wm geometry $w +$x+$y
166
{{DOT Graph Files} {.dot}}
169
set fn [tk_getOpenFile \
170
-defaultextension .dot \
172
-initialfile $fileName]
173
if {[string length $fn]} {
174
loadFileByName $c $fn
178
proc saveFile {type} {
180
if {$fileName == {}} {
183
saveFileByName $fileName $type
187
proc saveFileByName {name type} {
189
if {$name != $fileName && [file exists $name]} {
190
confirm "File exists. Shall I overwrite it?" \
191
"saveFileByNameDontAsk $name $type"
193
saveFileByNameDontAsk $name $type
197
proc saveFileByNameDontAsk {name type} {
198
global modified fileName g
199
if {[catch {open $name w} f]} {
200
warning "Unable to open file for write:\n$name; return"
202
if {$type == "dot"} {
209
message "Graph written to:\n$name"
212
proc saveFileAs {type} {
215
set cmap {{{CMAP Image Map Files} {.cmap}} {{All Files} *}}
216
set dia {{{DIA Image Files} {.dia}} {{All Files} *}}
217
set dot {{{DOT Graph Files} {.dot}} {{All Files} *}}
218
set fig {{{FIG Image Files} {.fig}} {{All Files} *}}
219
set gif {{{GIF Image Files} {.gif}} {{All Files} *}}
220
set hpgl {{{HPGL Image Files} {.hpgl}} {{All Files} *}}
221
set jpg {{{JPG Image Files} {.jpg}} {{All Files} *}}
222
set mif {{{MIF Image Files} {.mif}} {{All Files} *}}
223
set pcl {{{PCL Image Files} {.pcl}} {{All Files} *}}
224
set png {{{PNG Image Files} {.png}} {{All Files} *}}
225
set ps {{{PostScript Files} {.ps}} {{All Files} *}}
226
set svg {{{SVG Image Files} {.png}} {{All Files} *}}
228
set fn [tk_getSaveFile \
229
-defaultextension .$type \
230
-filetypes [set $type] \
231
-initialdir [file dirname $fileName] \
232
-initialfile [file tail [file rootname $fileName]].$type]
233
if {[string length $fn]} {
234
saveFileByNameDontAsk $fn $type
239
global g printCommand
240
if {[catch {open "| $printCommand &" w} f]} {
241
warning "Unable to open pipe to printer command:\n$printCommand; return"
245
message "Graph printed to:\n$printCommand"
248
proc setPrinterCommand {w} {
250
set printCommand [$w.printCommand get]
251
message "Printer command changed to:\n$printCommand"
261
wm title $w "Printer"
262
wm iconname $w "Printer"
263
label $w.message -text "Printer command:"
264
frame $w.spacer -height 3m -width 20
265
entry $w.printCommand
266
$w.printCommand insert end $printCommand
267
bind $w.printCommand <Return> "setPrinterCommand $w"
269
button $w.buttons.confirm -text OK -command "setPrinterCommand $w"
270
button $w.buttons.cancel -text Cancel -command "destroy $w"
271
pack $w.buttons.confirm $w.buttons.cancel -side left -expand 1
272
pack $w.message $w.spacer $w.printCommand -side top -anchor w
273
pack $w.buttons -side bottom -expand y -fill x -pady 2m
276
proc confirm {msg cmd} {
281
wm title $w "Confirm"
282
wm iconname $w "Confirm"
283
label $w.message -text "\n$msg\n"
284
frame $w.spacer -height 3m -width 20
286
button $w.buttons.confirm -text OK -command "$cmd; destroy $w"
287
button $w.buttons.cancel -text Cancel -command "destroy $w"
288
pack $w.buttons.confirm $w.buttons.cancel -side left -expand 1
289
pack $w.message $w.spacer -side top -anchor w
290
pack $w.buttons -side bottom -expand y -fill x -pady 2m
298
wm title $w "Message"
299
wm iconname $w "Message"
300
label $w.message -text "\n$m\n"
301
pack $w.message -side top -anchor w
303
after 2000 "destroy $w"
311
wm title $w "Warning"
312
wm iconname $w "Warning"
313
label $w.message -text "\nWarning:\n\n$m"
314
pack $w.message -side top -anchor w
316
after 2000 "destroy $w"
319
proc setoneattribute {w d a s} {
320
set aa [$w.e$a.a get]
322
error "no attribute name set"
329
addEntryPair $w $d $aa $v $s
330
addEntryPair $w d {} {} $s
334
proc addEntryPair {w d a v s} {
335
pack [frame $w.e$a] -side top
336
pack [entry $w.e$a.a] [entry $w.e$a.v] -side left
338
$w.e$a.a insert end $a
339
$w.e$a.a configure -state disabled -relief flat
340
$w.e$a.v insert end $v
342
$w.e$a.v configure -state disabled -relief flat
345
bind $w.e$a.a <Return> "focus $w.e$a.v"
346
bind $w.e$a.v <Return> [list setoneattribute $w $d $a $s]
347
pack $w.e$a -side top
351
proc deleteobj {c o} {
352
if {[string first "node" $o] == 0} {
353
foreach e [$o listedges] {
364
# open a requestor for object $o,
365
# deletable if $d is not null,
366
# command to list attribute in $l
367
# command to query attributes in $q
368
# command to set attributes in $s
369
proc setAttributesWidget {c o d l q s} {
374
wm title $w "[$o showname] Attributes"
375
wm iconname $w "Attributes"
376
foreach a [eval $l] {
377
if {[catch {eval $q $a} v]} {set v {}}
378
addEntryPair $w $d $a $v $s
380
addEntryPair $w d {} {} $s
381
frame $w.spacer -height 3m -width 20
384
button $w.buttons.delete -text Delete -command "deleteobj $c $o; destroy $w"
385
pack $w.buttons.delete -side left -expand 1
387
button $w.buttons.dismiss -text OK -command "destroy $w"
388
pack $w.buttons.dismiss -side left -expand 1
389
pack $w.buttons -side bottom -expand y -fill x -pady 2m
392
# open a requestor according to the type of graph object $obj, to allow the user to read and set attributions
393
proc setAttributes {c obj} {
396
set obj [string range [lindex [$c gettags current] 0] 1 end]
398
set type [string range $obj 0 3]
399
if {$type == "node" || $type == "edge"} {
400
if {[string length $obj] > 4} {
401
setAttributesWidget $c $obj d \
402
"$obj listattributes" \
403
"$obj queryattributes" \
406
setAttributesWidget $c $obj {} \
407
"$g list[set type]attributes" \
408
"$g query[set type]attributes" \
409
"$g set[set type]attributes"
412
setAttributesWidget $c $g {} \
413
"$g listattributes" \
414
"$g queryattributes" \
419
# unconditionally remove any old graph and canvas contents, the create a new graph of $type
420
proc newGraphDontAsk {c type} {
421
global modified g graphtype
425
if {[info exists g]} {$g delete}
429
# upon confirmation, remove any old graph and canvas contents, the create a new graph of $type
430
proc newGraph {c type} {
433
confirm "Current graph has been modified. Shall I continue?" \
434
"newGraphDontAsk $c $type"
436
newGraphDontAsk $c $type
440
# generate a new graph layout and update rendering on the canvas
441
# this proc is attached to the green button to the lower right of the window
447
$c configure -scrollregion [$c bbox all]
450
# generate a help window with $msg as the contents
456
wm title $w "DotEd Help"
457
wm iconname $w "DotEd"
458
frame $w.menu -relief raised -bd 2
459
pack $w.menu -side top -fill x
461
-font -Adobe-helvetica-medium-r-normal--*-140-*-*-*-*-*-* \
462
-wraplength 4i -justify left -text $msg
463
pack $w.msg -side top
465
pack $w.buttons -side bottom -expand y -fill x -pady 2m
466
button $w.buttons.dismiss -text Dismiss -command "destroy $w"
467
pack $w.buttons.dismiss -side left -expand 1
470
# proc that supports zoom in/out events
473
set x [$c canvasx [expr {[winfo pointerx $c] - [winfo rootx $c]}]]
474
set y [$c canvasy [expr {[winfo pointery $c] - [winfo rooty $c]}]]
475
$c scale all $x $y $fact $fact
476
set data(zdepth) [expr {$data(zdepth) * $fact}]
477
after cancel $data(idle)
478
set data(idle) [after idle "zoomupdate $c"]
481
# update all text strings after zom operation is complete
482
proc zoomupdate {c} {
485
foreach {i} [$c find all] {
486
if { ! [string equal [$c type $i] text]} {continue}
488
# get original fontsize and text from tags
489
# if they were previously recorded
490
foreach {tag} [$c gettags $i] {
491
scan $tag {_f%d} fontsize
492
scan $tag "_t%\[^\0\]" text
494
# if not, then record current fontsize and text
496
set font [$c itemcget $i -font]
498
set text [$c itemcget $i -text]
499
set fontsize [lindex $font 1]
500
$c addtag _f$fontsize withtag $i
501
$c addtag _t$text withtag $i
504
set newsize [expr {int($fontsize * $data(zdepth))}]
505
if {abs($newsize) >= 4} {
506
$c itemconfigure $i \
507
-font [lreplace $font 1 1 $newsize] \
510
# suppress text if too small
511
$c itemconfigure $i -text {}
514
set bbox [$c bbox all]
515
if {[llength $bbox]} {
516
$c configure -scrollregion $bbox
518
$c configure -scrollregion [list -4 -4 \
519
[expr {[winfo width $c]-4}] \
520
[expr {[winfo height $c]-4}]]
524
#--------------------------------------------------------------------------
525
set help_about "DotEd - Dot Graph Editor
526
Copyright (C) 1995 AT&T Bell Labs
527
(C) 1996 Lucent Technologies
529
Written by: John Ellson (ellson@graphviz.org)
530
and: Stephen North (north@research.att.com)
532
DotEd provides for the graphical editing of
533
directed graphs. Once a graph has been manually
534
entered then the dot layout algorithm can be applied
535
by clicking on the button in the lower right corner
538
set help_mouse "Button-1: When the cursor is over the
539
background Button-1-Press will start a node,
540
Button-1-Motion (dragging the mouse with
541
Button-1 still down) will move it and
542
Button-1-Release will complete the node
543
insertion into the graph.
545
When the cursor is over an existing node
546
then Button-1-Press will start an edge from
547
that node. Button-1-Motion will extend the
548
edge and Button-1-Release over a different
549
node will complete the edge.
551
Button-2: Button-2-Motion (click and drag) will
552
reposition the canvas under the window.
554
Button-3: When Button-3 is clicked over a
555
node or edge the attribute editor will
556
be opened on that object.
558
Scrollwheel: Zooms canvas in/out.
560
Once a graph has been manually entered then
561
the dot layout algorithm can be applied by
562
clicking on the button in the lower right
563
corner of the window."
565
#--------------------------------------------------------------------------
567
#initialize some globals
571
set fileName {no_name}
572
set printCommand {lpr}
577
wm iconname . "DotEd"
579
wm geometry . 400x300
580
frame .m -relief raised -borderwidth 1
585
-xscrollcommand ".b.h set" \
586
-yscrollcommand ".a.v set" \
598
-width [.a.v cget -width] \
599
-height [.b.h cget -width] \
601
-activeforeground green\
602
-bitmap @$tk_library/demos/images/gray25.bmp \
605
# initialize zoom state
606
set [set c](zdepth) 1.0
609
# create graph structure and set global "g"
610
newGraphDontAsk $c digraph
613
bind $c <Configure> "resize_canvas $c %w %h"
614
bind $c <ButtonPress-1> "mouse_b1_press $c %x %y"
615
bind $c <B1-Motion> "mouse_b1_motion $c %x %y"
616
bind $c <ButtonRelease-1> "mouse_b1_release $c %x %y"
617
bind $c <Button-2> "$c scan mark %x %y"
618
bind $c <B2-Motion> "$c scan dragto %x %y 1"
619
bind $c <Button-3> "setAttributes $c {}"
620
bind $c <Button-4> "zoom $c $zfact"
621
bind $c <Button-5> "zoom $c [expr {1.0/$zfact}]"
623
# canvas item bindings
624
$c bind all <Any-Enter> "mouse_anyenter $c"
625
$c bind all <Any-Leave> "mouse_anyleave $c"
627
menubutton .m.file -text "File" -underline 0 -menu .m.file.m
629
.m.file.m add command -label "Load ..." -underline 0 \
630
-command "loadFile $c"
631
.m.file.m add command -label "New - directed" -underline 0 \
632
-command "newGraph $c digraph"
633
.m.file.m add command -label "New - undirected" -underline 6 \
634
-command "newGraph $c graph"
635
.m.file.m add command -label "Save" -underline 0 \
636
-command "saveFile dot"
637
.m.file.m add command -label "Save As ..." -underline 5 \
638
-command "saveFileAs dot"
639
.m.file.m add separator
640
.m.file.m add cascade -label "Export" -underline 1 \
641
-menu .m.file.m.export
642
menu .m.file.m.export
643
.m.file.m.export add command -label "CMAP ..." -underline 0 \
644
-command "saveFileAs cmap"
645
.m.file.m.export add command -label "DIA ..." -underline 0 \
646
-command "saveFileAs dia"
647
.m.file.m.export add command -label "FIG ..." -underline 0 \
648
-command "saveFileAs fig"
649
.m.file.m.export add command -label "GIF ..." -underline 0 \
650
-command "saveFileAs gif"
651
.m.file.m.export add command -label "HPGL ..." -underline 0 \
652
-command "saveFileAs hpgl"
653
.m.file.m.export add command -label "MIF ..." -underline 0 \
654
-command "saveFileAs mif"
655
.m.file.m.export add command -label "PNG ..." -underline 0 \
656
-command "saveFileAs png"
657
.m.file.m.export add command -label "PS ..." -underline 0 \
658
-command "saveFileAs ps"
659
.m.file.m.export add command -label "SVG ..." -underline 0 \
660
-command "saveFileAs svg"
661
.m.file.m add separator
662
.m.file.m add command -label "Print Setup ..." -underline 0 \
663
-command "printSetup"
664
.m.file.m add command -label "Print" -underline 0 \
666
.m.file.m add separator
667
.m.file.m add command -label "Exit" -underline 0 -command "exit"
668
menubutton .m.graph -text "Graph" -underline 0 -menu .m.graph.m
670
.m.graph.m add command -label "Graph Attributes" -underline 0 \
671
-command "setAttributes $c graph"
672
.m.graph.m add command -label "Node Attributes" -underline 0 \
673
-command "setAttributes $c node"
674
.m.graph.m add command -label "Edge Attributes" -underline 0 \
675
-command "setAttributes $c edge"
676
menubutton .m.help -text "Help" -underline 0 -menu .m.help.m
678
.m.help.m add command -label "About DotEd" -underline 0 \
679
-command {help $help_about}
680
.m.help.m add command -label "Mouse Operations" -underline 0 \
681
-command {help $help_mouse}
683
pack append .m .m.file {left} .m.graph {left} .m.help {right}
684
pack append .a $c {left expand fill} .a.v {right filly}
685
pack append .b .b.h {left expand fillx} .b.layout {right}
686
pack append . .m {top fillx} .a {expand fill} .b {bottom fillx}
687
tk_menuBar .m.file .m.graph .m.help
689
if {$argc} {loadFileByNameDontAsk $c [lindex $argv 0]}
added
removed
tclpkg/tcldot/demo/doted
