Documentation Source Text

#!/bin/wish
#
# Run this wish script to generate syntax bubble diagrams from
# text descriptions.
#





source [file join [file dirname [info script]] bubble-generator-data.tcl]

# Top-level displays
#
toplevel .bb

canvas .c -bg white
pack .c -side top -fill both -expand 1
wm withdraw .

# Draw the button bar
#
set bn 0
frame .bb.f1
................................................................................
}
incr bn
set b $side.b$bn
button $b -text Everything -command {draw_all_graphs}
pack $b -side top -fill x -expand 1

set tagcnt 0                      ;# tag counter
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


# 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}]
    set xr1 [expr {$x+$RADIUS}]
    .c create arc $xr0 $y0 $xr1 [expr {$y0+2*$RADIUS}] \
          -width 2 -start 90 -extent -90 -tags $tag -style arc
    set yr0 [expr {$y0+$RADIUS}]
    set yr1 [expr {$y1-$RADIUS}]


    if {abs($yr1-$yr0)>$RADIUS*2} {
      set half_y [expr {($yr1+$yr0)/2}]
      .c create line $xr1 $yr0 $xr1 $half_y -width 2 -tags $tag -arrow last

      .c create line $xr1 $half_y $xr1 $yr1 -width 2 -tags $tag
    } else {
      .c create line $xr1 $yr0 $xr1 $yr1 -width 2 -tags $tag
    }
    .c create arc $xr0 [expr {$y1-2*$RADIUS}] $xr1 $y1 \
          -width 2 -start 0 -extent -90 -tags $tag -style arc

  } else { 
    set r [expr {($y1-$y0)/2.0}]
    set x0 [expr {$x-$r}]
    set x1 [expr {$x+$r}]
    .c create arc $x0 $y0 $x1 $y1 \
          -width 2 -start 90 -extent -180 -tags $tag -style arc
  }
}

# Draw a left-hand turn around.  Approximately a "("
#
proc draw_left_turnback {tag x y0 y1 dir} {
  global RADIUS
  if {$y0 + 2*$RADIUS < $y1} {
    set xr0 [expr {$x-$RADIUS}]
    set xr1 [expr {$x+$RADIUS}]
    .c create arc $xr0 $y0 $xr1 [expr {$y0+2*$RADIUS}] \
          -width 2 -start 90 -extent 90 -tags $tag -style arc
    set yr0 [expr {$y0+$RADIUS}]
    set yr1 [expr {$y1-$RADIUS}]


    if {abs($yr1-$yr0)>$RADIUS*3} {
      set half_y [expr {($yr1+$yr0)/2}]
      if {$dir=="down"} {
        .c create line $xr0 $yr0 $xr0 $half_y -width 2 -tags $tag -arrow last

        .c create line $xr0 $half_y $xr0 $yr1 -width 2 -tags $tag
      } else {
        .c create line $xr0 $yr1 $xr0 $half_y -width 2 -tags $tag -arrow last

        .c create line $xr0 $half_y $xr0 $yr0 -width 2 -tags $tag
      }
    } else {
      .c create line $xr0 $yr0 $xr0 $yr1 -width 2 -tags $tag
    }

    # .c create line $xr0 $yr0 $xr0 $yr1 -width 2 -tags $tag
    .c create arc $xr0 [expr {$y1-2*$RADIUS}] $xr1 $y1 \
          -width 2 -start 180 -extent 90 -tags $tag -style arc
  } else { 
    set r [expr {($y1-$y0)/2.0}]
    set x0 [expr {$x-$r}]
    set x1 [expr {$x+$r}]
    .c create arc $x0 $y0 $x1 $y1 \
          -width 2 -start 90 -extent 180 -tags $tag -style arc
  }
}

