2
# next line is a comment in tcl \
3
exec wish "$0" ${1+"$@"}
5
package require Tkspline
6
package require Tclpathplan
8
########################################################################
9
# shape - a shape drawing tool for testing the spring layout engine
11
# John Ellson - ellson@graphviz.org - September 12, 1996
15
# Radio buttons select the drawing mode.
16
# "draw" - draw a closed and filled polygon
17
# "stretch" - move a vertex of a polygon, also
18
# insert additional vertices with subsequent button 1 clicks
19
# "collapse" - delete a vertex of a polygon (except last 2)
20
# "move" - move a complete polygon without altering
21
# its shape, or move the whole canvas.
22
# "rotate" - rotate a polygon about its center
23
# "scale" - scale a polygon
24
# "clone" - copy an existing shape
25
# "delete" - remove an entire polygon object
26
# "path" - draw a line between two polygons and the
27
# system will respond with the shortest path
28
# around all the other polygons.
29
# "bezier path" - draw a line between two polygons and the
30
# system will respond with the spline that follows
31
# the shortest path around all the other polygons.
32
# "id" - identify a polygon. mostly for debugging.
34
# "draw," "stretch," "move," "path", "bezier path", and "clone" use
35
# button 1 for first though penultimate points, then button 2 to
36
# complete the operation.
38
# "rotate" and "scale" use the button 1 to grab a polygon and
39
# button 2 to complete the operation.
41
# "collapse" and "delete" just use button 1
43
# "stretch, " "move, " "collapse," and "delete" operations all act on
44
# a highlighted object
46
# "grid" constrains the locations of input points to lie on a grid of
47
# the specified spacing (in pixels).
51
# some other possible operations:
52
# regularize (arrange points on circle)
53
# transformations: skew, distort, scale
54
# label text (inside or relative)
55
# fill & outline color
56
# fill & outline stipple
58
# outline dash (mark, space offset)
60
# number of peripheries
64
# raise/lower (not required if no overlap)
66
# constraints: no overlap
69
# resources: shape library
73
########################################################################
75
set splinecolor orange
79
proc nextpoint {vc c wx wy} {
80
global id mode oldx oldy gain0 angle0 index grid
82
set x [$c canvasx $wx]
83
set y [$c canvasy $wy]
84
set gx [expr $grid * int(($x / $grid) + 0.5)]
85
set gy [expr $grid * int(($y / $grid) + 0.5)]
89
$c insert $id 0 [list $gx $gy]
91
set id [$c create polygon $gx $gy $gx $gy \
92
-fill red -outline #ffc000]
97
$c insert $id $index [list $gx $gy]
99
set id [$c find withtag current]
103
set index [$c index $id @$x,$y]
105
$c insert $id $index [list $gx $gy]
110
set id [$c find withtag current]
112
set index [$c index $id @$x,$y]
113
if {[llength [$c coords $id]] > 4} {$c dchars $id $index}
114
$vc coords [lindex [$c gettags $id] 0] [$c coords $id]
119
if [info exists id] {
120
set tag [$vc insert [$c coords $id]]
121
$c addtag $tag withtag $id
123
set t [$c find withtag current]
125
set id [$c create [$c type $t] [$c coords $t]]
126
foreach config [$c itemconfigure $t] {
127
foreach {config . . . val} $config {break}
128
if {$config != "-tags"} {
129
$c itemconfigure $id $config $val
137
set id [$c find withtag current]
146
set id [$c find withtag current]
150
foreach {oldx oldy} \
151
[$vc center [lindex [$c gettags $id] 0]] {break}
152
set dx [expr $oldx-$x]
153
set dy [expr $oldy-$y]
154
set gain0 [expr sqrt($dx*$dx+$dy*$dy)]
158
set id [$c find withtag current]
162
foreach {oldx oldy} [$vc center [lindex [$c gettags $id] 0]] {
165
set angle0 [expr atan2($x-$oldx, $oldy-$y)]
169
if [info exists id] {
170
set path [$c coords $id]
171
if [catch {$vc path $path} path] {
175
$c itemconfigure $id -fill red
176
set id [$c create line $x $y $x $y \
177
-fill red -state disabled]
180
set id [$c create line $gx $gy $gx $gy \
181
-fill red -state disabled]
185
if [info exists id] {
186
set path [$c coords $id]
187
if [catch {$vc bpath $path} path] {
191
$c itemconfigure $id -fill orange
192
set id [$c create line $x $y $x $y \
193
-smooth spline -fill orange -state disabled]
196
set id [$c create line $gx $gy $gx $gy \
197
-smooth spline -fill orange -state disabled]
201
$vc remove [lindex [$c gettags current] 0]
206
if {[$vc bind triangle] == {}} {
208
if {$mode == "triangulate"} {
209
$c create polygon %t -tag triangles \
210
-fill {} -outline white -width 2
212
$c create polygon %t -tag triangles \
213
-fill {} -outline white -width 2 -state hidden
217
if {$mode == "triangulate"} {
218
$c itemconfigure triangles -state normal
220
$c itemconfigure triangles -state hidden
222
set t [$vc find $x $y]
228
set t [$vc find $x $y]
230
puts "at: $x $y ....nothing"
232
puts "at: $x $y\nid: $t\ncoords: [$vc coords $t]"
238
proc lastpoint {vc c args} {
240
if [info exists id] {
243
$c itemconfigure $id -fill darkgreen \
244
-outline yellow -activeoutline #ffc000
245
set tag [$vc insert [$c coords $id]]
246
$c addtag $tag withtag $id
249
set tag [$vc insert [$c coords $id]]
250
$c addtag $tag withtag $id
252
move - stretch - rotate - scale {
253
set t [lindex [$c gettags $id] 0]
254
if {$t != {} && $t != "current"} {
255
$vc coords $t [$c coords $id]
259
set path [$c coords $id]
260
if [catch {$vc path $path} path] {
265
$c itemconfigure $id -fill
269
set path [$c coords $id]
270
if [catch {$vc bpath $path} path] {
275
$c itemconfigure $id -fill red
279
$c configure -scrollregion [$c bbox all]
284
proc motion {vc c wx wy} {
285
global id mode oldx oldy gain0 angle0 index grid showmouse
286
set x [$c canvasx $wx]
287
set y [$c canvasy $wy]
288
if {$showmouse == "on"} {
289
puts -nonewline stderr "\r$x,$y [list [$vc find $x $y]] "
291
if [info exists id] {
294
set gx [expr $grid * int(($x / $grid) + 0.5)]
295
set gy [expr $grid * int(($y / $grid) + 0.5)]
297
$c insert $id 0 [list $gx $gy]
301
$c insert $id 0 [list $x $y]
305
$c insert $id 0 [list $x $y]
309
$c scan dragto $wx $wy 1
311
set gx [expr $grid * int(($x / $grid) + 0.5)]
312
set gy [expr $grid * int(($y / $grid) + 0.5)]
313
$c move $id [expr $gx - $oldx] [expr $gy - $oldy]
319
set gx [expr $grid * int(($x / $grid) + 0.5)]
320
set gy [expr $grid * int(($y / $grid) + 0.5)]
322
$c insert $id $index [list $gx $gy]
325
set t [lindex [$c gettags $id] 0]
326
set dx [expr $x-$oldx]
327
set dy [expr $y-$oldy]
328
set gain [expr sqrt($dx*$dx+$dy*$dy)/20]
329
$c coords $id [$vc scale $t $gain]
332
set t [lindex [$c gettags $id] 0]
333
set alpha [expr atan2($x-$oldx,$oldy-$y) - $angle0]
334
$c coords $id [$vc rotate $t $alpha]
340
proc clearpaths {vc c} {
341
catch { $c delete triangles }
342
foreach i [$c find all] {
344
if {$t == "line"} {$c delete $i}
348
proc clearall {vc c} {
349
catch { $c delete triangles }
350
foreach i [$c find all] {
351
if {[$c type $i] == "polygon"} {$vc remove [lindex [$c gettags $i] 0]}
356
proc loadpaths {vc c file} {
357
if [catch {open $file r} f] {
358
error "unable to open file for read: $file"
363
if {$path == {}} {continue}
364
if [catch {$vc bpath $path} path] {
367
$c create line $path \
368
-smooth spline -fill #ff00c0 -state disabled
372
$c configure -scrollregion [$c bbox all]
375
proc loadvconfig {vc c file} {
376
if [catch {open $file r} f] {
377
error "unable to open file for read: $file"
381
set coords [string trim [gets $f]]
382
if {$coords == {}} {continue}
383
set tag [$vc insert $coords]
384
$c create polygon $coords \
388
-activeoutline #ffc000
391
$c configure -scrollregion [$c bbox all]
394
proc savepaths {vc c file} {
395
if [catch {open $file w} f] {
396
error "unable to open file for write: $file"
398
foreach i [$c find all] {
401
set path [$c coords $i]
402
set l [llength $path]
403
set x1 [lindex $path 0]
404
set y1 [lindex $path 1]
405
set x2 [lindex $path [incr l -2]]
406
set y2 [lindex $path [incr l]]
407
puts $f "$x1 $y1 $x2 $y2"
413
proc savevconfig {vc c file} {
414
if [catch {open $file w} f] {
415
error "unable to open file for write: $file"
417
foreach id [$vc list] {
418
puts $f [$vc coords $id]
425
set filename [file join [file dirname $filename] [file tail $filename]]
426
set files [glob [file join [file dirname $filename] *[file extension $filename]]]
427
set filename [lindex $files [expr ([lsearch $files $filename] + 1) % [llength $files]]]
432
set filename "pathplan_data/unknown.dat"
440
-xscrollcommand "$b.h set" \
441
-yscrollcommand "$a.v set"]
442
scrollbar $b.h -command "$c xview" -orient horiz
443
scrollbar $a.v -command "$c yview"
445
-width [expr [$a.v cget -width] + \
446
[$a.v cget -bd]*2 + [$a.v cget -highlightthickness]*2 ] \
447
-height [expr [$b.h cget -width] + \
448
[$b.h cget -bd]*2 + [.fl.b.h cget -highlightthickness]*2 ]
451
pack [radiobutton .fr.bpath.bpath -text "bezier path" -value bpath \
452
-highlightthickness 0 -anchor w -variable mode] \
453
-side left -anchor w -fill x
454
pack [scale .fr.grid -orient horizontal -label grid -variable grid \
455
-highlightthickness 0 -from 1 -to 100] \
456
[radiobutton .fr.draw -text draw -value draw \
457
-highlightthickness 0 -anchor w -variable mode] \
458
[radiobutton .fr.stretch -text stretch -value stretch \
459
-highlightthickness 0 -anchor w -variable mode] \
460
[radiobutton .fr.collapse -text collapse -value collapse \
461
-highlightthickness 0 -anchor w -variable mode] \
462
[radiobutton .fr.clone -text clone -value clone \
463
-highlightthickness 0 -anchor w -variable mode] \
464
[radiobutton .fr.move -text move -value move \
465
-highlightthickness 0 -anchor w -variable mode] \
466
[radiobutton .fr.rotate -text rotate -value rotate \
467
-highlightthickness 0 -anchor w -variable mode] \
468
[radiobutton .fr.scale -text scale -value scale \
469
-highlightthickness 0 -anchor w -variable mode] \
470
[radiobutton .fr.delete -text delete -value delete \
471
-highlightthickness 0 -anchor w -variable mode] \
472
[radiobutton .fr.path -text path -value path \
473
-highlightthickness 0 -anchor w -variable mode] \
475
[radiobutton .fr.id -text id -value id \
476
-highlightthickness 0 -anchor w -variable mode] \
477
[radiobutton .fr.triangulate -text triangulate -value triangulate \
478
-highlightthickness 0 -anchor w -variable mode] \
481
pack [button .fr.load.load -text load \
482
-highlightthickness 0 -command "loadvconfig $vc $c \$filename"] \
483
[button .fr.load.paths -text loadpaths \
484
-highlightthickness 0 -command "loadpaths $vc $c \$filename"] \
485
-side left -fill x -expand true
487
pack [button .fr.save.save -text save \
488
-highlightthickness 0 -command "savevconfig $vc $c \$filename"] \
489
[button .fr.save.paths -text savepaths \
490
-highlightthickness 0 -command "savepaths $vc $c \$filename"] \
491
-side left -fill x -expand true
493
pack [button .fr.clear.all -text clear -command "clearall $vc $c" \
494
-highlightthickness 0] \
495
[button .fr.clear.paths -text clearpaths -command "clearpaths $vc $c" \
496
-highlightthickness 0] \
497
-side left -fill x -expand true
499
pack [entry .fr.file.name -textvar filename -highlightthickness 0] \
500
-side left -fill x -expand true
501
pack [button .fr.file.next -text next \
502
-highlightthickness 0 -command "nextfile"] \
505
pack [button .fr.quitdebug.debug -text debug \
506
-highlightthickness 0 -command "$vc debug"] \
507
[button .fr.quitdebug.quit -text quit \
508
-highlightthickness 0 -command "exit"] \
509
-side left -fill x -expand true
510
pack .fr.quitdebug .fr.clear .fr.save .fr.load .fr.file \
511
[label .fr.flabel -anchor w -text "file"] \
512
[entry .fr.coordinates -textvar coordinates -highlightthickness 0] \
513
[label .fr.clabel -anchor w -text "coordinates"] \
514
-side bottom -fill x -expand true
515
pack $a.v -side right -fill y
516
pack $c -side left -fill both -expand true
517
pack $b.h -side left -fill x -expand true
518
pack $b.pad -side right
519
pack $b -side bottom -fill x
520
pack $a -side top -fill both -expand true
521
pack .fl -side left -fill both -expand true
522
pack .fr -side left -fill y
524
bind $c <1> "nextpoint $vc $c %x %y"
525
bind $c <2> "lastpoint $vc $c"
526
bind $c <Motion> "motion $vc $c %x %y"
528
trace variable mode w "lastpoint $vc $c"
530
bind .fr.file.name <Return> {
531
.fr.loadsave.load flash
532
loadvconfig $vc $c $filename
535
bind .fr.coordinates <Return> {
536
if {$coordinates == {}} {continue}
537
set coords [split $coordinates]
541
if [catch {$vc insert $coords} tag] {
544
$c create polygon $coords \
547
-activeoutline #ffc000 \
552
if [catch {$vc path $coords} coords] {
555
$c create line $coords -fill #ff00c0 -state disabled
559
if [catch {$vc bpath $coords} coords] {
562
$c create line $coords \
563
-smooth spline -fill orange -state disabled
569
proc balloon_help {w msg} {
570
bind $w <Enter> "after 1000 \"balloon_help_aux %W [list $msg]\""
571
bind $w <Leave> "after cancel \"balloon_help_aux %W [list $msg]\"
572
catch {destroy %W.balloon_help}"
575
proc balloon_help_aux {w msg} {
576
set t $w.balloon_help
579
wm overrideredirect $t 1
580
pack [label $t.l -text $msg -relief groove -bd 1 -bg yellow] -fill both
581
wm geometry $t +[expr [winfo rootx $w]+([winfo width $w]/2)]+[expr \
582
[winfo rooty $w]+([winfo height $w]/2)]
585
balloon_help .fr.grid "set grid size for draw operations"
586
balloon_help .fr.draw "draw a region. B1 foreach vertex except B2 for last"
587
balloon_help .fr.stretch "B1 to stretch a vertex, next B1 inserts new vertex. B2 to end"
588
balloon_help .fr.collapse "B1 collapses a vertex"
589
balloon_help .fr.clone "each B1 creates a new clone of a region, B2 to end"
590
balloon_help .fr.move "B1 to move, B2 to end"
591
balloon_help .fr.rotate "B1 to rotate, B2 to end"
592
balloon_help .fr.scale "B1 to scale, B2 to end"
593
balloon_help .fr.delete "B1 to delete a region"
594
balloon_help .fr.path "B1 starts a euclidean shortest path, B2 to end"
595
balloon_help .fr.bpath.bpath "B1 starts a bezier spline path, B2 to end"
596
balloon_help .fr.triangulate "B1 to display triangulation of a polygon"
597
balloon_help .fr.id "print the identifier of a region"
598
balloon_help .fr.coordinates "text entry of coordinates, alternative to button operations"
599
balloon_help .fr.file.name "current file name, or enter new name"
600
balloon_help .fr.file.next "next file with same directory and extension"
601
balloon_help .fr.save.paths "save paths to file"
602
balloon_help .fr.load.paths "load paths from file"
603
balloon_help .fr.save.save "save regions to file"
604
balloon_help .fr.load.load "load regions from file"
605
balloon_help .fr.clear.all "clear canvas of all regions and paths"
606
balloon_help .fr.clear.paths "clear canvas of all paths"
607
balloon_help .fr.quitdebug.quit "quit this application"
608
balloon_help .fr.quitdebug.debug "dump the vconfig"
added
removed
tclpkg/tclpathplan/demo/pathplan
