︙ | | |
37
38
39
40
41
42
43
44
45
46
47
48
49
50
|
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
set font1 {Helvetica 16 bold} ;# default token font
set font2 {GillSans 14 bold} ;# default variable font
set RADIUS 9 ;# default turn radius
set HSEP 17 ;# horizontal separation
set VSEP 9 ;# vertical separation
set DPI 80 ;# dots per inch
# Move all widgets with $tag and/or $tag-txt
#
proc move_glyphs {tag dx dy} {
.c move $tag $dx $dy
.c move $tag-txt $dx $dy
}
# Change all widgets tagged with $old to $new or with $old-txt to $new-txt
#
proc retag {old new} {
.c addtag $new withtag $old
.c addtag $new-txt withtag $old-txt
.c dtag $old
.c dtag $old-txt
}
# Draw a right-hand turn around. Approximately a ")"
#
proc draw_right_turnback {tag x y0 y1} {
global RADIUS
if {$y0 + 2*$RADIUS < $y1} {
set xr0 [expr {$x-$RADIUS}]
|
︙ | | |
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
|
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
|
-
+
-
-
-
+
-
+
-
-
+
+
-
+
-
+
-
+
|
} elseif {[regexp {^[a-z]} $txt]} {
set font $::font2
set istoken 0
} else {
set font $::font1
set istoken 1
}
set id1 [.c create text 0 0 -anchor c -text $txt -font $font -tags $tag]
set id1 [.c create text 0 0 -anchor c -text $txt -font $font -tags $tag-txt]
foreach {x0 y0 x1 y1} [.c bbox $id1] break
set h [expr {$y1-$y0+2}]
set rad [expr {($h+1)/2}]
set top [expr {$y0-2}]
set btm [expr {$y1}]
set fudge [expr {int(3*$istoken + [string length $txt]*1.4)}]
#puts "fudge($txt)=$fudge"
set left [expr {$x0+$fudge}]
set right [expr {$x1-$fudge}]
if {$left>$right} {
set left [expr {($x0+$x1)/2}]
set right $left
}
set tag2 x$tagcnt-box
set tags [list $tag $tag2]
if {$istoken} {
.c create arc [expr {$left-$rad}] $top [expr {$left+$rad}] $btm \
-width 2 -start 90 -extent 180 -style arc -tags $tags
-width 2 -start 90 -extent 180 -style arc -tags $tag
.c create arc [expr {$right-$rad}] $top [expr {$right+$rad}] $btm \
-width 2 -start -90 -extent 180 -style arc -tags $tags
-width 2 -start -90 -extent 180 -style arc -tags $tag
if {$left<$right} {
.c create line $left $top $right $top -width 2 -tags $tags
.c create line $left $btm $right $btm -width 2 -tags $tags
.c create line $left $top $right $top -width 2 -tags $tag
.c create line $left $btm $right $btm -width 2 -tags $tag
}
} else {
.c create rect $left $top $right $btm -width 2 -tags $tags
.c create rect $left $top $right $btm -width 2 -tags $tag
}
foreach {x0 y0 x1 y1} [.c bbox $tag2] break
foreach {x0 y0 x1 y1} [.c bbox $tag] break
set width [expr {$x1-$x0}]
.c move $tag [expr {-$x0}] 0
move_glyphs $tag [expr {-$x0}] 0
# Entry is always 0 0
# Return: TAG EXIT_X EXIT_Y
#
return [list $tag $width 0]
}
|
︙ | | |
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
|
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
|
-
+
-
-
+
|
set exx 0
set exy 0
foreach term $lx {
set m [draw_diagram $term]
foreach {t texx texy} $m break
if {$exx>0} {
set xn [expr {$exx+$sep}]
.c move $t $xn $exy
move_glyphs $t $xn $exy
.c create line [expr {$exx-1}] $exy $xn $exy \
-tags $tag -width 2 -arrow last
set exx [expr {$xn+$texx}]
} else {
set exx $texx
}
set exy $texy
.c addtag $tag withtag $t
.c dtag $t $t
retag $t $tag
}
if {$exx==0} {
set exx [expr {$sep*2}]
.c create line 0 0 $sep 0 -width 2 -tags $tag -arrow last
.c create line $sep 0 $exx 0 -width 2 -tags $tag
set exx $sep
}
|
︙ | | |
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
|
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
|
-
+
-
-
+
|
foreach term $lb {
set m [draw_diagram $term]
foreach {t texx texy} $m break
foreach {tx0 ty0 tx1 ty1} [.c bbox $t] break
set w [expr {$tx1-$tx0}]
if {$exx>0} {
set xn [expr {$exx+$sep}]
.c move $t $xn 0
move_glyphs $t $xn 0
.c create line $exx $exy $xn $exy -tags $tag -width 2 -arrow first
set exx [expr {$xn+$texx}]
} else {
set exx $texx
}
set exy $texy
.c addtag $tag withtag $t
.c dtag $t $t
retag $t $tag
}
if {$exx==0} {
.c create line 0 0 $sep 0 -width 2 -tags $tag
set exx $sep
}
return [list $tag $exx $exy]
}
|
︙ | | |
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
|
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
|
-
+
-
-
+
|
if {$bypass_y>0} {
set mid_y [expr {($bypass_y+$RADIUS+$back_y)/2}]
.c create line $bypass_x $bypass_y $bypass_x $mid_y \
-width 2 -tags $tag -arrow last
.c create line $bypass_x $mid_y $bypass_x [expr {$back_y+$RADIUS}] \
-tags $tag -width 2
}
.c move $t $enter_x $enter_y
move_glyphs $t $enter_x $enter_y
set e2 [expr {$exit_x + $sep}]
.c create line $exit_x $exit_y $e2 $exit_y \
-width 2 -tags $tag
draw_right_turnback $tag $e2 $exit_y $back_y
set e3 [expr {$enter_x-$sep}]
set bypass_x [expr {$e3-$RADIUS}]
set emid [expr {($e2+$e3)/2}]
.c create line $e2 $back_y $emid $back_y \
-width 2 -tags $tag -arrow last
.c create line $emid $back_y $e3 $back_y \
-width 2 -tags $tag
set r2 [expr {($enter_y - $back_y)/2.0}]
draw_left_turnback $tag $e3 $back_y $enter_y down
.c create line $e3 $enter_y $enter_x $enter_y \
-arrow last -width 2 -tags $tag
set exit_x [expr {$enter_x + $exx}]
set exit_y [expr {$enter_y + $exy}]
}
.c addtag $tag withtag $t
.c dtag $t $t
retag $t $tag
set btm [lindex [.c bbox $tag] 3]
incr i
}
if {$bypass} {
set fwd_y [expr {$btm + $sep + 1}]
set mid_y [expr {($next_bypass_y+$RADIUS+$fwd_y)/2}]
set descender_x [expr {$exit_x+$RADIUS}]
|
︙ | | |
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
|
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
|
-
+
-
+
-
+
-
+
-
-
-
-
-
+
+
+
|
foreach {ft fexx fexy} [draw_diagram $forward] break
foreach {fx0 fy0 fx1 fy1} [.c bbox $ft] break
set fw [expr {$fx1-$fx0}]
foreach {bt bexx bexy} [draw_backwards_line $back] break
foreach {bx0 by0 bx1 by1} [.c bbox $bt] break
set bw [expr {$bx1-$bx0}]
set dy [expr {$fy1 - $by0 + $vsep}]
.c move $bt 0 $dy
move_glyphs $bt 0 $dy
set biny $dy
set bexy [expr {$dy+$bexy}]
set by0 [expr {$dy+$by0}]
set by1 [expr {$dy+$by1}]
if {$fw>$bw} {
if {$fexx<$fw && $fexx>=$bw} {
set dx [expr {($fexx-$bw)/2}]
.c move $bt $dx 0
move_glyphs $bt $dx 0
set bexx [expr {$dx+$bexx}]
.c create line 0 $biny $dx $biny -width 2 -tags $bt
.c create line $bexx $bexy $fexx $bexy -width 2 -tags $bt -arrow first
set mxx $fexx
} else {
set dx [expr {($fw-$bw)/2}]
.c move $bt $dx 0
move_glyphs $bt $dx 0
set bexx [expr {$dx+$bexx}]
.c create line 0 $biny $dx $biny -width 2 -tags $bt
.c create line $bexx $bexy $fx1 $bexy -width 2 -tags $bt -arrow first
set mxx $fexx
}
} elseif {$bw>$fw} {
set dx [expr {($bw-$fw)/2}]
.c move $ft $dx 0
move_glyphs $ft $dx 0
set fexx [expr {$dx+$fexx}]
.c create line 0 0 $dx $fexy -width 2 -tags $ft -arrow last
.c create line $fexx $fexy $bx1 $fexy -width 2 -tags $ft
set mxx $bexx
}
.c addtag $tag withtag $bt
.c addtag $tag withtag $ft
.c dtag $bt $bt
.c dtag $ft $ft
.c move $tag $sep 0
retag $bt $tag
retag $ft $tag
move_glyphs $tag $sep 0
set mxx [expr {$mxx+$sep}]
.c create line 0 0 $sep 0 -width 2 -tags $tag
draw_left_turnback $tag $sep 0 $biny up
draw_right_turnback $tag $mxx $fexy $bexy
foreach {x0 y0 x1 y1} [.c bbox $tag] break
set exit_x [expr {$mxx+$::RADIUS}]
.c create line $mxx $fexy $exit_x $fexy -width 2 -tags $tag
|
︙ | | |
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
|
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
|
-
+
-
+
-
+
-
-
-
-
-
+
+
+
|
foreach {ft fexx fexy} [draw_diagram $forward] break
foreach {fx0 fy0 fx1 fy1} [.c bbox $ft] break
set fw [expr {$fx1-$fx0}]
foreach {bt bexx bexy} [draw_backwards_line $back] break
foreach {bx0 by0 bx1 by1} [.c bbox $bt] break
set bw [expr {$bx1-$bx0}]
set dy [expr {-($by1 - $fy0 + $vsep)}]
.c move $bt 0 $dy
move_glyphs $bt 0 $dy
set biny $dy
set bexy [expr {$dy+$bexy}]
set by0 [expr {$dy+$by0}]
set by1 [expr {$dy+$by1}]
if {$fw>$bw} {
set dx [expr {($fw-$bw)/2}]
.c move $bt $dx 0
move_glyphs $bt $dx 0
set bexx [expr {$dx+$bexx}]
.c create line 0 $biny $dx $biny -width 2 -tags $bt
.c create line $bexx $bexy $fx1 $bexy -width 2 -tags $bt -arrow first
set mxx $fexx
} elseif {$bw>$fw} {
set dx [expr {($bw-$fw)/2}]
.c move $ft $dx 0
move_glyphs $ft $dx 0
set fexx [expr {$dx+$fexx}]
.c create line 0 0 $dx $fexy -width 2 -tags $ft
.c create line $fexx $fexy $bx1 $fexy -width 2 -tags $ft
set mxx $bexx
}
.c addtag $tag withtag $bt
.c addtag $tag withtag $ft
.c dtag $bt $bt
.c dtag $ft $ft
.c move $tag $sep 0
retag $bt $tag
retag $ft $tag
move_glyphs $tag $sep 0
set mxx [expr {$mxx+$sep}]
.c create line 0 0 $sep 0 -width 2 -tags $tag
draw_left_turnback $tag $sep 0 $biny down
draw_right_turnback $tag $mxx $fexy $bexy
foreach {x0 y0 x1 y1} [.c bbox $tag] break
.c create line $mxx $fexy $x1 $fexy -width 2 -tags $tag
return [list $tag $x1 $fexy]
|
︙ | | |
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
|
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
|
-
+
-
+
|
for {set i 0} {$i<$n} {incr i} {
foreach {t texx texy} $m($i) break
foreach {tx0 ty0 tx1 ty1} [.c bbox $t] break
set w [expr {$tx1-$tx0}]
set dx [expr {($mxw-$w)/2 + $x2}]
if {$w>10 && $dx>$x2+10} {set dx [expr {$x2+10}]}
.c move $t $dx 0
move_glyphs $t $dx 0
set texx [expr {$texx+$dx}]
set m($i) [list $t $texx $texy]
foreach {tx0 ty0 tx1 ty1} [.c bbox $t] break
if {$i==0} {
if {$dx>$x2} {set ax last} {set ax none}
.c create line 0 0 $dx 0 -width 2 -tags $tag -arrow $ax
.c create line $texx $texy [expr {$x5+1}] $texy -width 2 -tags $tag
set exy $texy
.c create arc -$sep 0 $sep [expr {$sep*2}] \
-width 2 -start 90 -extent -90 -tags $tag -style arc
set btm $ty1
} else {
set dy [expr {$btm - $ty0 + $vsep}]
if {$dy<2*$sep} {set dy [expr {2*$sep}]}
.c move $t 0 $dy
move_glyphs $t 0 $dy
set texy [expr {$texy+$dy}]
if {$dx>$x2} {
.c create line $x2 $dy $dx $dy -width 2 -tags $tag -arrow last
if {$dx<$xc-2} {set ax last} {set ax none}
.c create line $texx $texy $x3 $texy -width 2 -tags $tag -arrow $ax
}
set y1 [expr {$dy-2*$sep}]
|
︙ | | |
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
|
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
|
-
-
+
|
-width 2 -start 180 -extent -90 -tags $tag -style arc
.c create line $x1 [expr {$dy-$sep}] $x1 $sep -width 2 -tags $tag
.c create line $x4 [expr {$texy-$sep}] $x4 [expr {$exy+$sep}] \
-width 2 -tags $tag
}
set btm [expr {$ty1+$dy}]
}
.c addtag $tag withtag $t
.c dtag $t $t
retag $t $tag
}
return [list $tag $x5 $exy]
}
proc draw_tail_branch {lx} {
global tagcnt
incr tagcnt
|
︙ | | |
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
|
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
|
-
+
-
+
-
-
+
|
set x1 $sep ;# decender
set x2 [expr {$sep*2}] ;# start of choice
for {set i 0} {$i<$n} {incr i} {
foreach {t texx texy} $m($i) break
foreach {tx0 ty0 tx1 ty1} [.c bbox $t] break
set dx [expr {$x2+10}]
.c move $t $dx 0
move_glyphs $t $dx 0
foreach {tx0 ty0 tx1 ty1} [.c bbox $t] break
if {$i==0} {
.c create line 0 0 $dx 0 -width 2 -tags $tag -arrow last
.c create arc -$sep 0 $sep [expr {$sep*2}] \
-width 2 -start 90 -extent -90 -tags $tag -style arc
set btm $ty1
} else {
set dy [expr {$btm - $ty0 + $vsep}]
if {$dy<2*$sep} {set dy [expr {2*$sep}]}
.c move $t 0 $dy
move_glyphs $t 0 $dy
if {$dx>$x2} {
.c create line $x2 $dy $dx $dy -width 2 -tags $tag -arrow last
}
set y1 [expr {$dy-2*$sep}]
.c create arc $x1 $y1 [expr {$x1+2*$sep}] $dy \
-width 2 -start 180 -extent 90 -style arc -tags $tag
if {$i==$n-1} {
.c create line $x1 [expr {$dy-$sep}] $x1 $sep -width 2 -tags $tag
}
set btm [expr {$ty1+$dy}]
}
.c addtag $tag withtag $t
.c dtag $t $t
retag $t $tag
}
return [list $tag 0 0]
}
proc draw_diagram {spec} {
set n [llength $spec]
if {$n==1} {
|
︙ | | |
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
|
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
|
-
+
|
proc draw_graph {name spec {do_xv 1}} {
.c delete all
wm deiconify .
wm title . $name
draw_diagram "line bullet [list $spec] bullet"
foreach {x0 y0 x1 y1} [.c bbox all] break
.c move all [expr {2-$x0}] [expr {2-$y0}]
move_glyphs all [expr {2-$x0}] [expr {2-$y0}]
foreach {x0 y0 x1 y1} [.c bbox all] break
.c create rect -100 -100 [expr {$x1+100}] [expr {$y1+100}] \
-fill white -outline white -tags bgrect
.c lower bgrect
.c config -width $x1 -height $y1
update
.c postscript -file $name.ps -width [expr {$x1+2}] -height [expr {$y1+2}]
|
︙ | | |