# Draw a bubble containing $txt. 
#
proc draw_bubble {txt} {
  global tagcnt
  incr tagcnt
  set tag x$tagcnt
  if {$txt=="nil"} {
    .c create line 0 0 1 0 -width 2 -tags $tag
    return [list $tag 1 0]
  } elseif {$txt=="bullet"} {
    .c create oval 0 -3 6 3 -width 2 -tags $tag
    return [list $tag 6 0]


  }
  if {[regexp {^/[a-z]} $txt]} {
    set txt [string range $txt 1 end]
    set font $::font2
    set istoken 1
  } 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]


  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
    .c create arc [expr {$right-$rad}] $top [expr {$right+$rad}] $btm \
         -width 2 -start -90 -extent 180 -style arc -tags $tags
    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
    }
  } else {
    .c create rect $left $top $right $btm -width 2 -tags $tags

  }
  foreach {x0 y0 x1 y1} [.c bbox $tag2] break


  set width [expr {$x1-$x0}]
  .c move $tag [expr {-$x0}] 0

  # Entry is always 0 0
  # Return:  TAG EXIT_X EXIT_Y
  #
  return [list $tag $width 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
      .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
  }
  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
  }
  return [list $tag $exx $exy]
}

# Draw a sequence of terms from right to left.
#
................................................................................
    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
      .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
  }
  if {$exx==0} {
    .c create line 0 0 $sep 0 -width 2 -tags $tag
    set exx $sep
  }
  return [list $tag $exx $exy]
}

# Draw a sequence of terms from top to bottom.
#
................................................................................
        if {$ex2>$enter_x} {set enter_x $ex2}
      } else {
        set enter_x [expr {$sep*2 + $indent}]
      }
      set back_y [expr {$btm + $sep + 1}]
      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
      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
    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}]
    .c create line $bypass_x $next_bypass_y $bypass_x $mid_y \
        -width 2 -tags $tag -arrow last
    .c create line $bypass_x $mid_y $bypass_x [expr {$fwd_y-$RADIUS}] \
        -tags $tag -width 2
    .c create arc $bypass_x [expr {$fwd_y-2*$RADIUS}] \
                  [expr {$bypass_x+2*$RADIUS}] $fwd_y \
        -width 2 -start 180 -extent 90 -tags $tag -style arc
    .c create arc [expr {$exit_x-$RADIUS}] $exit_y \

                  $descender_x [expr {$exit_y+2*$RADIUS}] \
        -width 2 -start 90 -extent -90 -tags $tag -style arc

    .c create arc $descender_x [expr {$fwd_y-2*$RADIUS}] \
                  [expr {$descender_x+2*$RADIUS}] $fwd_y \
        -width 2 -start 180 -extent 90 -tags $tag -style arc

    set exit_x [expr {$exit_x+2*$RADIUS}]
    set half_x [expr {($exit_x+$indent)/2}]
    .c create line [expr {$bypass_x+$RADIUS}] $fwd_y $half_x $fwd_y \
        -width 2 -tags $tag -arrow last
    .c create line $half_x $fwd_y $exit_x $fwd_y \
        -width 2 -tags $tag
    .c create line $descender_x [expr {$exit_y+$RADIUS}] \
                   $descender_x [expr {$fwd_y-$RADIUS}] \
        -width 2 -tags $tag -arrow last
    set exit_y $fwd_y
  }
  set width [lindex [.c bbox $tag] 2]
  return [list $tag $exit_x $exit_y]
}

proc draw_loop {forward back} {
................................................................................
  set by1 [expr {$dy+$by1}]

  if {$fw>$bw} {
    if {$fexx<$fw && $fexx>=$bw} {
      set dx [expr {($fexx-$bw)/2}]
      .c move $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
      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
    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
  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
  return [list $tag $exit_x $fexy]
}

proc draw_toploop {forward back} {
  global tagcnt
  incr tagcnt
  set tag x$tagcnt
................................................................................
  set by0 [expr {$dy+$by0}]
  set by1 [expr {$dy+$by1}]

  if {$fw>$bw} {
    set dx [expr {($fw-$bw)/2}]
    .c move $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
    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
  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]
}

proc draw_or {lx} {
  global tagcnt
  incr tagcnt
  set tag x$tagcnt
................................................................................
    set w [expr {$x1-$x0}]
    if {$i>0} {set w [expr {$w+20}]}  ;# extra space for arrowheads
    if {$w>$mxw} {set mxw $w}
    incr i
  }

  set x0 0                        ;# entry x
  set x1 $sep                     ;# decender 
  set x2 [expr {$sep*2}]          ;# start of choice
  set xc [expr {$mxw/2}]          ;# center point
  set x3 [expr {$mxw+$x2}]        ;# end of choice
  set x4 [expr {$x3+$sep}]        ;# accender
  set x5 [expr {$x4+$sep}]        ;# exit x

  for {set i 0} {$i<$n} {incr i} {
................................................................................
    set dx [expr {($mxw-$w)/2 + $x2}]
    if {$w>10 && $dx>$x2+10} {set dx [expr {$x2+10}]}
    .c move $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
      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}]
      .c create arc $x1 $y1 [expr {$x1+2*$sep}] $dy \
          -width 2 -start 180 -extent 90 -style arc -tags $tag

      set y2 [expr {$texy-2*$sep}]
      .c create arc [expr {$x3-$sep}] $y2 $x4 $texy \
          -width 2 -start 270 -extent 90 -style arc -tags $tag


      if {$i==$n-1} {
        .c create arc $x4 $exy [expr {$x4+2*$sep}] [expr {$exy+2*$sep}] \
           -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
  }
  return [list $tag $x5 $exy]   
}

