· 9 years ago · Feb 04, 2017, 06:56 PM
1canvas .c -bg white
2
3# Graphs:
4#
5set all_graphs {
6 sql-stmt-list {
7 toploop {optx sql-stmt} ;
8 }
9 sql-stmt {
10 line
11 {opt EXPLAIN {opt QUERY PLAN}}
12 {or
13 alter-table-stmt
14 analyze-stmt
15 attach-stmt
16 begin-stmt
17 commit-stmt
18 create-index-stmt
19 create-table-stmt
20 create-trigger-stmt
21 create-view-stmt
22 create-virtual-table-stmt
23 delete-stmt
24 delete-stmt-limited
25 detach-stmt
26 drop-index-stmt
27 drop-table-stmt
28 drop-trigger-stmt
29 drop-view-stmt
30 insert-stmt
31 pragma-stmt
32 reindex-stmt
33 release-stmt
34 rollback-stmt
35 savepoint-stmt
36 select-stmt
37 update-stmt
38 update-stmt-limited
39 vacuum-stmt
40 }
41 }
42 alter-table-stmt {
43 stack
44 {line ALTER TABLE {optx /database-name .} /table-name}
45 {tailbranch
46 {line RENAME TO /new-table-name}
47 {line ADD {optx COLUMN} column-def}
48 }
49 }
50 analyze-stmt {
51 line ANALYZE {or nil /database-name /table-name
52 {line /database-name . /table-name}}
53 }
54 attach-stmt {
55 line ATTACH {or DATABASE nil} /filename AS /database-name
56 }
57 begin-stmt {
58 line BEGIN {or nil DEFERRED IMMEDIATE EXCLUSIVE}
59 {optx TRANSACTION}
60 }
61 commit-stmt {
62 line {or COMMIT END} {optx TRANSACTION}
63 }
64 rollback-stmt {
65 line ROLLBACK {optx TRANSACTION}
66 {optx TO {optx SAVEPOINT} /savepoint-name}
67 }
68 savepoint-stmt {
69 line SAVEPOINT /savepoint-name
70 }
71 release-stmt {
72 line RELEASE {optx SAVEPOINT} /savepoint-name
73 }
74 create-index-stmt {
75 stack
76 {line CREATE {opt UNIQUE} INDEX {opt IF NOT EXISTS}}
77 {line {optx /database-name .} /index-name
78 ON /table-name ( {loop indexed-column ,} )}
79 }
80 indexed-column {
81 line /column-name {optx COLLATE /collation-name} {or ASC DESC nil}
82 }
83 create-table-stmt {
84 stack
85 {line CREATE {or {} TEMP TEMPORARY} TABLE {opt IF NOT EXISTS}}
86 {line {optx /database-name .} /table-name
87 {tailbranch
88 {line ( {loop column-def ,} {loop {} {, table-constraint}} )}
89 {line AS select-stmt}
90 }
91 }
92 }
93 column-def {
94 line /column-name {or type-name nil} {loop nil {nil column-constraint nil}}
95 }
96 type-name {
97 line {loop /name {}} {or {}
98 {line ( signed-number )}
99 {line ( signed-number , signed-number )}
100 }
101 }
102 column-constraint {
103 stack
104 {optx CONSTRAINT /name}
105 {or
106 {line PRIMARY KEY {or nil ASC DESC}
107 conflict-clause {opt AUTOINCREMENT}
108 }
109 {line NOT NULL conflict-clause}
110 {line UNIQUE conflict-clause}
111 {line CHECK ( expr )}
112 {line DEFAULT
113 {or
114 signed-number
115 literal-value
116 {line ( expr )}
117 }
118 }
119 {line COLLATE /collation-name}
120 {line foreign-key-clause}
121 }
122 }
123 signed-number {
124 line
125 {or nil + -}
126 {or /integer-literal /floating-point-literal}
127 }
128 table-constraint {
129 stack
130 {optx CONSTRAINT /name}
131 {or
132 {line {or {line PRIMARY KEY} UNIQUE}
133 ( {loop indexed-column ,} ) conflict-clause}
134 {line CHECK ( expr )}
135 {line FOREIGN KEY ( {loop /column-name ,} ) foreign-key-clause }
136 }
137 }
138 foreign-key-clause {
139 stack
140 {line REFERENCES /foreign-table {optx ( {loop /column-name ,} )}}
141 {loop
142 {or
143 {line ON {or DELETE UPDATE INSERT}
144 {or {line SET NULL} {line SET DEFAULT}
145 CASCADE RESTRICT
146 }
147 }
148 {line MATCH /name}
149 }
150 {}
151 }
152 {or
153 {line {optx NOT} DEFERRABLE
154 {or
155 {line INITIALLY DEFERRED}
156 {line INITIALLY IMMEDIATE}
157 {}
158 }
159 }
160 nil
161 }
162 }
163 conflict-clause {
164 opt {line ON CONFLICT {or ROLLBACK ABORT FAIL IGNORE REPLACE}}
165 }
166 create-trigger-stmt {
167 stack
168 {line CREATE {or {} TEMP TEMPORARY} TRIGGER {opt IF NOT EXISTS}}
169 {line {optx /database-name .} /trigger-name
170 {or BEFORE AFTER {line INSTEAD OF} nil}
171 }
172 {line
173 {or DELETE INSERT
174 {line UPDATE {opt OF {loop /column-name ,} }}
175 }
176 ON /table-name
177 }
178 {line {optx FOR EACH ROW}
179 {optx WHEN expr}
180 }
181 {line BEGIN
182 {loop
183 {line {or update-stmt insert-stmt delete-stmt select-stmt} ;}
184 nil
185 }
186 END
187 }
188 }
189 create-view-stmt {
190 stack
191 {line CREATE {or {} TEMP TEMPORARY} VIEW {opt IF NOT EXISTS}}
192 {line {optx /database-name .} /view-name AS select-stmt}
193 }
194 create-virtual-table-stmt {
195 stack
196 {line CREATE VIRTUAL TABLE {optx /database-name .} /table-name}
197 {line USING /module-name {optx ( {loop module-argument ,} )}}
198 }
199 delete-stmt {
200 line DELETE FROM qualified-table-name {optx WHERE expr}
201 }
202 delete-stmt-limited {
203 stack
204 {line DELETE FROM qualified-table-name {optx WHERE expr}}
205 {optx
206 {stack
207 {optx ORDER BY {loop ordering-term ,}}
208 {line LIMIT /integer {optx {or OFFSET ,} /integer}}
209 }
210 }
211 }
212 detach-stmt {
213 line DETACH {optx DATABASE} /database-name
214 }
215 drop-index-stmt {
216 line DROP INDEX {optx IF EXISTS} {optx /database-name .} /index-name
217 }
218 drop-table-stmt {
219 line DROP TABLE {optx IF EXISTS} {optx /database-name .} /table-name
220 }
221 drop-trigger-stmt {
222 line DROP TRIGGER {optx IF EXISTS} {optx /database-name .} /trigger-name
223 }
224 drop-view-stmt {
225 line DROP VIEW {optx IF EXISTS} {optx /database-name .} /view-name
226 }
227 expr {
228 or
229 {line literal-value}
230 {line bind-parameter}
231 {line {optx {optx /database-name .} /table-name .} /column-name}
232 {line /unary-operator expr}
233 {line expr /binary-operator expr}
234 {line /function-name ( {or {line {optx DISTINCT} {toploop expr ,}} {} *} )}
235 {line ( expr )}
236 {line CAST ( expr AS type-name )}
237 {line expr COLLATE /collation-name}
238 {line expr {optx NOT} {or LIKE GLOB REGEXP MATCH} expr
239 {optx ESCAPE expr}}
240 {line expr {or ISNULL NOTNULL {line IS NULL} {line NOT NULL}
241 {line IS NOT NULL}}}
242 {line expr {optx NOT} BETWEEN expr AND expr}
243 {line expr {optx NOT} IN
244 {or
245 {line ( {or {} select-stmt {loop expr ,}} )}
246 {line {optx /database-name .} /table-name}
247 }
248 }
249 {line {optx {optx NOT} EXISTS} ( select-stmt )}
250 {line CASE {optx expr} {loop {line WHEN expr THEN expr} {}}
251 {optx ELSE expr} END}
252 {line raise-function}
253 }
254 raise-function {
255 line RAISE (
256 {or IGNORE
257 {line {or ROLLBACK ABORT FAIL} , /error-message }
258 } )
259 }
260 literal-value {
261 or
262 {line /integer-literal}
263 {line /floating-point-literal}
264 {line /string-literal}
265 {line /blob-literal}
266 {line NULL}
267 {line CURRENT_TIME}
268 {line CURRENT_DATE}
269 {line CURRENT_TIMESTAMP}
270 }
271 insert-stmt {
272 stack
273 {line
274 {or
275 {line INSERT {opt OR {or ROLLBACK ABORT REPLACE FAIL IGNORE}}}
276 REPLACE
277 }
278 INTO {optx /database-name .} /table-name
279 }
280 {tailbranch
281 {line
282 {optx ( {loop /column-name ,} )}
283 {tailbranch
284 {line VALUES ( {loop expr ,} )}
285 select-stmt
286 }
287 }
288 {line DEFAULT VALUES}
289 }
290 }
291 pragma-stmt {
292 line PRAGMA {optx /database-name .} /pragma-name
293 {or
294 nil
295 {line = pragma-value}
296 {line ( pragma-value )}
297 }
298 }
299 pragma-value {
300 or
301 signed-number
302 /name
303 /string-literal
304 }
305 reindex-stmt {
306 line REINDEX
307 {tailbranch
308 /collation-name
309 {line {optx /database-name .}
310 {tailbranch /table-name /index-name}
311 }
312 }
313 }
314 select-stmt {
315 stack
316 {loop {line select-core nil} {nil compound-operator nil}}
317 {optx ORDER BY {loop ordering-term ,}}
318 {optx LIMIT /integer {optx {or OFFSET ,} /integer}}
319 }
320 select-core {
321 stack
322 {line SELECT {or nil DISTINCT ALL} {loop result-column ,}}
323 {optx FROM join-source}
324 {optx WHERE expr}
325 {optx GROUP BY {loop ordering-term ,} {optx HAVING expr}}
326
327 }
328 result-column {
329 or
330 *
331 {line /table-name . *}
332 {line expr {optx {optx AS} /column-alias}}
333 }
334 join-source {
335 line
336 single-source
337 {opt {loop {line nil join-op single-source join-constraint nil} {}}}
338 }
339 single-source {
340 or
341 {line
342 {optx /database-name .} /table-name
343 {optx {optx AS} /table-alias}
344 {or nil {line INDEXED BY /index-name} {line NOT INDEXED}}
345 }
346 {line
347 ( select-stmt ) {optx {optx AS} /table-alias}
348 }
349 {line ( join-source )}
350 }
351 join-op {
352 or
353 {line ,}
354 {line
355 {opt NATURAL}
356 {or {line {opt LEFT} {opt OUTER}} INNER CROSS}
357 JOIN
358 }
359 }
360 join-constraint {
361 or
362 {line ON expr}
363 {line USING ( {loop /column-name ,} )}
364 nil
365 }
366 ordering-term {
367 line expr {opt COLLATE /collation-name} {or nil ASC DESC}
368 }
369 compound-operator {
370 or {line UNION {optx ALL}} INTERSECT EXCEPT
371 }
372 update-stmt {
373 stack
374 {line UPDATE {opt OR {or ROLLBACK ABORT REPLACE FAIL IGNORE}}
375 qualified-table-name}
376 {line SET {loop {line /column-name = expr} ,} {optx WHERE expr}}
377 }
378 update-stmt-limited {
379 stack
380 {line UPDATE {opt OR {or ROLLBACK ABORT REPLACE FAIL IGNORE}}
381 qualified-table-name}
382 {line SET {loop {line /column-name = expr} ,} {optx WHERE expr}}
383 {optx
384 {stack
385 {optx ORDER BY {loop ordering-term ,}}
386 {line LIMIT /integer {optx {or OFFSET ,} /integer}}
387 }
388 }
389 }
390 qualified-table-name {
391 line {optx /database-name .} /table-name
392 {or nil {line INDEXED BY /index-name} {line NOT INDEXED}}
393 }
394 vacuum-stmt {
395 line VACUUM
396 }
397 comment-syntax {
398 or
399 {line -- {loop nil /anything-except-newline}
400 {or /newline /end-of-input}}
401 {line /* {loop nil /anything-except-*/}
402 {or */ /end-of-input}}
403 }
404}
405
406
407set tagcnt 0 ;# tag counter
408set font1 {Helvetica 16 bold} ;# default token font
409set font2 {Helvetica 15} ;# default variable font
410set RADIUS 9 ;# default turn radius
411set HSEP 17 ;# horizontal separation
412set VSEP 9 ;# vertical separation
413set DPI 160 ;# dots per inch
414
415
416# Draw a right-hand turn around. Approximately a ")"
417#
418proc draw_right_turnback {tag x y0 y1} {
419 global RADIUS
420 if {$y0 + 2*$RADIUS < $y1} {
421 set xr0 [expr {$x-$RADIUS}]
422 set xr1 [expr {$x+$RADIUS}]
423 .c create arc $xr0 $y0 $xr1 [expr {$y0+2*$RADIUS}] \
424 -width 2 -start 90 -extent -90 -tags $tag -style arc
425 set yr0 [expr {$y0+$RADIUS}]
426 set yr1 [expr {$y1-$RADIUS}]
427 if {abs($yr1-$yr0)>$RADIUS*2} {
428 set half_y [expr {($yr1+$yr0)/2}]
429 .c create line $xr1 $yr0 $xr1 $half_y -width 2 -tags $tag -arrow last
430 .c create line $xr1 $half_y $xr1 $yr1 -width 2 -tags $tag
431 } else {
432 .c create line $xr1 $yr0 $xr1 $yr1 -width 2 -tags $tag
433 }
434 .c create arc $xr0 [expr {$y1-2*$RADIUS}] $xr1 $y1 \
435 -width 2 -start 0 -extent -90 -tags $tag -style arc
436 } else {
437 set r [expr {($y1-$y0)/2.0}]
438 set x0 [expr {$x-$r}]
439 set x1 [expr {$x+$r}]
440 .c create arc $x0 $y0 $x1 $y1 \
441 -width 2 -start 90 -extent -180 -tags $tag -style arc
442 }
443}
444
445# Draw a left-hand turn around. Approximatley a "("
446#
447proc draw_left_turnback {tag x y0 y1 dir} {
448 global RADIUS
449 if {$y0 + 2*$RADIUS < $y1} {
450 set xr0 [expr {$x-$RADIUS}]
451 set xr1 [expr {$x+$RADIUS}]
452 .c create arc $xr0 $y0 $xr1 [expr {$y0+2*$RADIUS}] \
453 -width 2 -start 90 -extent 90 -tags $tag -style arc
454 set yr0 [expr {$y0+$RADIUS}]
455 set yr1 [expr {$y1-$RADIUS}]
456 if {abs($yr1-$yr0)>$RADIUS*3} {
457 set half_y [expr {($yr1+$yr0)/2}]
458 if {$dir=="down"} {
459 .c create line $xr0 $yr0 $xr0 $half_y -width 2 -tags $tag -arrow last
460 .c create line $xr0 $half_y $xr0 $yr1 -width 2 -tags $tag
461 } else {
462 .c create line $xr0 $yr1 $xr0 $half_y -width 2 -tags $tag -arrow last
463 .c create line $xr0 $half_y $xr0 $yr0 -width 2 -tags $tag
464 }
465 } else {
466 .c create line $xr0 $yr0 $xr0 $yr1 -width 2 -tags $tag
467 }
468 # .c create line $xr0 $yr0 $xr0 $yr1 -width 2 -tags $tag
469 .c create arc $xr0 [expr {$y1-2*$RADIUS}] $xr1 $y1 \
470 -width 2 -start 180 -extent 90 -tags $tag -style arc
471 } else {
472 set r [expr {($y1-$y0)/2.0}]
473 set x0 [expr {$x-$r}]
474 set x1 [expr {$x+$r}]
475 .c create arc $x0 $y0 $x1 $y1 \
476 -width 2 -start 90 -extent 180 -tags $tag -style arc
477 }
478}
479
480# Draw a bubble containing $txt.
481#
482proc draw_bubble {txt} {
483 global tagcnt
484 incr tagcnt
485 set tag x$tagcnt
486 if {$txt=="nil"} {
487 .c create line 0 0 1 0 -width 2 -tags $tag
488 return [list $tag 1 0]
489 } elseif {$txt=="bullet"} {
490 .c create oval 0 -3 6 3 -width 2 -tags $tag
491 return [list $tag 6 0]
492 }
493 if {[regexp {^/[a-z]} $txt]} {
494 set txt [string range $txt 1 end]
495 set font $::font2
496 set istoken 1
497 } elseif {[regexp {^[a-z]} $txt]} {
498 set font $::font2
499 set istoken 0
500 } else {
501 set font $::font1
502 set istoken 1
503 }
504 set id1 [.c create text 0 0 -anchor c -text $txt -font $font -tags $tag]
505 foreach {x0 y0 x1 y1} [.c bbox $id1] break
506 set h [expr {$y1-$y0+2}]
507 set rad [expr {($h+1)/2}]
508 set top [expr {$y0-2}]
509 set btm [expr {$y1}]
510 set left [expr {$x0+3*$istoken}]
511 set right [expr {$x1-3*$istoken}]
512 if {$left>$right} {
513 set left [expr {($x0+$x1)/2}]
514 set right $left
515 }
516 if {$istoken} {
517 .c create arc [expr {$left-$rad}] $top [expr {$left+$rad}] $btm \
518 -width 2 -start 90 -extent 180 -style arc -tags $tag
519 .c create arc [expr {$right-$rad}] $top [expr {$right+$rad}] $btm \
520 -width 2 -start -90 -extent 180 -style arc -tags $tag
521 if {$left<$right} {
522 .c create line $left $top $right $top -width 2 -tags $tag
523 .c create line $left $btm $right $btm -width 2 -tags $tag
524 }
525 } else {
526 .c create rect $left $top $right $btm -width 2 -tags $tag
527 }
528 foreach {x0 y0 x1 y1} [.c bbox $tag] break
529 set width [expr {$x1-$x0}]
530 .c move $tag [expr {-$x0}] 0
531
532 # Entry is always 0 0
533 # Return: TAG EXIT_X EXIT_Y
534 #
535 return [list $tag $width 0]
536}
537
538# Draw a sequence of terms from left to write. Each element of $lx
539# descripts a single term.
540#
541proc draw_line {lx} {
542 global tagcnt
543 incr tagcnt
544 set tag x$tagcnt
545
546 set sep $::HSEP
547 set exx 0
548 set exy 0
549 foreach term $lx {
550 set m [draw_diagram $term]
551 foreach {t texx texy} $m break
552 if {$exx>0} {
553 set xn [expr {$exx+$sep}]
554 .c move $t $xn $exy
555 .c create line [expr {$exx-1}] $exy $xn $exy \
556 -tags $tag -width 2 -arrow last
557 set exx [expr {$xn+$texx}]
558 } else {
559 set exx $texx
560 }
561 set exy $texy
562 .c addtag $tag withtag $t
563 .c dtag $t $t
564 }
565 if {$exx==0} {
566 set exx [expr {$sep*2}]
567 .c create line 0 0 $sep 0 -width 2 -tags $tag -arrow last
568 .c create line $sep 0 $exx 0 -width 2 -tags $tag
569 set exx $sep
570 }
571 return [list $tag $exx $exy]
572}
573
574# Draw a sequence of terms from right to left.
575#
576proc draw_backwards_line {lx} {
577 global tagcnt
578 incr tagcnt
579 set tag x$tagcnt
580
581 set sep $::HSEP
582 set exx 0
583 set exy 0
584 set lb {}
585 set n [llength $lx]
586 for {set i [expr {$n-1}]} {$i>=0} {incr i -1} {
587 lappend lb [lindex $lx $i]
588 }
589 foreach term $lb {
590 set m [draw_diagram $term]
591 foreach {t texx texy} $m break
592 foreach {tx0 ty0 tx1 ty1} [.c bbox $t] break
593 set w [expr {$tx1-$tx0}]
594 if {$exx>0} {
595 set xn [expr {$exx+$sep}]
596 .c move $t $xn 0
597 .c create line $exx $exy $xn $exy -tags $tag -width 2 -arrow first
598 set exx [expr {$xn+$texx}]
599 } else {
600 set exx $texx
601 }
602 set exy $texy
603 .c addtag $tag withtag $t
604 .c dtag $t $t
605 }
606 if {$exx==0} {
607 .c create line 0 0 $sep 0 -width 2 -tags $tag
608 set exx $sep
609 }
610 return [list $tag $exx $exy]
611}
612
613# Draw a sequence of terms from top to bottom.
614#
615proc draw_stack {indent lx} {
616 global tagcnt RADIUS VSEP
617 incr tagcnt
618 set tag x$tagcnt
619
620 set sep [expr {$VSEP*2}]
621 set btm 0
622 set n [llength $lx]
623 set i 0
624 set next_bypass_y 0
625
626 foreach term $lx {
627 set bypass_y $next_bypass_y
628 if {$i>0 && $i<$n && [llength $term]>1 &&
629 ([lindex $term 0]=="opt" || [lindex $term 0]=="optx")} {
630 set bypass 1
631 set term "line [lrange $term 1 end]"
632 } else {
633 set bypass 0
634 set next_bypass_y 0
635 }
636 set m [draw_diagram $term]
637 foreach {t exx exy} $m break
638 foreach {tx0 ty0 tx1 ty1} [.c bbox $t] break
639 if {$i==0} {
640 set btm $ty1
641 set exit_y $exy
642 set exit_x $exx
643 } else {
644 set enter_y [expr {$btm - $ty0 + $sep*2 + 2}]
645 if {$bypass} {set next_bypass_y [expr {$enter_y - $RADIUS}]}
646 set enter_x [expr {$sep*2 + $indent}]
647 set back_y [expr {$btm + $sep + 1}]
648 if {$bypass_y>0} {
649 set mid_y [expr {($bypass_y+$RADIUS+$back_y)/2}]
650 .c create line $bypass_x $bypass_y $bypass_x $mid_y \
651 -width 2 -tags $tag -arrow last
652 .c create line $bypass_x $mid_y $bypass_x [expr {$back_y+$RADIUS}] \
653 -tags $tag -width 2
654 }
655 .c move $t $enter_x $enter_y
656 set e2 [expr {$exit_x + $sep}]
657 .c create line $exit_x $exit_y $e2 $exit_y \
658 -width 2 -tags $tag
659 draw_right_turnback $tag $e2 $exit_y $back_y
660 set e3 [expr {$enter_x-$sep}]
661 set bypass_x [expr {$e3-$RADIUS}]
662 set emid [expr {($e2+$e3)/2}]
663 .c create line $e2 $back_y $emid $back_y \
664 -width 2 -tags $tag -arrow last
665 .c create line $emid $back_y $e3 $back_y \
666 -width 2 -tags $tag
667 set r2 [expr {($enter_y - $back_y)/2.0}]
668 draw_left_turnback $tag $e3 $back_y $enter_y down
669 .c create line $e3 $enter_y $enter_x $enter_y \
670 -arrow last -width 2 -tags $tag
671 set exit_x [expr {$enter_x + $exx}]
672 set exit_y [expr {$enter_y + $exy}]
673 }
674 .c addtag $tag withtag $t
675 .c dtag $t $t
676 set btm [lindex [.c bbox $tag] 3]
677 incr i
678 }
679 if {$bypass} {
680 set fwd_y [expr {$btm + $sep + 1}]
681 set mid_y [expr {($next_bypass_y+$RADIUS+$fwd_y)/2}]
682 set descender_x [expr {$exit_x+$RADIUS}]
683 .c create line $bypass_x $next_bypass_y $bypass_x $mid_y \
684 -width 2 -tags $tag -arrow last
685 .c create line $bypass_x $mid_y $bypass_x [expr {$fwd_y-$RADIUS}] \
686 -tags $tag -width 2
687 .c create arc $bypass_x [expr {$fwd_y-2*$RADIUS}] \
688 [expr {$bypass_x+2*$RADIUS}] $fwd_y \
689 -width 2 -start 180 -extent 90 -tags $tag -style arc
690 .c create arc [expr {$exit_x-$RADIUS}] $exit_y \
691 $descender_x [expr {$exit_y+2*$RADIUS}] \
692 -width 2 -start 90 -extent -90 -tags $tag -style arc
693 .c create arc $descender_x [expr {$fwd_y-2*$RADIUS}] \
694 [expr {$descender_x+2*$RADIUS}] $fwd_y \
695 -width 2 -start 180 -extent 90 -tags $tag -style arc
696 set exit_x [expr {$exit_x+2*$RADIUS}]
697 set half_x [expr {($exit_x+$indent)/2}]
698 .c create line [expr {$bypass_x+$RADIUS}] $fwd_y $half_x $fwd_y \
699 -width 2 -tags $tag -arrow last
700 .c create line $half_x $fwd_y $exit_x $fwd_y \
701 -width 2 -tags $tag
702 .c create line $descender_x [expr {$exit_y+$RADIUS}] \
703 $descender_x [expr {$fwd_y-$RADIUS}] \
704 -width 2 -tags $tag -arrow last
705 set exit_y $fwd_y
706 }
707 set width [lindex [.c bbox $tag] 2]
708 return [list $tag $exit_x $exit_y]
709}
710
711proc draw_loop {forward back} {
712 global tagcnt
713 incr tagcnt
714 set tag x$tagcnt
715 set sep $::HSEP
716 set vsep $::VSEP
717 if {$back==","} {
718 set vsep 0
719 } elseif {$back=="nil"} {
720 set vsep [expr {$vsep/2}]
721 }
722
723 foreach {ft fexx fexy} [draw_diagram $forward] break
724 foreach {fx0 fy0 fx1 fy1} [.c bbox $ft] break
725 set fw [expr {$fx1-$fx0}]
726 foreach {bt bexx bexy} [draw_backwards_line $back] break
727 foreach {bx0 by0 bx1 by1} [.c bbox $bt] break
728 set bw [expr {$bx1-$bx0}]
729 set dy [expr {$fy1 - $by0 + $vsep}]
730 .c move $bt 0 $dy
731 set biny $dy
732 set bexy [expr {$dy+$bexy}]
733 set by0 [expr {$dy+$by0}]
734 set by1 [expr {$dy+$by1}]
735
736 if {$fw>$bw} {
737 if {$fexx<$fw && $fexx>=$bw} {
738 set dx [expr {($fexx-$bw)/2}]
739 .c move $bt $dx 0
740 set bexx [expr {$dx+$bexx}]
741 .c create line 0 $biny $dx $biny -width 2 -tags $bt
742 .c create line $bexx $bexy $fexx $bexy -width 2 -tags $bt -arrow first
743 set mxx $fexx
744 } else {
745 set dx [expr {($fw-$bw)/2}]
746 .c move $bt $dx 0
747 set bexx [expr {$dx+$bexx}]
748 .c create line 0 $biny $dx $biny -width 2 -tags $bt
749 .c create line $bexx $bexy $fx1 $bexy -width 2 -tags $bt -arrow first
750 set mxx $fexx
751 }
752 } elseif {$bw>$fw} {
753 set dx [expr {($bw-$fw)/2}]
754 .c move $ft $dx 0
755 set fexx [expr {$dx+$fexx}]
756 .c create line 0 0 $dx $fexy -width 2 -tags $ft -arrow last
757 .c create line $fexx $fexy $bx1 $fexy -width 2 -tags $ft
758 set mxx $bexx
759 }
760 .c addtag $tag withtag $bt
761 .c addtag $tag withtag $ft
762 .c dtag $bt $bt
763 .c dtag $ft $ft
764 .c move $tag $sep 0
765 set mxx [expr {$mxx+$sep}]
766 .c create line 0 0 $sep 0 -width 2 -tags $tag
767 draw_left_turnback $tag $sep 0 $biny up
768 draw_right_turnback $tag $mxx $fexy $bexy
769 foreach {x0 y0 x1 y1} [.c bbox $tag] break
770 set exit_x [expr {$mxx+$::RADIUS}]
771 .c create line $mxx $fexy $exit_x $fexy -width 2 -tags $tag
772 return [list $tag $exit_x $fexy]
773}
774
775proc draw_toploop {forward back} {
776 global tagcnt
777 incr tagcnt
778 set tag x$tagcnt
779 set sep $::VSEP
780 set vsep [expr {$sep/2}]
781
782 foreach {ft fexx fexy} [draw_diagram $forward] break
783 foreach {fx0 fy0 fx1 fy1} [.c bbox $ft] break
784 set fw [expr {$fx1-$fx0}]
785 foreach {bt bexx bexy} [draw_backwards_line $back] break
786 foreach {bx0 by0 bx1 by1} [.c bbox $bt] break
787 set bw [expr {$bx1-$bx0}]
788 set dy [expr {-($by1 - $fy0 + $vsep)}]
789 .c move $bt 0 $dy
790 set biny $dy
791 set bexy [expr {$dy+$bexy}]
792 set by0 [expr {$dy+$by0}]
793 set by1 [expr {$dy+$by1}]
794
795 if {$fw>$bw} {
796 set dx [expr {($fw-$bw)/2}]
797 .c move $bt $dx 0
798 set bexx [expr {$dx+$bexx}]
799 .c create line 0 $biny $dx $biny -width 2 -tags $bt
800 .c create line $bexx $bexy $fx1 $bexy -width 2 -tags $bt -arrow first
801 set mxx $fexx
802 } elseif {$bw>$fw} {
803 set dx [expr {($bw-$fw)/2}]
804 .c move $ft $dx 0
805 set fexx [expr {$dx+$fexx}]
806 .c create line 0 0 $dx $fexy -width 2 -tags $ft
807 .c create line $fexx $fexy $bx1 $fexy -width 2 -tags $ft
808 set mxx $bexx
809 }
810 .c addtag $tag withtag $bt
811 .c addtag $tag withtag $ft
812 .c dtag $bt $bt
813 .c dtag $ft $ft
814 .c move $tag $sep 0
815 set mxx [expr {$mxx+$sep}]
816 .c create line 0 0 $sep 0 -width 2 -tags $tag
817 draw_left_turnback $tag $sep 0 $biny down
818 draw_right_turnback $tag $mxx $fexy $bexy
819 foreach {x0 y0 x1 y1} [.c bbox $tag] break
820 .c create line $mxx $fexy $x1 $fexy -width 2 -tags $tag
821 return [list $tag $x1 $fexy]
822}
823
824proc draw_or {lx} {
825 global tagcnt
826 incr tagcnt
827 set tag x$tagcnt
828 set sep $::VSEP
829 set vsep [expr {$sep/2}]
830 set n [llength $lx]
831 set i 0
832 set mxw 0
833 foreach term $lx {
834 set m($i) [set mx [draw_diagram $term]]
835 set tx [lindex $mx 0]
836 foreach {x0 y0 x1 y1} [.c bbox $tx] break
837 set w [expr {$x1-$x0}]
838 if {$i>0} {set w [expr {$w+20}]} ;# extra space for arrowheads
839 if {$w>$mxw} {set mxw $w}
840 incr i
841 }
842
843 set x0 0 ;# entry x
844 set x1 $sep ;# decender
845 set x2 [expr {$sep*2}] ;# start of choice
846 set xc [expr {$mxw/2}] ;# center point
847 set x3 [expr {$mxw+$x2}] ;# end of choice
848 set x4 [expr {$x3+$sep}] ;# accender
849 set x5 [expr {$x4+$sep}] ;# exit x
850
851 for {set i 0} {$i<$n} {incr i} {
852 foreach {t texx texy} $m($i) break
853 foreach {tx0 ty0 tx1 ty1} [.c bbox $t] break
854 set w [expr {$tx1-$tx0}]
855 set dx [expr {($mxw-$w)/2 + $x2}]
856 if {$w>10 && $dx>$x2+10} {set dx [expr {$x2+10}]}
857 .c move $t $dx 0
858 set texx [expr {$texx+$dx}]
859 set m($i) [list $t $texx $texy]
860 foreach {tx0 ty0 tx1 ty1} [.c bbox $t] break
861 if {$i==0} {
862 if {$dx>$x2} {set ax last} {set ax none}
863 .c create line 0 0 $dx 0 -width 2 -tags $tag -arrow $ax
864 .c create line $texx $texy [expr {$x5+1}] $texy -width 2 -tags $tag
865 set exy $texy
866 .c create arc -$sep 0 $sep [expr {$sep*2}] \
867 -width 2 -start 90 -extent -90 -tags $tag -style arc
868 set btm $ty1
869 } else {
870 set dy [expr {$btm - $ty0 + $vsep}]
871 if {$dy<2*$sep} {set dy [expr {2*$sep}]}
872 .c move $t 0 $dy
873 set texy [expr {$texy+$dy}]
874 if {$dx>$x2} {
875 .c create line $x2 $dy $dx $dy -width 2 -tags $tag -arrow last
876 if {$dx<$xc-2} {set ax last} {set ax none}
877 .c create line $texx $texy $x3 $texy -width 2 -tags $tag -arrow $ax
878 }
879 set y1 [expr {$dy-2*$sep}]
880 .c create arc $x1 $y1 [expr {$x1+2*$sep}] $dy \
881 -width 2 -start 180 -extent 90 -style arc -tags $tag
882 set y2 [expr {$texy-2*$sep}]
883 .c create arc [expr {$x3-$sep}] $y2 $x4 $texy \
884 -width 2 -start 270 -extent 90 -style arc -tags $tag
885 if {$i==$n-1} {
886 .c create arc $x4 $exy [expr {$x4+2*$sep}] [expr {$exy+2*$sep}] \
887 -width 2 -start 180 -extent -90 -tags $tag -style arc
888 .c create line $x1 [expr {$dy-$sep}] $x1 $sep -width 2 -tags $tag
889 .c create line $x4 [expr {$texy-$sep}] $x4 [expr {$exy+$sep}] \
890 -width 2 -tags $tag
891 }
892 set btm [expr {$ty1+$dy}]
893 }
894 .c addtag $tag withtag $t
895 .c dtag $t $t
896 }
897 return [list $tag $x5 $exy]
898}
899
900proc draw_tail_branch {lx} {
901 global tagcnt
902 incr tagcnt
903 set tag x$tagcnt
904 set sep $::VSEP
905 set vsep [expr {$sep/2}]
906 set n [llength $lx]
907 set i 0
908 foreach term $lx {
909 set m($i) [set mx [draw_diagram $term]]
910 incr i
911 }
912
913 set x0 0 ;# entry x
914 set x1 $sep ;# decender
915 set x2 [expr {$sep*2}] ;# start of choice
916
917 for {set i 0} {$i<$n} {incr i} {
918 foreach {t texx texy} $m($i) break
919 foreach {tx0 ty0 tx1 ty1} [.c bbox $t] break
920 set dx [expr {$x2+10}]
921 .c move $t $dx 0
922 foreach {tx0 ty0 tx1 ty1} [.c bbox $t] break
923 if {$i==0} {
924 .c create line 0 0 $dx 0 -width 2 -tags $tag -arrow last
925 .c create arc -$sep 0 $sep [expr {$sep*2}] \
926 -width 2 -start 90 -extent -90 -tags $tag -style arc
927 set btm $ty1
928 } else {
929 set dy [expr {$btm - $ty0 + $vsep}]
930 if {$dy<2*$sep} {set dy [expr {2*$sep}]}
931 .c move $t 0 $dy
932 if {$dx>$x2} {
933 .c create line $x2 $dy $dx $dy -width 2 -tags $tag -arrow last
934 }
935 set y1 [expr {$dy-2*$sep}]
936 .c create arc $x1 $y1 [expr {$x1+2*$sep}] $dy \
937 -width 2 -start 180 -extent 90 -style arc -tags $tag
938 if {$i==$n-1} {
939 .c create line $x1 [expr {$dy-$sep}] $x1 $sep -width 2 -tags $tag
940 }
941 set btm [expr {$ty1+$dy}]
942 }
943 .c addtag $tag withtag $t
944 .c dtag $t $t
945 }
946 return [list $tag 0 0]
947}
948
949proc draw_diagram {spec} {
950 set n [llength $spec]
951 if {$n==1} {
952 return [draw_bubble $spec]
953 }
954 if {$n==0} {
955 return [draw_bubble nil]
956 }
957 set cmd [lindex $spec 0]
958 if {$cmd=="line"} {
959 return [draw_line [lrange $spec 1 end]]
960 }
961 if {$cmd=="stack"} {
962 return [draw_stack 0 [lrange $spec 1 end]]
963 }
964 if {$cmd=="indentstack"} {
965 return [draw_stack $::HSEP [lrange $spec 1 end]]
966 }
967 if {$cmd=="loop"} {
968 return [draw_loop [lindex $spec 1] [lindex $spec 2]]
969 }
970 if {$cmd=="toploop"} {
971 return [draw_toploop [lindex $spec 1] [lindex $spec 2]]
972 }
973 if {$cmd=="or"} {
974 return [draw_or [lrange $spec 1 end]]
975 }
976 if {$cmd=="opt"} {
977 set args [lrange $spec 1 end]
978 if {[llength $args]==1} {
979 return [draw_or [list nil [lindex $args 0]]]
980 } else {
981 return [draw_or [list nil "line $args"]]
982 }
983 }
984 if {$cmd=="optx"} {
985 set args [lrange $spec 1 end]
986 if {[llength $args]==1} {
987 return [draw_or [list [lindex $args 0] nil]]
988 } else {
989 return [draw_or [list "line $args" nil]]
990 }
991 }
992 if {$cmd=="tailbranch"} {
993 return [draw_or [lrange $spec 1 end]]
994 }
995 error "unknown operator: $cmd"
996}
997
998proc draw_graph {name spec} {
999 .c delete all
1000 draw_diagram "line bullet [list $spec] bullet"
1001 foreach {x0 y0 x1 y1} [.c bbox all] break
1002 .c move all [expr {2-$x0}] [expr {2-$y0}]
1003 foreach {x0 y0 x1 y1} [.c bbox all] break
1004 .c config -width $x1 -height $y1
1005 update
1006 .c postscript -file $name.ps -width [expr {$x1+2}] -height [expr {$y1+2}]
1007 global DPI
1008 exec convert -density ${DPI}x$DPI -antialias $name.ps $name.png
1009}
1010
1011proc draw_all_graphs {} {
1012 global all_graphs
1013 foreach {name graph} $all_graphs {
1014 if {[regexp {^X-} $name]} continue
1015 draw_graph $name $graph
1016 set img($name) 1
1017 set children($name) {}
1018 set parents($name) {}
1019 }
1020}