branch_diagram.tcl

TKCVS Source Code For CVS。

        gen_log:log T "ENTER ($x $y $box_width $height $revision)"
        # Draw the list of tags
        set tx [expr {$x - $curr(tspcb)}]
        set ty $y
        set revbtag $revbtags($branch)
        foreach tag $tlist($revision) {
          gen_log:log D "$revision: tag $tag"
          if {[string match "${fromprefix}_*" $tag]} {
            lappend fromtags $tag
            regsub {.*_(.*$)} $tag {\1} tagend
            gen_log:log D "  $tag is a FROM TAG"
            gen_log:log D "  will need a TO TAG ${toprefix}_${revbtag}_$tagend"
            set match($tag) ${toprefix}_${revbtag}_$tagend
            set boxwidth($tag) $box_width
            set xy($tag) [list $x [expr {$y - ($box_height / 4)}]]
          }
          if {[string match "${toprefix}_*" $tag]} {
            lappend totags $tag
            regsub {.*_(.*$)} $tag {\1} tagend
            gen_log:log D "  $tag is a TO TAG"
            gen_log:log D "  will need a FROM TAG ${toprefix}_${revbtag}_$tagend"
            set match($tag) ${toprefix}_${revbtag}_$tagend
            set boxwidth($tag) $box_width
            set xy($tag) [list $x [expr {$y - ($box_height / 4)}]]
          }
          if {$opt(show_tags)} {
            set my_font $font_norm
            set tagcolour black
            set taglist {}
            if {$tag == {more...}} {
              set my_font $font_bold
              set taglist [list R$revision tag active]
            } elseif {[info exists cvscfg(tagcolour,$tag)]} {
              set tagcolour $cvscfg(tagcolour,$tag)
            }
            $logcanvas.canvas create text \
              $tx $ty \
              -text $tag \
              -anchor se -fill $tagcolour \
              -font $my_font \
              -tags $taglist
            incr ty -$font_norm_h
          }
        }
        # draw the box...
        set tx [expr {$x + $box_width}]
        set ty [expr {$y - $box_height}]
        $logcanvas.canvas create rectangle \
          $x $y $tx $ty \
          -width $curr(width) -fill gray90 \
          -tags [list box R$revision rect$revision active]
        # ...and add the contents
        if {[info exists revstate($revision)]} {
          if {$revstate($revision) == {dead}} {
            $logcanvas.canvas create line \
              $x $y $tx $ty -fill red -width $curr(width)
            $logcanvas.canvas create line \
              $tx $y $x $ty -fill red -width $curr(width)
          }
        }
        set tx [expr {$x + $box_width/2}]
        set ty [expr {$y - $curr(pady)}]
        foreach s [subst $rev_info] {
          $logcanvas.canvas create text \
            $tx $ty \
            -text $s \
            -anchor s \
            -font $font_norm \
            -tags [list R$revision box active]
          incr ty -$font_norm_h
        }
        #gen_log:log T "LEAVE"
        return
      }

      proc DrawBranch { x y root_rev branch } {
        variable logcanvas
        variable opt
        variable curr
        variable box_height
        variable revkind
        variable branchrevs
        variable revbranches

        #gen_log:log T "ENTER ($x $y $root_rev $branch)"
        gen_log:log D "Drawing branch \"$branch\" rooted at \"$root_rev\""
        # What revisions to show on this branch?
        if {![info exists branchrevs($branch)]} {set branchrevs($branch) {}}
        if {$branchrevs($branch) == {}} {
          set revlist {}
        } else {
          # Always have the head revision
          set revlist [lindex $branchrevs($branch) 0]
          foreach r [lrange $branchrevs($branch) 1 end-1] {
            if {![info exists revbranches($r)]} {set revbranches($r) {}}
            if {$opt(show_inter_revs) || $opt(show_empty_branches) \
                && $revbranches($r) != {}} {
              lappend revlist $r
            } else {
              # Only if there are non-empty branches off this revision
              foreach b $revbranches($r) {
                if {![info exists branchrevs($b)]} {set branchrevs($b) {}}
                if {$branchrevs($b) != {}} {
                  lappend revlist $r
                  break
                }
              }
            }
          }
          if {[llength $branchrevs($branch)] > 1} {
            # Always have the first revision on a branch
            lappend revlist [lindex $branchrevs($branch) end]
          }
        }

        # Work out width and height of this limb, saving sizes of revisions
        set tag_width 0
        set rdata {}
        if {$branch == {current}} {
          set rtw 0
          foreach {box_width root_height} [CalcCurrent $branch] { break }
        } else {
          foreach {rtw box_width root_height} [CalcRoot $branch] { break }
        }
        if {$rtw > $tag_width} {
          set tag_width $rtw
        }
        set height [expr {$root_height + $curr(spcy)}]
        foreach revision $revlist {
          if {$revision == {current}} {
            set rtw 0
            foreach {rbw rh} [CalcCurrent $revision] { break }
          } else {
            foreach {rtw rbw rh} [CalcRevision $revision] { break }
          }
          lappend rdata $rtw $rh
          if {$rtw > $tag_width} {
            set tag_width $rtw
          }
          if {$rbw > $box_width} {
            set box_width $rbw
          }
          incr height $curr(spcy)
          incr height $rh
        }
        # Position branch.
        # Look for overlap horizontally
        while {1} {
          $logcanvas.canvas addtag ol_x overlapping \
            [expr {$x - $curr(spcx)}] [expr {$y - $height + $curr(yfudge)}] \
            [expr {$x + $tag_width + $box_width}] $y
            set bbox [$logcanvas.canvas bbox ol_x]
          $logcanvas.canvas dtag ol_x
          if {$bbox == {}} {
          break
        }
        gen_log:log D "horizontal overlap with $bbox"
          # Move branch to rightmost point of overlapped objects plus some space
          # N.B. +1 because exactly equal counts as an overlap
          set x [expr {[lindex $bbox 2] + $curr(spcx) + 1}]
        }
        # Look for overlap vertically
        $logcanvas.canvas addtag ol_y overlapping \
          $x [expr {$y - $height}] \
          [expr {$x + $tag_width + $box_width}] [expr {$y - $height +\
               $curr(yfudge)}]
        set bbox [$logcanvas.canvas bbox ol_y]
        $logcanvas.canvas dtag ol_y
        if {$bbox != {}} {
          # Move down to make space
          gen_log:log D "vertical overlap with $bbox"
          incr y [expr {[lindex $bbox 3] - ($y - $height)}]
        }
        # Position to top of branch
        incr x $tag_width
        incr y -$height
        # Draw the branch
        set midx [expr {$x + $box_width/2}]
        set last_y {}
        foreach revision $revlist {rtag_width rheight} $rdata {
          incr y $curr(spcy)
          incr y $rheight
          # For each branch off this revision, draw it to the right of this
          # revision box and a little above the centre line of this box.
          set x2 [expr {$x +$box_width + $curr(spcx)}]
          set y2 [expr {$y - $box_height/2 - $curr(boff)}]
          set brevs {}
          set bxys {}
          if {[info exists revbranches($revision)]} {
            foreach r2 $revbranches($revision) {
              # Do we display the branch if it is empty?
              # If it's the you-are-here, we do anyway
              if {![info exists branchrevs($r2)] } { set branchrevs($r2) {} }
              if {$branchrevs($r2) == {} && $r2 != {current} && !\
                  $opt(show_empty_branches)} {
                continue
              }
              lappend brevs $r2
              foreach {lx y2 lbw rh lly} [DrawBranch $x2 $y2 $revision $r2] {
                lappend bxys $lx $lbw $rh $lly
                break
              }
              set x2 [expr {$lx + $lbw + $curr(spcx)}]
            }
          }

          # y2 may have changed to accomodate a long branch. If so we need
          # to figure out what our y should be
          set y [expr {$y2 + $box_height/2 + $curr(boff)}]
          set rx [expr {$x + $box_width}]
          set ry [expr {$y - $box_height/2}]
          set by [expr {$ry - $curr(boff)}]
          # If it has brevs, it's the root of a branch

          foreach b $brevs {bx bw rh ly} $bxys {
            set mx [expr {$bx + $bw/2}]
            if {$ly != {}} {
              $logcanvas.canvas create line \
                $mx $ly $mx [expr {$by - $rh}] \
                -arrow first -arrowshape $curr(arrowshape) -width $curr(width)
            }
            if {$b == {current}} {
              DrawCurrent $bx $by $bw $rh $revision
            } else {
              set last_rev [lindex $branchrevs($b) 0]
              if {$last_rev == {current}} {
                set last_rev [lindex $branchrevs($b) 1]
              }
              DrawRoot $bx $by $bw $rh $revision $b
            }
            $logcanvas.canvas lower [ \
              $logcanvas.canvas create line \
                $rx $ry $mx $ry $mx $by \
                -arrow last -arrowshape $curr(arrowshape) -width $curr(width) \
                -fill blue
            ]
            if {$opt(update_drawing) < 1} {
              UpdateBndBox
            }
          }

          if {$last_y != {}} {
            $logcanvas.canvas create line \
              $midx $last_y $midx [expr {$y - $box_height}] \
              -arrow first -arrowshape $curr(arrowshape) -width $curr(width)
          }
          if {$revision == {current}} {
            DrawCurrent $x $y $box_width $rheight $revision
          } else {
            DrawRevision $x $y $box_width $rheight $revision
          }
          if {$opt(update_drawing) < 1} {
            UpdateBndBox
          }
          set last_y $y
          set last_rev $revision
        }
        if {$opt(update_drawing) < 2} {
          UpdateBndBox
        }
        return [list $x [expr {$y + $root_height + $curr(spcy)}] \
        $box_width $root_height $last_y]
      }
  
      proc UpdateBndBox {} {
        variable logcanvas
        variable font_bold
        variable view_xoff
        variable view_yoff
        variable curr_x
        variable curr_y

        #gen_log:log T "ENTER"

        foreach {x1 y1 x2 y2} [$logcanvas.canvas bbox all] { break }
        $logcanvas.canvas configure \
          -scrollregion [list \
            [expr {$x1 - 5}] [expr {$y1 - 5}] \
            [expr {$x2 + 5}] [expr {$y2 + 5}]
          ]

        if {[info exists curr_x]} {
          set canv_width [$logcanvas.canvas cget -width]
          set canv_height [$logcanvas.canvas cget -height]
          set bbox [$logcanvas.canvas bbox all]
          set llx [lindex $bbox 0]
          set lly [lindex $bbox 1]
          set urx [lindex $bbox 2]
          set ury [lindex $bbox 3]
          set bbox_width [expr {$urx - $llx}]
          set bbox_height [expr {$ury - $lly}]
          gen_log:log D "diagram size: $bbox_width x $bbox_height"
          gen_log:log D "canvas size:  $canv_width x $canv_height"
          set canv_bot [expr {$ury - $canv_height}]
          set view_y [expr {$canv_bot - $ury}]
          gen_log:log D "bbox:         $bbox"
          gen_log:log D "canvas view:  $llx $canv_bot  $canv_width $view_y"
          gen_log:log D "curr x & y:  $curr_x, $curr_y"
          gen_log:log D "x: (curr_x $curr_x) >? (canv_width $canv_width)"
          if {$curr_x > $canv_width} {
            set dist_x [expr {$curr_x - $canv_width/2}]
            set dist_x [expr {$dist_x - 3 * [font measure $font_bold \
                     -displayof $logcanvas.canvas {You are}]}]
            gen_log:log D "positioning x:  new x $dist_x"
          } else {
            gen_log:log D "not re-positioning x"
            set dist_x 0
          }
          gen_log:log D "y: (curr_y $curr_y) <? (view_y $view_y)"
          if {$curr_y < $view_y} {
            set dist_y [expr {$curr_y - $lly}]
            #gen_log:log D " $curr_y is $dist_y pixels from the top"
            set dist_y [expr {$dist_y - 2 * [image height Man]}]
            gen_log:log D "positioning y:  new y $dist_y"
          } else {
            gen_log:log D "not re-positioning y"
            set dist_y 0
          }
          # Multiplying by 1.0 keeps it from being rounded to an int
          set x_proportion [expr {($dist_x * 1.0) / ($bbox_width * 1.0)}]
          set view_xoff $x_proportion
          set y_proportion [expr {($dist_y * 1.0) / ($bbox_height * 1.0)}]
          set view_yoff $y_proportion