proc draw_tail_branch {lx} {
  global tagcnt
  incr tagcnt
  set tag x$tagcnt
  set sep $::VSEP
................................................................................
  set i 0
  foreach term $lx {
    set m($i) [set mx [draw_diagram $term]]
    incr i
  }

  set x0 0                        ;# entry x
  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
    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
      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
  }
  return [list $tag 0 0]
................................................................................
  if {$cmd=="tailbranch"} {
    # return [draw_tail_branch [lrange $spec 1 end]]
    return [draw_or [lrange $spec 1 end]]
  }
  error "unknown operator: $cmd"
}

















































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}]
  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}]
  global DPI
  .c delete bgrect
  exec convert -density ${DPI}x$DPI -antialias $name.ps $name.gif
  if {$do_xv} {

    if {[catch {exec xv $name.gif &}]} {








      exec display $name.gif &
    }

  }
}

proc draw_all_graphs {} {
  global all_graphs

  set f [open all.html w]
  foreach {name graph} $all_graphs {
    if {[regexp {^X-} $name]} continue
    puts $f "<h3>$name:</h3>"
    puts $f "<img src=\"$name.gif\">"
    draw_graph $name $graph 0
    set img($name) 1
    set children($name) {}
    set parents($name) {}
  }
  close $f
  set order {}
  foreach {name graph} $all_graphs {
................................................................................
  foreach name [lsort [array names img]] {
    set cx [lsort $children($name)]
    set px [lsort $parents($name)]
    puts $f [list set syntax_linkage($name) [list $cx $px]]
  }
  puts $f [list set syntax_order $order]
  close $f

  wm withdraw .
}

proc walk_graph_extract_names {graph varname} {
  upvar 1 $varname v
  foreach x $graph {
    set n [llength $x]

#!/bin/wish
#
# Run this wish script to generate syntax bubble diagrams from
# text descriptions.
#

option add *busyCursor watch

package require tkpath

source [file join [file dirname [info script]] bubble-generator-data.tcl]

# Top-level displays
#
toplevel .bb
wm protocol .bb WM_DELETE_WINDOW {destroy .}
tkp::canvas .c -bg white
pack .c -side top -fill both -expand 1
wm withdraw .

# Draw the button bar
#
set bn 0
frame .bb.f1
................................................................................
}
incr bn
set b $side.b$bn
button $b -text Everything -command {draw_all_graphs}
pack $b -side top -fill x -expand 1

set tagcnt 0                      ;# tag counter
set font1 {Helvetica 13 bold}     ;# default token font
set font2 {Helvetica 11 bold}     ;# default variable font
set RADIUS 9                      ;# default turn radius
set HSEP 15                       ;# horizontal separation
set VSEP 7                        ;# vertical separation



# 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}]
    set xr1 [expr {$x+$RADIUS}]


    set yr0 [expr {$y0+$RADIUS}]
    set yr1 [expr {$y1-$RADIUS}]
    .c create path "M $x $y0 A $RADIUS $RADIUS 0 0 1 $xr1 $yr0" \
       -strokewidth 2 -tags $tag
    if {abs($yr1-$yr0)>$RADIUS*2} {
      set half_y [expr {($yr1+$yr0)/2}]
      .c create pline $xr1 $yr0 $xr1 $half_y -strokewidth 2 -tags $tag \
        -endarrow on
      .c create pline $xr1 $half_y $xr1 $yr1 -strokewidth 2 -tags $tag
    } else {
      .c create pline $xr1 $yr0 $xr1 $yr1 -strokewidth 2 -tags $tag
    }

    .c create path "M $xr1 $yr1 A $RADIUS $RADIUS 0 0 1 $x $y1" \
      -strokewidth 2 -tags $tag
  } else {
    set r [expr {($y1-$y0)/2.0}]

    .c create path "M $x $y0 A $r $r 0 0 0 $x $y1" \
      -strokewidth 2 -tags $tag

  }
}

