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