Eskil

#                               Added CVS support.
#
#-----------------------------------------------
# the next line restarts using wish \
exec wish "$0" "$@"

set debug 1
set diffver "Version 1.8b  000824"
set tmpcnt 0
set tmpfiles {}
set thisscript [file join [pwd] [info script]]
set thisdir [file dirname $thisscript]

if {$tcl_platform(platform) == "windows"} {
    cd $thisdir

    global tmpfiles
    foreach f $tmpfiles {
        file delete $f
    }
    set tmpfiles {}
}

# 2nd stage line parsing
# Recursively look for common substrings in strings s1 and s2
##syntax compareMidString x x n n x?
proc compareMidString {s1 s2 res1Name res2Name {test 0}} {
    global Pref
    upvar $res1Name res1
    upvar $res2Name res2

    set len1 [string length $s1]
    set len2 [string length $s2]

    # Is s1 a substring of s2 ?
    if {$len1 < $len2} {
        set t [string first $s1 $s2]
        if {$t != -1} {
            set left2 [string range $s2 0 [expr {$t - 1}]]
            set mid2 [string range $s2 $t [expr {$t + $len1 - 1}]]
            set right2 [string range $s2 [expr {$t + $len1}] end]
            set res2 [list $left2 $mid2 $right2]
            set res1 [list "" $s1 ""]
            return
        }
    }

    # Is s2 a substring of s1 ?
    if {$len2 < $len1} {
        set t [string first $s2 $s1]
        if {$t != -1} {
            set left1 [string range $s1 0 [expr {$t - 1}]]
            set mid1 [string range $s1 $t [expr {$t + $len2 - 1}]]
            set right1 [string range $s1 [expr {$t + $len2}] end]
            set res1 [list $left1 $mid1 $right1]
            set res2 [list "" $s2 ""]
            return
        }
    }

    # Are they too short to be considered ?
    if {$len1 < 4 || $len2 < 4} {
        set res1 [list $s1]
        set res2 [list $s2]
        return
    }

    set foundlen -1
    set minlen 2 ;# The shortest common substring we detect is 3 chars

    # Find the longest string common to both strings
    for {set t 0 ; set u $minlen} {$u < $len1} {incr t ; incr u} {
        set i [string first [string range $s1 $t $u] $s2]
        if {$i >= 0} {
            for {set p1 [expr {$u + 1}]; set p2 [expr {$i + $minlen + 1}]} \
                    {$p1 < $len1 && $p2 < $len2} {incr p1 ; incr p2} {
                if {[string index $s1 $p1] != [string index $s2 $p2]} {
                    break

        compareMidString $right1 $right2 right1 right2 $test

        set res1 [concat $left1 [list $mid1] $right1]
        set res2 [concat $left2 [list $mid2] $right2]
    }
}

# Compare two lines to find inequalities to highlight.
# The return value is, for each line, a list where the first, third etc.
# element is equal between the lines. The second, fourth etc. will be
# highlighted.
##syntax compareLines x x n n x?
proc compareLines {line1 line2 res1Name res2Name {test 0}} {
    global Pref
    upvar $res1Name res1
    upvar $res2Name res2

    if {$Pref(ignore) != " "} {
        # Skip white space in both ends

        set apa1 [string trimleft $line1]
        set leftp1 [expr {[string length $line1] - [string length $apa1]}]
        set mid1 [string trimright $line1]

        set apa2 [string trimleft $line2]
        set leftp2 [expr {[string length $line2] - [string length $apa2]}]
        set mid2 [string trimright $line2]
    } else {
        # If option "ignore nothing" is selected
        set apa1 $line1
        set leftp1 0
        set mid1 $line1
        set apa2 $line2
        set leftp2 0
        set mid2 $line2
    }

    # Check for matching left chars/words.
    # leftp1 and leftp2 will be the indicies of the first difference

    set len1 [string length $apa1]
    set len2 [string length $apa2]
    set len [expr {$len1 < $len2 ? $len1 : $len2}]
    for {set t 0; set s 0; set flag 0} {$t < $len} {incr t} {
        if {[set c [string index $apa1 $t]] != [string index $apa2 $t]} {
            incr flag 2

        } elseif {$flag == 3} {
            incr s
        }
        incr leftp1 $s
        incr leftp2 $s
    }

    # Check for matching right chars/words.
    # t1 and t2 will be the indicies of the last difference

    set len1 [string length $mid1]
    set len2 [string length $mid2]

    set t1 [expr {$len1 - 1}]
    set t2 [expr {$len2 - 1}]
    set s1 $t1

                incr s2 -1
            }
            set t1 $s1
            set t2 $s2
        }
    }

    # Make the result
    if {$leftp1 > $t1} {
        set res1 [list $line1]
    } else {
        set right1 [string range $line1 [expr {$t1 + 1}] end]
        set mid1 [string range $line1 $leftp1 $t1]
        set left1 [string range $line1 0 [expr {$leftp1 - 1}]]
        set res1 [list $left1 $mid1 $right1]

    if {$Pref(extralineparse) != 0 && $leftp1 <= $t1 && $leftp2 <= $t2} {
        compareMidString $mid1 $mid2 mid1 mid2 $test
        set res1 [eval lreplace \$res1 1 1 $mid1]
        set res2 [eval lreplace \$res2 1 1 $mid2]
    }
}

# Compare two lines and rate how much they resemble each other.
proc compareLines2 {line1 line2} {
    compareLines $line1 $line2 res1 res2 1

    # Collect identical pieces and different pieces
    set sames {}
    set diffs1 {}
    set diffs2 {}
    foreach {same diff} $res1 {
        lappend sames $same
        if {$diff != ""} {
            lappend diffs1 $diff
        }
    }
    foreach {same diff} $res2 {
        if {$diff != ""} {
            lappend diffs2 $diff
        }
    }
    set sumsame 0
    set sumdiff1 0
    set sumdiff2 0
    foreach same $sames {
        set apa [string length [string trim $same]]
        
        incr sumsame [expr {$apa * $apa}]
    }
    foreach diff $diffs1 {
        set apa [string length $diff]
        incr sumdiff1 $apa
    }
    foreach diff $diffs2 {
        set apa [string length $diff]
        incr sumdiff2 $apa
    }
#    puts "S $sumsame D $sumdiff1 D $sumdiff2"
    return [expr {$sumsame - [maxabs $sumdiff1 $sumdiff2]}]
}

# Decide how to display change blocks
proc oldcompareblocks {block1 block2} {
    set size1 [llength $block1]
    set size2 [llength $block2]

    # Swap if block1 is bigger
    if {$size1 > $size2} {
        set apa $block1
        set block1 $block2
        set block2 $apa
        set size1 [llength $block1]
        set size2 [llength $block2]
        set dsym a
        set asym d
    } else {
        set dsym d
        set asym a
    }

    # Collect statistics
    set result {}
    set scores {}
    foreach line1 $block1 {
        set bestscore -100000
        set bestline 0
        set i 0
        foreach line2 $block2 {
            set x [compareLines2 $line1 $line2]
            if {$x > $bestscore} {
                set bestscore $x
                set bestline $i
            }
            incr i
        }
        lappend result $bestline
        lappend scores $bestscore
    }

    # If result is in order, no problem.
    # Otherwise, try to adjust result to make it ordered
    if {$size1 > 1} {
        set bad 1
        for {set loop 0} {[llength $bad] != 0 && $loop < 2} {incr loop} {
            set bad {}
            for {set i 0; set j 1} {$j < $size1} {incr i; incr j} {
                if {[lindex $result $i] >= [lindex $result $j]} {
                    lappend bad $i

                set l3 [lindex $result $j]
                if {$i + 2 >= $size1} {
                    set l4 [expr {$size2 + 10}]
                } else {
                    set l4 [lindex $result [expr {$i + 2}]]
                }

                # Try to move the one with lowest score first
                set si [lindex $scores $i]
                set sj [lindex $scores $j]
                if {$si < $sj} {
                    for {set t [expr {$l3 - 1}]} {$t > $l1} {incr t -1} {
                        if {[lsearch $result $t] == -1} {
                            set result [lreplace $result $i $i $t]
                            set next 1

            lappend apa $asym
            incr t2
        }
    }
    return $apa
}

# Decide how to display change blocks
# This tries to match the lines that resemble each other and put them
# next to each other. The algorithm for doing it would need some work.
proc compareblocks {block1 block2} {
    set size1 [llength $block1]
    set size2 [llength $block2]

    if {$size1 * $size2 > 1000} {
        puts "Diff warning: Analyzing a large block. ($size1 $size2)"
        update idletasks
    }

    # Swap if block1 is bigger
    if {$size1 > $size2} {
        set apa $block1
        set block1 $block2
        set block2 $apa
        set size1 [llength $block1]
        set size2 [llength $block2]
        set dsym a
        set asym d
    } else {
        set dsym d
        set asym a
    }

    # Collect statistics
    array set scores {}
    set j 0
    set bestsum 0
    foreach line1 $block1 {
        set bestscore -100000
        set bestline 0
        set i 0
        foreach line2 $block2 {
            set x [compareLines2 $line1 $line2]
            set scores($j,$i) $x
#            puts "Score $j $i : $x"
            if {$x > $bestscore} {
                set bestscore $x
                set bestline $i
            }
            incr i
        }
#        puts "Best for $j is $bestline : $bestscore"
        set origresult($j) $bestline
        set scores(best,$j) $bestscore
        incr bestsum $bestscore
        incr j
    }

    array set bestresult [array get origresult]

    # If result is in order, no problem.
    # Otherwise, try to adjust result to make it ordered
    if {$size1 > 1} {

        set bestscoresum -100000

        while {1} {
            array set result [array get origresult]
            for {set i 0} {$i < $size1} {incr i} {
                set mark($i) 0
            }
            while {1} {
                set besti 0
                set bestscore -100000
                set order 1
                for {set i 0} {$i < $size1} {incr i} {
                    if {$mark($i) == 0} {
                        for {set j [expr {$i + 1}]} {$j < $size1} {incr j} {
                            if {$mark($j) == 0} break
                        }
                        if {$j < $size1 && $result($i) >= $result($j)} {
                            set order 0
                        }
                        set x $scores(best,$i)
                        if {$x > $bestscore} {
                            set bestscore $x
                            set besti $i
                        }
                    }
                }
#                puts "Best $besti order $order sc $bestscore"
                if {$order} break
                set mark($besti) 1
                set bestr $result($besti)
                for {set i 0} {$i < $besti} {incr i} {
                    if {$mark($i) == 0 && $result($i) >= $bestr} {
                        set mark($i) 2
                    }
                }
                for {set i [expr {$besti + 1}]} {$i < $size1} {incr i} {
                    if {$mark($i) == 0 && $result($i) <= $bestr} {
                        set mark($i) 2
                    }
                }
            }
            set prev $size2
            for {set i [expr {$size1 - 1}]} {$i >= 0} {incr i -1} {
                if {$mark($i) != 2} {
                    set prev $result($i)
                } else {
                    set high($i) [expr {$prev - 1}]
                }
            }
            set prev -1
            for {set i 0} {$i < $size1} {incr i} {
                if {$mark($i) != 2} {
                    set prev $result($i)
                } else {
                    if {$high($i) > $prev} {
                        incr prev
                        set result($i) $prev
                    } else {
                        set result($i) -1
                    }
                }
            }
            set scoresum 0
            for {set i 0} {$i < $size1} {incr i} {
                set j $result($i)
                if {[info exists scores($i,$j)]} {
#                    puts "Score: $i $j $scores($i,$j)"
                    incr scoresum $scores($i,$j)
                }
            }
#            puts "Scoresum: $scoresum ($bestsum)"
            if {$scoresum > $bestscoresum} {
                array set bestresult [array get result]
                set bestscoresum $scoresum
                if {$bestscoresum >= (3 * $bestsum / 4)} {
                    break
                }
                # If the result seems too bad, try again but
                # ignore the most awkwardly placed line.
                set mostp -1
                set mosti 0
                for {set i 0} {$i < $size1} {incr i} {
                    if {$mark($i) == 1} {
                        if {abs($result($i) - $i) > $mostp} {
                            set mostp [expr {abs($result($i) - $i)}]
                            set mosti $i
                        }
                    }
                }
#                puts "Most $mosti $mostp"
                set scores(best,$mosti) 0
            } else {
                break
            }
        }
    }

    array set result [array get bestresult]

    set apa {}
    set t1 0
    set t2 0
    while {$t1 < $size1 || $t2 < $size2} {
        if {$t1 < $size1} {
            set r $result($t1)

            lappend apa $asym
            incr t2
        }
    }
    return $apa
}

# Insert lineno and text
proc insert {n line text {tag {}}} {
    .ft$n.tl insert end [myforml $line] $tag
    .ft$n.tt insert end "$text\n" $tag
}

proc emptyline {n} {
    .ft$n.tl insert end "\n"
    .ft$n.tt insert end "\n"
}

# Insert one line in each text widget.
# Mark them as changed, and optionally parse them.
proc insertMatchingLines {line1 line2} {
    global doingLine1 doingLine2 Pref

    if {$Pref(parse) != 0} {
        compareLines $line1 $line2 res1 res2
        set dotag 0
        set n [maxabs [llength $res1] [llength $res2]]

        insert 1 $doingLine1 $line1 change
        insert 2 $doingLine2 $line2 change
    }
    incr doingLine1
    incr doingLine2
}

# Process one of the change/add/delete blocks reported by diff.
# ch1 is a file channel for the left file
# ch2 is a file channel for the right file
# n1/n2 is the number of lines involved
# line1/line2 says on what lines this block starts
proc dotext {ch1 ch2 n1 n2 line1 line2} {
    global doingLine1 doingLine2 Pref mapList mapMax

    if {$n1 == 0 && $n2 == 0} {
        # All blocks have been processed. Continue until end of file.
        if {$Pref(onlydiffs) == 1} return
        while {[gets $ch2 apa] != -1} {
            insert 2 $doingLine2 $apa
            incr doingLine2
            incr mapMax
        }
        while {[gets $ch1 apa] != -1} {
            insert 1 $doingLine1 $apa
            incr doingLine1
        }
        return
    }

    if {$n1 == 0} {set tag2 new2} else {set tag2 change}
    if {$n2 == 0} {set tag1 new1} else {set tag1 change}

    # Display all equal lines before next diff
    if {$Pref(onlydiffs) == 1 && $doingLine1 < $line1} {
        emptyline 1
        emptyline 2
        incr mapMax
    }
    while {$doingLine1 < $line1} {
        gets $ch1 apa

    if {$doingLine2 != $line2} {
        .ft1.tt insert end "**Bad alignment here!! $doingLine2 $line2**\n"
        .ft2.tt insert end "**Bad alignment here!! $doingLine2 $line2**\n"
        .ft1.tl insert end "\n"
        .ft2.tl insert end "\n"
    }

    # Process the block

    if {$n1 == $n2 && ($n1 == 1 || $Pref(parse) < 2)} {
        for {set t 0} {$t < $n1} {incr t} {
            gets $ch1 line1
            gets $ch2 line2
            insertMatchingLines $line1 $line2
        }

                incr mapMax $n1
                lappend mapList $mapMax $tag1
            }
        }
    }
}

# Scroll windows to next diff
proc findNext {} {
    set i [.ft1.tt index @0,0+1line]
    set n1 [.ft1.tt tag nextrange new1 $i]
    set c1 [.ft1.tt tag nextrange change $i]
    set i [.ft2.tt index @0,0+1line]
    set n2 [.ft2.tt tag nextrange new2 $i]
    set c2 [.ft2.tt tag nextrange change $i]

    }

    foreach w {.ft1.tl .ft1.tt .ft2.tl .ft2.tt} {
        $w yview $apa
    }
}

# Scroll windows to previous diff
proc findPrev {} {
    set i [.ft1.tt index @0,0]
    set n1 [.ft1.tt tag prevrange new1 $i]
    set c1 [.ft1.tt tag prevrange change $i]
    set i [.ft2.tt index @0,0]
    set n2 [.ft2.tt tag prevrange new2 $i]
    set c2 [.ft2.tt tag prevrange change $i]

    update idletasks

    if {$RCSmode} {
        prepareRCS
    }

    set differr [catch {eval exec \$::diffexe $Pref(dopt) $Pref(ignore) \
            \$leftFile \$rightFile} diffres]

    set apa [split $diffres "\n"]
    set result {}
    foreach i $apa {
        if {[string match {[0-9]*} $i]} {
            lappend result $i

        }
    } else {
        set eqLabel " "
    }

    set ch1 [open $leftFile]
    set ch2 [open $rightFile]
    if {$::tcl_platform(platform) == "windows" && $Pref(crlf)} {
        fconfigure $ch1 -translation crlf
        fconfigure $ch2 -translation crlf
    }
    set doingLine1 1
    set doingLine2 1
    set t 0
    foreach i $result {

        if {$y2 <= $y1} {set y2 [expr {$y1 + 1}]}
        if {$y2 > $h} {set y2 $h}
        incr y2
        map put $Pref(color$type) -to 1 $y1 $x2 $y2
    }
}

# Format a line number for printing
proc formatLineno {lineno gray} {
    set res [format "%3d: " $lineno]
    if {[string length $res] > 5} {
        set res [string range $res end-5 end-1]
    }
    if {$gray == "1.0"} {
        return $res

                set line ""
            }
        }
    }
    return $lines
}

# Handle wrapping of a too long line for printing
proc linewrap {gray} {
    if {$gray == "1.0"} {
        return "\n     "
    } else {
        return "\0bggray\{1.0\}\n     \0bggray\{$gray\}"
    }
}

# Prepare a text block for printing
proc fixTextBlock {text index} {
    # Remove any form feed
    if {[regsub -all "\f" $text {} apa]} {
        set text $apa
    }
    regexp {\d+\.(\d+)} $index -> index

    # Expand tabs to 8 chars
    while 1 {
        set i [string first \t $text]
        if {$i == -1} break
        set n [expr {(- $i - $index) % 8}]
        set text [string replace $text $i $i [format %${n}s ""]]
    }
    return $text

proc scroll {n what} {
    if {![string match ".ft?.tt" [focus]]} {
        .ft1.tt yview scroll $n $what
    }
}

# Build the main window
proc makeDiffWin {} {
    global Pref tcl_platform debug
    eval destroy [winfo children .]

    wm protocol . WM_DELETE_WINDOW cleanupAndExit

    frame .f

    menubutton .mo -text Options -underline 0 -menu .mo.m
    menu .mo.m
    .mo.m add cascade -label Font -underline 0 -menu .mo.mf
    .mo.m add cascade -label Ignore -underline 0 -menu .mo.mi
    .mo.m add cascade -label Parse -underline 0 -menu .mo.mp
    .mo.m add command -label Colours -underline 0 -command makePrefWin
    .mo.m add checkbutton -label "Diffs only" -variable Pref(onlydiffs)
    if {$tcl_platform(platform) == "windows"} {
        .mo.m add checkbutton -label "Force crlf translation" \
                -variable Pref(crlf)
    }
    .mo.m add separator
    .mo.m add command -label "Save default" -command saveOptions

    menu .mo.mf
    .mo.mf add command -label "Select" -command makeFontWin
    .mo.mf add radiobutton -label 6 -variable Pref(fontsize) -value 6 \
            -command chFont

    grid .fo.es .fo.bm .fo.bp -sticky new
    grid columnconfigure .fo 0 -weight 1
    grid rowconfigure .fo 1 -weight 1

    exampleFont
}

# Help and startup functions

proc makeAboutWin {} {
    global diffver
    destroy .ab

    toplevel .ab
    wm title .ab "About Diff.tcl"

    set Pref(colorchange) red
    set Pref(colornew1) darkgreen
    set Pref(colornew2) blue
    set Pref(bgchange) gray
    set Pref(bgnew1) gray
    set Pref(bgnew2) gray
    set Pref(onlydiffs) 0
    set Pref(crlf) 0
    set Pref(marklast) 1

    if {[file exists "~/.diffrc"]} {
        source "~/.diffrc"
    }
}

if {![winfo exists .f]} {
    getOptions
    makeDiffWin
    update idletasks
    parseCommandLine
}