# Draw a left-hand turn around.  Approximately a "("
#
proc draw_left_turnback {tag x y0 y1 dir} {
  global RADIUS
  if {$y0 + 2*$RADIUS < $y1} {
    set xr0 [expr {$x-$RADIUS}]
    set xr1 [expr {$x+$RADIUS}]


    set yr0 [expr {$y0+$RADIUS}]
    set yr1 [expr {$y1-$RADIUS}]
    .c create path "M $x $y0 A $RADIUS $RADIUS 0 0 0 $xr0 $yr0" \
      -strokewidth 2 -tags $tag
    if {abs($yr1-$yr0)>$RADIUS*2} {
      set half_y [expr {($yr1+$yr0)/2}]
      if {$dir=="down"} {
        .c create pline $xr0 $yr0 $xr0 $half_y -strokewidth 2 -tags $tag \
          -endarrow on
        .c create pline $xr0 $half_y $xr0 $yr1 -strokewidth 2 -tags $tag
      } else {
        .c create pline $xr0 $yr1 $xr0 $half_y -strokewidth 2 -tags $tag \
          -endarrow on
        .c create pline $xr0 $half_y $xr0 $yr0 -strokewidth 2 -tags $tag
      }
    } else {
      .c create pline $xr0 $yr0 $xr0 $yr1 -strokewidth 2 -tags $tag
    }
    .c create path "M $xr0 $yr1 A $RADIUS $RADIUS 0 0 0 $x $y1" \
      -strokewidth 2 -tags $tag


  } else {
    set r [expr {($y1-$y0)/2.0}]

    .c create path "M $x $y0 A $r $r 0 0 1 $x $y1" \
      -strokewidth 2 -tags $tag

  }
}

# Draw a bubble containing $txt.
#
proc draw_bubble {txt} {
  global tagcnt
  incr tagcnt
  set tag x$tagcnt
  if {$txt eq "nil"} {
    .c create pline 0 0 1 0 -strokewidth 2 -tags $tag
    return [list $tag 1 0]
  } elseif {$txt eq "bullet"} {
    .c create circle 2 0 -r 3 -strokewidth 2 -tags $tag
    return [list $tag 6 0]
  } elseif {$txt eq "--"} {
    set txt "- -"
  }
  if {[regexp {^/[a-z]} $txt]} {
    set txt [string range $txt 1 end]
    set font $::font2
    set istoken 1
  } elseif {[regexp {^[a-z]} $txt]} {
    set font $::font2
    set istoken 0
  } else {
    set font $::font1
    set istoken 1
  }
  foreach {ffam fsize fweight} $font break
  set id1 [.c create ptext 0 0 -text $txt -fontfamily $ffam \
    -fontsize $fsize -fontweight $fweight -textanchor c -tags $tag]
  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+2}]
  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}]




  set tag2 x$tagcnt-box
  set tags [list $tag $tag2]
  if {$istoken} {
    set w [expr {$right-$left}]
    if {$w>1.3*$h} {
      .c create prect $left $top $right $btm -rx $rad -strokewidth 2 \
        -tags $tags -fill gray80 -fillopacity 0.1
    } else {
      set xx [expr {($x0+$x1)/2}]
      set yy [expr {($y0+$y1)/2}]
      .c create circle $xx $yy -r [expr {2+$h/2}] -strokewidth 2 \
        -tags $tags -fill gray80 -fillopacity 0.1


    }
  } else {
    .c create prect $left $top $right $btm -strokewidth 2 \
      -tags $tags -fill gray80 -fillopacity 0.1
  }
  foreach {x0 y0 x1 y1} [.c bbox $tag2] break
  set x0 [expr {$x0+3}]
  set x1 [expr {$x1-3}]
  set width [expr {$x1-$x0}]
  .c move $tag [expr {-$x0}] 0

  # Entry is always 0 0
  # Return:  TAG EXIT_X EXIT_Y
  #
  return [list $tag $width 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
      .c create pline [expr {$exx-1}] $exy $xn $exy \
        -tags $tag -strokewidth 2 -endarrow on
      set exx [expr {$xn+$texx}]
    } else {
      set exx $texx
    }
    set exy $texy
    .c addtag $tag withtag $t
    .c dtag $t $t
  }
  if {$exx==0} {
    set exx [expr {$sep*2}]
    .c create pline 0 0 $sep 0 -strokewidth 2 -tags $tag -endarrow on
    .c create pline $sep 0 $exx 0 -strokewidth 2 -tags $tag
    set exx $sep
  }
  return [list $tag $exx $exy]
}

