- return $xt
-}
-
-proc notecrossings {id lo hi corner} {
- global olddisplist crossings cornercrossings
-
- for {set i $lo} {[incr i] < $hi} {} {
- set p [lindex $olddisplist $i]
- if {$p == {}} continue
- if {$i == $corner} {
- if {![info exists cornercrossings($id)]
- || [lsearch -exact $cornercrossings($id) $p] < 0} {
- lappend cornercrossings($id) $p
- }
- if {![info exists cornercrossings($p)]
- || [lsearch -exact $cornercrossings($p) $id] < 0} {
- lappend cornercrossings($p) $id
- }
- } else {
- if {![info exists crossings($id)]
- || [lsearch -exact $crossings($id) $p] < 0} {
- lappend crossings($id) $p
- }
- if {![info exists crossings($p)]
- || [lsearch -exact $crossings($p) $id] < 0} {
- lappend crossings($p) $id
- }
- }
- }
-}
-
-proc xcoord {i level ln} {
- global canvx0 xspc1 xspc2
-
- set x [expr {$canvx0 + $i * $xspc1($ln)}]
- if {$i > 0 && $i == $level} {
- set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
- } elseif {$i > $level} {
- set x [expr {$x + $xspc2 - $xspc1($ln)}]
- }
- return $x
-}
-
-# it seems Tk can't draw arrows on the end of diagonal line segments...
-proc trimdiagend {line} {
- while {[llength $line] > 4} {
- set x1 [lindex $line end-3]
- set y1 [lindex $line end-2]
- set x2 [lindex $line end-1]
- set y2 [lindex $line end]
- if {($x1 == $x2) != ($y1 == $y2)} break
- set line [lreplace $line end-1 end]
- }
- return $line
-}
-
-proc trimdiagstart {line} {
- while {[llength $line] > 4} {
- set x1 [lindex $line 0]
- set y1 [lindex $line 1]
- set x2 [lindex $line 2]
- set y2 [lindex $line 3]
- if {($x1 == $x2) != ($y1 == $y2)} break
- set line [lreplace $line 0 1]
- }
- return $line
-}
-
-proc drawslants {id needonscreen nohs} {
- global canv mainline mainlinearrow sidelines
- global canvx0 canvy xspc1 xspc2 lthickness
- global currentparents dupparents
- global lthickness linespc canvy colormap lineno geometry
- global maxgraphpct maxwidth
- global displist onscreen lastuse
- global parents commitlisted
- global oldnlines olddlevel olddisplist
- global nhyperspace numcommits nnewparents
-
- if {$lineno < 0} {
- lappend displist $id
- set onscreen($id) 1
- return 0
- }
-
- set y1 [expr {$canvy - $linespc}]
- set y2 $canvy
-
- # work out what we need to get back on screen
- set reins {}
- if {$onscreen($id) < 0} {
- # next to do isn't displayed, better get it on screen...
- lappend reins [list $id 0]
- }
- # make sure all the previous commits's parents are on the screen
- foreach p $currentparents {
- if {$onscreen($p) < 0} {
- lappend reins [list $p 0]
- }
- }
- # bring back anything requested by caller
- if {$needonscreen ne {}} {
- lappend reins $needonscreen
- }
-
- # try the shortcut
- if {$currentparents == $id && $onscreen($id) == 0 && $reins eq {}} {
- set dlevel $olddlevel
- set x [xcoord $dlevel $dlevel $lineno]
- set mainline($id) [list $x $y1]
- set mainlinearrow($id) none
- set lastuse($id) $lineno
- set displist [lreplace $displist $dlevel $dlevel $id]
- set onscreen($id) 1
- set xspc1([expr {$lineno + 1}]) $xspc1($lineno)
- return $dlevel
- }
-
- # update displist
- set displist [lreplace $displist $olddlevel $olddlevel]
- set j $olddlevel
- foreach p $currentparents {
- set lastuse($p) $lineno
- if {$onscreen($p) == 0} {
- set displist [linsert $displist $j $p]
- set onscreen($p) 1
- incr j
- }
- }
- if {$onscreen($id) == 0} {
- lappend displist $id
- set onscreen($id) 1
- }
-
- # remove the null entry if present
- set nullentry [lsearch -exact $displist {}]
- if {$nullentry >= 0} {
- set displist [lreplace $displist $nullentry $nullentry]
- }
-
- # bring back the ones we need now (if we did it earlier
- # it would change displist and invalidate olddlevel)
- foreach pi $reins {
- # test again in case of duplicates in reins
- set p [lindex $pi 0]
- if {$onscreen($p) < 0} {
- set onscreen($p) 1
- set lastuse($p) $lineno
- set displist [linsert $displist [lindex $pi 1] $p]
- incr nhyperspace -1
- }
- }
-
- set lastuse($id) $lineno
-
- # see if we need to make any lines jump off into hyperspace
- set displ [llength $displist]
- if {$displ > $maxwidth} {
- set ages {}
- foreach x $displist {
- lappend ages [list $lastuse($x) $x]
- }
- set ages [lsort -integer -index 0 $ages]
- set k 0
- while {$displ > $maxwidth} {
- set use [lindex $ages $k 0]
- set victim [lindex $ages $k 1]
- if {$use >= $lineno - 5} break
- incr k
- if {[lsearch -exact $nohs $victim] >= 0} continue
- set i [lsearch -exact $displist $victim]
- set displist [lreplace $displist $i $i]
- set onscreen($victim) -1
- incr nhyperspace
- incr displ -1
- if {$i < $nullentry} {
- incr nullentry -1
- }
- set x [lindex $mainline($victim) end-1]
- lappend mainline($victim) $x $y1
- set line [trimdiagend $mainline($victim)]
- set arrow "last"
- if {$mainlinearrow($victim) ne "none"} {
- set line [trimdiagstart $line]
- set arrow "both"
- }
- lappend sidelines($victim) [list $line 1 $arrow]
- unset mainline($victim)
- }
- }
-
- set dlevel [lsearch -exact $displist $id]
-
- # If we are reducing, put in a null entry
- if {$displ < $oldnlines} {
- # does the next line look like a merge?
- # i.e. does it have > 1 new parent?
- if {$nnewparents($id) > 1} {
- set i [expr {$dlevel + 1}]
- } elseif {$nnewparents([lindex $olddisplist $olddlevel]) == 0} {
- set i $olddlevel
- if {$nullentry >= 0 && $nullentry < $i} {
- incr i -1
- }
- } elseif {$nullentry >= 0} {
- set i $nullentry
- while {$i < $displ
- && [lindex $olddisplist $i] == [lindex $displist $i]} {
- incr i
- }
- } else {
- set i $olddlevel
- if {$dlevel >= $i} {
- incr i
- }
- }
- if {$i < $displ} {
- set displist [linsert $displist $i {}]
- incr displ
- if {$dlevel >= $i} {
- incr dlevel
- }
- }
- }
-
- # decide on the line spacing for the next line
- set lj [expr {$lineno + 1}]
- set maxw [expr {$maxgraphpct * $geometry(canv1) / 100}]
- if {$displ <= 1 || $canvx0 + $displ * $xspc2 <= $maxw} {
- set xspc1($lj) $xspc2
- } else {
- set xspc1($lj) [expr {($maxw - $canvx0 - $xspc2) / ($displ - 1)}]
- if {$xspc1($lj) < $lthickness} {
- set xspc1($lj) $lthickness
- }
- }
-
- foreach idi $reins {
- set id [lindex $idi 0]
- set j [lsearch -exact $displist $id]
- set xj [xcoord $j $dlevel $lj]
- set mainline($id) [list $xj $y2]
- set mainlinearrow($id) first
- }
-
- set i -1
- foreach id $olddisplist {
- incr i
- if {$id == {}} continue
- if {$onscreen($id) <= 0} continue
- set xi [xcoord $i $olddlevel $lineno]
- if {$i == $olddlevel} {
- foreach p $currentparents {
- set j [lsearch -exact $displist $p]
- set coords [list $xi $y1]
- set xj [xcoord $j $dlevel $lj]
- if {$xj < $xi - $linespc} {
- lappend coords [expr {$xj + $linespc}] $y1
- notecrossings $p $j $i [expr {$j + 1}]
- } elseif {$xj > $xi + $linespc} {
- lappend coords [expr {$xj - $linespc}] $y1
- notecrossings $p $i $j [expr {$j - 1}]
- }
- if {[lsearch -exact $dupparents $p] >= 0} {
- # draw a double-width line to indicate the doubled parent
- lappend coords $xj $y2
- lappend sidelines($p) [list $coords 2 none]
- if {![info exists mainline($p)]} {
- set mainline($p) [list $xj $y2]
- set mainlinearrow($p) none
- }
- } else {
- # normal case, no parent duplicated
- set yb $y2
- set dx [expr {abs($xi - $xj)}]
- if {0 && $dx < $linespc} {
- set yb [expr {$y1 + $dx}]
- }
- if {![info exists mainline($p)]} {
- if {$xi != $xj} {
- lappend coords $xj $yb
- }
- set mainline($p) $coords
- set mainlinearrow($p) none
- } else {
- lappend coords $xj $yb
- if {$yb < $y2} {
- lappend coords $xj $y2
- }
- lappend sidelines($p) [list $coords 1 none]
- }
- }
- }
- } else {
- set j $i
- if {[lindex $displist $i] != $id} {
- set j [lsearch -exact $displist $id]
- }
- if {$j != $i || $xspc1($lineno) != $xspc1($lj)
- || ($olddlevel < $i && $i < $dlevel)
- || ($dlevel < $i && $i < $olddlevel)} {
- set xj [xcoord $j $dlevel $lj]
- lappend mainline($id) $xi $y1 $xj $y2
- }
- }
- }
- return $dlevel
-}
-
-# search for x in a list of lists
-proc llsearch {llist x} {
- set i 0
- foreach l $llist {
- if {$l == $x || [lsearch -exact $l $x] >= 0} {
- return $i
- }
- incr i
- }
- return -1
-}
-
-proc drawmore {reading} {
- global displayorder numcommits ncmupdate nextupdate
- global stopped nhyperspace parents commitlisted
- global maxwidth onscreen displist currentparents olddlevel
-
- set n [llength $displayorder]
- while {$numcommits < $n} {
- set id [lindex $displayorder $numcommits]
- set ctxend [expr {$numcommits + 10}]
- if {!$reading && $ctxend > $n} {
- set ctxend $n
- }
- set dlist {}
- if {$numcommits > 0} {
- set dlist [lreplace $displist $olddlevel $olddlevel]
- set i $olddlevel
- foreach p $currentparents {
- if {$onscreen($p) == 0} {
- set dlist [linsert $dlist $i $p]
- incr i
- }
- }
- }
- set nohs {}
- set reins {}
- set isfat [expr {[llength $dlist] > $maxwidth}]
- if {$nhyperspace > 0 || $isfat} {
- if {$ctxend > $n} break
- # work out what to bring back and
- # what we want to don't want to send into hyperspace
- set room 1
- for {set k $numcommits} {$k < $ctxend} {incr k} {
- set x [lindex $displayorder $k]
- set i [llsearch $dlist $x]
- if {$i < 0} {
- set i [llength $dlist]
- lappend dlist $x
- }
- if {[lsearch -exact $nohs $x] < 0} {
- lappend nohs $x
- }
- if {$reins eq {} && $onscreen($x) < 0 && $room} {
- set reins [list $x $i]
- }
- set newp {}
- if {[info exists commitlisted($x)]} {
- set right 0
- foreach p $parents($x) {
- if {[llsearch $dlist $p] < 0} {
- lappend newp $p
- if {[lsearch -exact $nohs $p] < 0} {
- lappend nohs $p
- }
- if {$reins eq {} && $onscreen($p) < 0 && $room} {
- set reins [list $p [expr {$i + $right}]]
- }
- }
- set right 1
- }
- }
- set l [lindex $dlist $i]
- if {[llength $l] == 1} {
- set l $newp
- } else {
- set j [lsearch -exact $l $x]
- set l [concat [lreplace $l $j $j] $newp]
- }
- set dlist [lreplace $dlist $i $i $l]
- if {$room && $isfat && [llength $newp] <= 1} {
- set room 0
- }
- }
- }
-
- set dlevel [drawslants $id $reins $nohs]
- drawcommitline $dlevel
- if {[clock clicks -milliseconds] >= $nextupdate
- && $numcommits >= $ncmupdate} {
- doupdate $reading
- if {$stopped} break
- }
- }
-}
-
-# level here is an index in todo
-proc updatetodo {level noshortcut} {
- global ncleft todo nnewparents
- global commitlisted parents onscreen
-
- set id [lindex $todo $level]
- set olds {}
- if {[info exists commitlisted($id)]} {
- foreach p $parents($id) {
- if {[lsearch -exact $olds $p] < 0} {
- lappend olds $p
- }
- }
- }
- if {!$noshortcut && [llength $olds] == 1} {
- set p [lindex $olds 0]
- if {$ncleft($p) == 1 && [lsearch -exact $todo $p] < 0} {
- set ncleft($p) 0
- set todo [lreplace $todo $level $level $p]
- set onscreen($p) 0
- set nnewparents($id) 1
- return 0
- }
- }
-
- set todo [lreplace $todo $level $level]
- set i $level
- set n 0
- foreach p $olds {
- incr ncleft($p) -1
- set k [lsearch -exact $todo $p]
- if {$k < 0} {
- set todo [linsert $todo $i $p]
- set onscreen($p) 0
- incr i
- incr n
- }
- }
- set nnewparents($id) $n
-
- return 1
-}
-
-proc decidenext {{noread 0}} {
- global ncleft todo
- global datemode cdate
- global commitinfo
-
- # choose which one to do next time around
- set todol [llength $todo]
- set level -1
- set latest {}
- for {set k $todol} {[incr k -1] >= 0} {} {
- set p [lindex $todo $k]
- if {$ncleft($p) == 0} {
- if {$datemode} {
- if {![info exists commitinfo($p)]} {
- if {$noread} {
- return {}
- }
- readcommit $p
- }
- if {$latest == {} || $cdate($p) > $latest} {
- set level $k
- set latest $cdate($p)
- }
- } else {
- set level $k
- break
- }
- }
- }
- if {$level < 0} {
- if {$todo != {}} {
- puts "ERROR: none of the pending commits can be done yet:"
- foreach p $todo {
- puts " $p ($ncleft($p))"
- }
- }
- return -1
- }
-
- return $level
-}
-
-proc drawcommit {id} {
- global phase todo nchildren datemode nextupdate revlistorder
- global numcommits ncmupdate displayorder todo onscreen parents
-
- if {$phase != "incrdraw"} {
- set phase incrdraw
- set displayorder {}
- set todo {}
- initgraph
- }
- if {$nchildren($id) == 0} {
- lappend todo $id
- set onscreen($id) 0
- }
- if {$revlistorder} {
- set level [lsearch -exact $todo $id]
- if {$level < 0} {
- error_popup "oops, $id isn't in todo"
- return
- }
- lappend displayorder $id
- updatetodo $level 0
- } else {
- set level [decidenext 1]
- if {$level == {} || $id != [lindex $todo $level]} {
- return
- }
- while 1 {
- lappend displayorder [lindex $todo $level]
- if {[updatetodo $level $datemode]} {
- set level [decidenext 1]
- if {$level == {}} break
- }
- set id [lindex $todo $level]
- if {![info exists commitlisted($id)]} {
- break
- }
- }