# Draw a sequence of terms from right to left.
#
................................................................................
    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
      .c create pline $exx $exy $xn $exy -tags $tag -strokewidth 2 \
        -startarrow on
      set exx [expr {$xn+$texx}]
    } else {
      set exx $texx
    }
    set exy $texy
    .c addtag $tag withtag $t
    .c dtag $t $t
  }
  if {$exx==0} {
    .c create pline 0 0 $sep 0 -strokewidth 2 -tags $tag
    set exx $sep
  }
  return [list $tag $exx $exy]
}

# Draw a sequence of terms from top to bottom.
#
................................................................................
        if {$ex2>$enter_x} {set enter_x $ex2}
      } else {
        set enter_x [expr {$sep*2 + $indent}]
      }
      set back_y [expr {$btm + $sep + 1}]
      if {$bypass_y>0} {
         set mid_y [expr {($bypass_y+$RADIUS+$back_y)/2}]
         .c create pline $bypass_x $bypass_y $bypass_x $mid_y \
           -strokewidth 2 -tags $tag -endarrow on
         .c create pline $bypass_x $mid_y $bypass_x [expr {$back_y+$RADIUS}] \
           -tags $tag -strokewidth 2
      }
      .c move $t $enter_x $enter_y
      set e2 [expr {$exit_x + $sep}]
      .c create pline $exit_x $exit_y $e2 $exit_y \
        -strokewidth 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 pline $e2 $back_y $emid $back_y -strokewidth 2 -tags $tag \
        -endarrow on
      .c create pline $emid $back_y $e3 $back_y -strokewidth 2 -tags $tag

      set r2 [expr {($enter_y - $back_y)/2.0}]
      draw_left_turnback $tag $e3 $back_y $enter_y down
      .c create pline $e3 $enter_y $enter_x $enter_y -endarrow on \
        -strokewidth 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
    set btm [lindex [.c bbox $tag] 3]
    incr i
  }
  if {$bypass} {
    set r $RADIUS
    set fwd_y [expr {$btm + $sep + 1}]
    set mid_y [expr {($next_bypass_y+$r+$fwd_y)/2}]
    set descender_x [expr {$exit_x+$r}]
    .c create pline $bypass_x $next_bypass_y $bypass_x $mid_y \
      -strokewidth 2 -tags $tag -endarrow on
    .c create pline $bypass_x $mid_y $bypass_x [expr {$fwd_y-$r}] \
      -tags $tag -strokewidth 2
    set path "M $bypass_x [expr {$fwd_y-$r}]"
    append path " A $r $r 0 0 0 [expr {$bypass_x+$r}] $fwd_y"

    .c create path $path -strokewidth 2 -tags $tag
    set path "M $exit_x $exit_y"
    append path " A $r $r 0 0 1 $descender_x [expr {$exit_y+$r}]"

    .c create path $path -strokewidth 2 -tags $tag
    set path "M $descender_x [expr {$fwd_y-$r}]"
    append path " A $r $r 0 0 0 [expr {$descender_x+$r}] $fwd_y"

    .c create path $path -strokewidth 2 -tags $tag
    set exit_x [expr {$exit_x+2*$r}]
    set half_x [expr {($exit_x+$indent)/2}]
    .c create pline [expr {$bypass_x+$r}] $fwd_y $half_x $fwd_y \
      -strokewidth 2 -tags $tag -endarrow on
    .c create pline $half_x $fwd_y $exit_x $fwd_y \
      -strokewidth 2 -tags $tag
    .c create pline $descender_x [expr {$exit_y+$r}] \
                   $descender_x [expr {$fwd_y-$r}] \
      -strokewidth 2 -tags $tag -endarrow on
    set exit_y $fwd_y
  }
  set width [lindex [.c bbox $tag] 2]
  return [list $tag $exit_x $exit_y]
}

proc draw_loop {forward back} {
................................................................................
  set by1 [expr {$dy+$by1}]

  if {$fw>$bw} {
    if {$fexx<$fw && $fexx>=$bw} {
      set dx [expr {($fexx-$bw)/2}]
      .c move $bt $dx 0
      set bexx [expr {$dx+$bexx}]
      .c create pline 0 $biny $dx $biny -strokewidth 2 -tags $bt
      .c create pline $bexx $bexy $fexx $bexy -strokewidth 2 -tags $bt \
        -startarrow on
      set mxx $fexx
    } else {
      set dx [expr {($fw-$bw)/2}]
      .c move $bt $dx 0
      set bexx [expr {$dx+$bexx}]
      .c create pline 0 $biny $dx $biny -strokewidth 2 -tags $bt
      .c create pline $bexx $bexy $fx1 $bexy -strokewidth 2 -tags $bt \
        -startarrow on
      set mxx $fexx
    }
  } elseif {$bw>$fw} {
    set dx [expr {($bw-$fw)/2}]
    .c move $ft $dx 0
    set fexx [expr {$dx+$fexx}]
    .c create pline 0 0 $dx $fexy -strokewidth 2 -tags $ft -endarrow on
    .c create pline $fexx $fexy $bx1 $fexy -strokewidth 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
  set mxx [expr {$mxx+$sep}]
  .c create pline 0 0 $sep 0 -strokewidth 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 pline $mxx $fexy $exit_x $fexy -strokewidth 2 -tags $tag
  return [list $tag $exit_x $fexy]
}

proc draw_toploop {forward back} {
  global tagcnt
  incr tagcnt
  set tag x$tagcnt
................................................................................
  set by0 [expr {$dy+$by0}]
  set by1 [expr {$dy+$by1}]

  if {$fw>$bw} {
    set dx [expr {($fw-$bw)/2}]
    .c move $bt $dx 0
    set bexx [expr {$dx+$bexx}]
    .c create pline 0 $biny $dx $biny -strokewidth 2 -tags $bt
    .c create pline $bexx $bexy $fx1 $bexy -strokewidth 2 -tags $bt \
      -startarrow on
    set mxx $fexx
  } elseif {$bw>$fw} {
    set dx [expr {($bw-$fw)/2}]
    .c move $ft $dx 0
    set fexx [expr {$dx+$fexx}]
    .c create pline 0 0 $dx $fexy -strokewidth 2 -tags $ft
    .c create pline $fexx $fexy $bx1 $fexy -strokewidth 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
  set mxx [expr {$mxx+$sep}]
  .c create pline 0 0 $sep 0 -strokewidth 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 pline $mxx $fexy $x1 $fexy -strokewidth 2 -tags $tag
  return [list $tag $x1 $fexy]
}

proc draw_or {lx} {
  global tagcnt
  incr tagcnt
  set tag x$tagcnt
................................................................................
    set w [expr {$x1-$x0}]
    if {$i>0} {set w [expr {$w+20}]}  ;# extra space for arrowheads
    if {$w>$mxw} {set mxw $w}
    incr i
  }

  set x0 0                        ;# entry x
  set x1 $sep                     ;# decender
  set x2 [expr {$sep*2}]          ;# start of choice
  set xc [expr {$mxw/2}]          ;# center point
  set x3 [expr {$mxw+$x2}]        ;# end of choice
  set x4 [expr {$x3+$sep}]        ;# accender
  set x5 [expr {$x4+$sep}]        ;# exit x

  for {set i 0} {$i<$n} {incr i} {
................................................................................
    set dx [expr {($mxw-$w)/2 + $x2}]
    if {$w>10 && $dx>$x2+10} {set dx [expr {$x2+10}]}
    .c move $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 {-endarrow on}} {set ax {}}
      .c create pline 0 0 $dx 0 -strokewidth 2 -tags $tag {*}$ax
      .c create pline $texx $texy [expr {$x5+1}] $texy -strokewidth 2 \
        -tags $tag
      set exy $texy

      .c create path "M 0 0 A $sep $sep 0 0 1 $sep $sep" \
        -strokewidth 2 -tags $tag
      set btm $ty1
    } else {
      set dy [expr {$btm - $ty0 + $vsep}]
      if {$dy<2*$sep} {set dy [expr {2*$sep}]}
      .c move $t 0 $dy
      set texy [expr {$texy+$dy}]
      if {$dx>$x2} {
        .c create pline $x2 $dy $dx $dy -strokewidth 2 -tags $tag -endarrow on
        if {$dx<$xc-2} {set ax {-endarrow on}} {set ax {}}
        .c create pline $texx $texy $x3 $texy -strokewidth 2 -tags $tag {*}$ax
      }
      set y1 [expr {$dy-2*$sep}]
      .c create path \
        "M $x1 [expr {$y1+$sep}] A $sep $sep 0 0 0 [expr {$x1+$sep}] $dy" \
        -strokewidth 2 -tags $tag
      set y2 [expr {$texy-2*$sep}]

      .c create path \
        "M $x3 [expr {$y2+2*$sep}] A $sep $sep 0 0 0 $x4 [expr {$y2+$sep}]" \
        -strokewidth 2 -tags $tag
      if {$i==$n-1} {


        .c create path \
          "M $x4 [expr {$exy+$sep}] A $sep $sep 0 0 1 [expr {$x4+$sep}] $exy" \
          -strokewidth 2 -tags $tag
        .c create pline $x1 [expr {$dy-$sep}] $x1 $sep -strokewidth 2 -tags $tag
        .c create pline $x4 [expr {$texy-$sep}] $x4 [expr {$exy+$sep}] \
          -strokewidth 2 -tags $tag
      }
      set btm [expr {$ty1+$dy}]
    }
    .c addtag $tag withtag $t
    .c dtag $t $t
  }
  return [list $tag $x5 $exy]
}

proc draw_tail_branch {lx} {
  global tagcnt
  incr tagcnt
  set tag x$tagcnt
  set sep $::VSEP
................................................................................
  set i 0
  foreach term $lx {
    set m($i) [set mx [draw_diagram $term]]
    incr i
  }

  set x0 0                        ;# entry x
  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
    foreach {tx0 ty0 tx1 ty1} [.c bbox $t] break
    if {$i==0} {
      .c create pline 0 0 $dx 0 -strokewidth 2 -tags $tag -endarrow on
      .c create path "M 0 0 A $sep $sep 0 0 1 $sep $sep" \
        -strokewidth 2 -tags $tag
      set btm $ty1
    } else {
      set dy [expr {$btm - $ty0 + $vsep}]
      if {$dy<2*$sep} {set dy [expr {2*$sep}]}
      .c move $t 0 $dy
      if {$dx>$x2} {
        .c create pline $x2 $dy $dx $dy -strokewidth 2 -tags $tag -endarrow on
      }
      set y1 [expr {$dy-2*$sep}]
      set path "M $x1 [expr {$y1+$sep}]"
      append path " A $sep $sep 0 0 0 [expr {$x1+$sep}] $dy"
      .c create path $path -strokewidth 2 -tags $tag
      if {$i==$n-1} {
        .c create pline $x1 [expr {$dy-$sep}] $x1 $sep -strokewidth 2 \
          -tags $tag
      }
      set btm [expr {$ty1+$dy}]
    }
    .c addtag $tag withtag $t
    .c dtag $t $t
  }
  return [list $tag 0 0]
................................................................................
  if {$cmd=="tailbranch"} {
    # return [draw_tail_branch [lrange $spec 1 end]]
    return [draw_or [lrange $spec 1 end]]
  }
  error "unknown operator: $cmd"
}

proc copy_to_surface {surf} {
  foreach id [.c find withtag all] {
    switch -- [.c type $id] {
      pline {
	# tricky: arrow heads adjust coords, but we want the original ones!
        set sa [.c itemcget $id -startarrow]
        set ea [.c itemcget $id -endarrow]
        .c itemconfig $id -startarrow off -endarrow off
	$surf create pline [.c coords $id] \
	  -strokewidth [.c itemcget $id -strokewidth] \
          -stroke [.c itemcget $id -stroke] \
	  -startarrow $sa -endarrow $ea
        .c itemconfig $id -startarrow $sa -endarrow $ea
      }
      path {
	$surf create path [.c coords $id] \
	  -strokewidth [.c itemcget $id -strokewidth] \
	  -stroke [.c itemcget $id -stroke]
      }
      circle {
	$surf create circle [.c coords $id] \
	  -r [.c itemcget $id -r] \
	  -strokewidth [.c itemcget $id -strokewidth] \
	  -stroke [.c itemcget $id -stroke]
      }
      prect {
	$surf create prect [.c coords $id] \
	  -rx [.c itemcget $id -rx] \
	  -ry [.c itemcget $id -ry] \
	  -strokewidth [.c itemcget $id -strokewidth] \
	  -stroke [.c itemcget $id -stroke] \
	  -fillopacity [.c itemcget $id -fillopacity] \
	  -fill [.c itemcget $id -fill]
      }
      ptext {
	$surf create ptext [.c coords $id] \
	  -strokewidth [.c itemcget $id -strokewidth] \
	  -stroke [.c itemcget $id -stroke] \
	  -fontfamily [.c itemcget $id -fontfamily] \
	  -fontsize [.c itemcget $id -fontsize] \
	  -text [.c itemcget $id -text] \
	  -textanchor [.c itemcget $id -textanchor] \
	  -fontweight [.c itemcget $id -fontweight]
      }
    }
  }
}

proc draw_graph {name spec {do_surf 0}} {
  .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}]
  foreach {x0 y0 x1 y1} [.c bbox all] break
  .c create prect -100 -100 [expr {$x1+100}] [expr {$y1+100}] \
     -fill white -stroke white -tags bgrect
  .c lower bgrect
  .c config -width $x1 -height $y1
  .c delete bgrect
  catch {tk busy hold .}
  update


  catch {tk busy forget .}

  if {$do_surf} {
    set ws [expr {$x1+2}]
    set hs [expr {$y1+2}]
    set surf [tkp::surface new $ws $hs]
    $surf erase 0 0 $ws $hs
    $surf create prect 0 0 $ws $hs -fill white
    copy_to_surface $surf
    set img [image create photo]
    $surf copy $img
    $surf destroy
    # $img write $name.png -format png
    $img write $name.gif -format gif

    image delete $img
  }
}

proc draw_all_graphs {} {
  global all_graphs
  catch {tk busy hold .bb}
  set f [open all.html w]
  foreach {name graph} $all_graphs {
    if {[regexp {^X-} $name]} continue
    puts $f "<h3>$name:</h3>"
    puts $f "<img src=\"$name.gif\">"
    draw_graph $name $graph 1
    set img($name) 1
    set children($name) {}
    set parents($name) {}
  }
  close $f
  set order {}
  foreach {name graph} $all_graphs {
................................................................................
  foreach name [lsort [array names img]] {
    set cx [lsort $children($name)]
    set px [lsort $parents($name)]
    puts $f [list set syntax_linkage($name) [list $cx $px]]
  }
  puts $f [list set syntax_order $order]
  close $f
  catch {tk busy forget .bb}
  wm withdraw .
}

proc walk_graph_extract_names {graph varname} {
  upvar 1 $varname v
  foreach x $graph {
    set n [llength $x]