Eskil

#             -line    : improve display. See online help for details.
#             -block   : The default is -block, but this can be slow if there
#                        are large change blocks.
#
#             -char    : The analysis of changes can be done on either
#             -word    : character or word basis. -char is the default.
#
#             -2nd     : Turn on or off second stage parsing.
#             -no2nd   : It is on by default.
#
#   Author    Peter Spjuth  980612
#
#   Revised   By       Date     Remark
#
#     1.0     DC-PS    980612   New Version.
#     1.1     DC-PS    980807   Parsing of change blocks added
#                               Options menu and variables changed
#                               Command line options added
#     1.2     DC-PS    980818   Improved yscroll
#                               Added map next to y-scrollbar
#     1.3     DC-PS    980921   Added Prev Diff button
#                               Added colour options, and Only diffs option
#                               Added 2nd stage line parsing
#                               Improved block parsing
#                               Added print
#
#-----------------------------------------------
# the next line restarts using wish \
exec wish "$0" "$@"

set debug 0
set diffver "Version 1.3 980921"

proc myform {lineNo text} {
    return [format "%3d: %s\n" $lineNo $text]
}

proc myforml {lineNo} {
    return [format "%3d: " $lineNo]
}

proc maxabs {a b} {
    return [expr {abs($a) > abs($b) ? $a : $b}]
}

#2nd stage line parsing
#Recursively look for common substrings in strings s1 and s2
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]

                    for {} {$newp1 > $newt} {incr newp1 -1} {
                        if {[string index $s1 $newp1] == " "} break
                    }
                }
                incr newp1

                if {$newp1 - $newt > $minlen} {
                    set foundlen [expr {$newp1 - $newt}]
                    set found1 $newt
                    set found2 [expr {$i + $newt - $t}]
                    set minlen $foundlen
                    set u [expr {$t + $minlen}]
                }
            } else {
                set foundlen [expr {$p1 - $t}]

    return
}

#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.
proc comparelines {line1 line2 res1Name res2Name {test 0}} {
    global Pref
    upvar $res1Name res1
    upvar $res2Name res2

    #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]

    #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

    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]
    }
}

#Count how many characters are common between two lines
proc comparelines2 {line1 line2} {
    comparelines $line1 $line2 res1 res2 1

    #Add lengths of every other element
    set sumsame 0
    set sumdiff1 0
    set sumdiff2 0
    foreach {same diff} $res1 {
        incr sumsame [string length $same]
        incr sumdiff1 [string length $diff]
    }
    foreach {same diff} $res2 {
        incr sumdiff2 [string length $diff]
    }

    return [expr {$sumsame - [maxabs $sumdiff1 $sumdiff2]}]
}

#Decide how to display change blocks
proc compareblocks {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 0
        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} {$bad != "" && $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
                }
            }
            foreach i $bad {
                set next 0

                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

                        }
                    }
                    if {$next == 1} continue
                }
            }
        }
    }

    set apa {}
    set t1 0 
    set t2 0
    while {$t1 < $size1 || $t2 < $size2} {
        if {$t1 < $size1} {
            set r [lindex $result $t1]
            if {$r < $t2 || $t2 >= $size2} {

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

#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) != "none"} {
        comparelines $line1 $line2 res1 res2
        set dotag 0
        .t1 insert end [myforml $doingLine1] change

        .t1 insert end [myform $doingLine1 $line1] change
        .t2 insert end [myform $doingLine2 $line2] change
    }
    incr doingLine1
    incr doingLine2
}

#Process one of the change/add/delete blocks reported by diff.
#ch1data contains n1 lines of text from 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 {ch1data ch2 n1 n2 line1 line2} {
    global doingLine1 doingLine2 Pref mapList mapMax

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

        incr doingLine1
        incr doingLine2
    }
    if {$doingLine2 != $line2} {
        .t1 insert end "**Bad alignment here!! $doingLine2 $line2**\n"
        .t2 insert end "**Bad alignment here!! $doingLine2 $line2**\n"
    }

    #Process the block

    if {$n1 == $n2 && ($n1 == 1 || $Pref(parse) != "block")} {
        for {set t 0} {$t < $n1} {incr t} {
            set line1 [lindex $ch1data $t]
            gets $ch2 line2
            insertMatchingLines $line1 $line2
        }

proc disableRedo {} {
    .mf.m entryconfigure 1 -state disabled
}

proc busyCursor {} {
    global oldcursor oldcursor2
    if {![info exists oldcursor]} {
        set oldcursor [. cget -cursor]
        set oldcursor2 [.t1 cget -cursor]
    }
    . config -cursor watch
    .t1 config -cursor watch
    .t2 config -cursor watch
}

proc normalCursor {} {
    global oldcursor oldcursor2
    . config -cursor $oldcursor
    .t1 config -cursor $oldcursor2
    .t2 config -cursor $oldcursor2
}














proc doDiff {} {
    global leftFile rightFile leftOK rightOK RCS
    global eqLabel RCS Pref doingLine1 doingLine2
    global mapList mapMax

    if {$RCS == 0 && ($leftOK == 0 || $rightOK == 0)} {
        disableRedo
        return
    } else {
        enableRedo
    }

    busyCursor

    .t1 delete 1.0 end
    .t2 delete 1.0 end
    set mapList {}
    set mapMax 0

    update idletasks

    if {$RCS} {
        set differr [catch {eval exec rcsdiff $Pref(dopt) $Pref(ignore) $rightFile} diffres]
    } else {
        set differr [catch {eval exec diff $Pref(dopt) $Pref(ignore) $leftFile $rightFile} diffres]
    }



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

    }

    dotext "" $ch2 0 0 0 0

    close $ch2
    drawMap -1
    normalCursor

}

proc doOpenLeft {} {
    global leftFile leftDir rightDir leftOK
    if {![info exists leftDir]} {
        if {[info exists rightDir]} {
            set leftDir $rightDir

        return "\n     "
    } else {
        return "\0bggray\{1.0\}\n     \0bggray\{$gray\}"
    }
}

proc printDiffs {} {
    busyCursor
    set tmpFile [file nativename ~/tcldiff.enscript]
    set tmpFile2 [file nativename ~/tcldifftmp.ps]
    set tmpFile3 [file nativename ~/tcldiff.ps]
    set ch [open $tmpFile "w"]

    set lines1 {}
    set lines2 {}

    set tdump1 [.t1 dump -tag -text 1.0 end]
    set tdump2 [.t2 dump -tag -text 1.0 end]

    foreach tdump [list $tdump1 $tdump2] \
            lineName {lines1 lines2} wrapName {wrap1 wrap2} {
        set lines {}
        set wraps {}
        set line ""
        set newline 0
        set gray 1.0
        set chars 0
        set wrapc 0

                }
                tagoff {
                    append line "\0bggray\{1.0\}"
                    set gray 1.0
                }
            }
        }
        set $lineName $lines
        set $wrapName $wraps
    }

    set wraplines1 {}
    set wraplines2 {}

    foreach l1 $lines1 l2 $lines2 w1 $wrap1 w2 $wrap2 {
        if {$w1 > 0} {

        puts -nonewline $ch "\f"
    }

    close $ch

    catch {exec enscript -c -B -e -p $tmpFile2 $tmpFile}
    catch {exec mpage -aA2P $tmpFile2 > $tmpFile3}

    normalCursor

    destroy .dp
    toplevel .dp
    wm title .dp "Diff Print"
    button .dp.b -text Close -command {destroy .dp}
    label .dp.l -anchor w -justify left -text "The following files have\
            been created:\n$tmpFile\nInput file to enscript.\
            \n$tmpFile2\nCreated with 'enscript -c -B -e -p $tmpFile2\
            $tmpFile'\n$tmpFile3\nCreated with 'mpage -aA2P $tmpFile2 >\
            $tmpFile3'"
    pack .dp.b -side bottom
    pack .dp.l -side top
}

proc my_yview args {
    eval .t1 yview $args
    eval .t2 yview $args
}

proc my_yscroll args {
    eval .sby set $args
    my_yview moveto [lindex $args 0]
}

proc chFont {} {
    global Pref

    font configure myfont -size $Pref(fontsize)


}

proc applyColor {} {
    global Pref

    .t1 tag configure new1 -foreground $Pref(colornew1) -background $Pref(bgnew1)
    .t1 tag configure change -foreground $Pref(colorchange) -background $Pref(bgchange)
    .t2 tag configure new2 -foreground $Pref(colornew2) -background $Pref(bgnew2)
    .t2 tag configure change -foreground $Pref(colorchange) -background $Pref(bgchange)
}

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

    frame .f
    grid .f - - - -row 0 -sticky news

    menubutton .mf -text File -underline 0 -menu .mf.m
    menu .mf.m
    if {$debug == 1} {
        .mf.m add command -label "Redo Diff" -underline 5 -command doDiff
    } else {
        .mf.m add command -label "Redo Diff" -underline 5 -command doDiff -state disabled
    }
    .mf.m add separator
    .mf.m add command -label "Open Both" -underline 0 -command openBoth
    .mf.m add command -label "Open Left File" -command openLeft
    .mf.m add command -label "Open Right File" -command openRight

    .mo.mp add radiobutton -label "Characters" -variable Pref(lineparsewords) -value "0"
    .mo.mp add radiobutton -label "Words" -variable Pref(lineparsewords) -value "1"
    .mo.mp add separator
    .mo.mp add checkbutton -label "Use 2nd stage" -variable Pref(extralineparse)

    menubutton .mh -text Help -underline 0 -menu .mh.m
    menu .mh.m
    .mh.m add command -label "Help" -command makeHelpWin
    .mh.m add command -label "About" -command makeAboutWin

    button .bfn -text "Next Diff" -relief raised -command findNext
    button .bfp -text "Prev Diff" -relief raised -command findPrev
    entry .eo -width 10 -textvariable Pref(dopt)
    label .lo -text "Diff Options"

            set Pref(parse) "line"
        } elseif {$arg == "-block"} {
            set Pref(parse) "block"
        } elseif {$arg == "-char"} {
            set Pref(lineparsewords) 0
        } elseif {$arg == "-word"} {
            set Pref(lineparsewords) 1
        } elseif {$arg == "-2nd"} {
            set Pref(extralineparse) 1
        } elseif {$arg == "-no2nd"} {
            set Pref(extralineparse) 0
        } elseif {$arg == "-nodiff"} {
            set noautodiff 1
        } elseif {[string range $arg 0 0] == "-"} {
            set Pref(dopt) "$Pref(dopt) $arg"
        } else {
            set apa [glob -nocomplain $arg]
            if {$apa == ""} {

            set rightDir $fulldir
            set rightFile $fullname
            set rightOK 1
            set leftFile "RCS"
            if {$noautodiff == "1"} {
                enableRedo
            } else {
                after idle doDiff
            }
        } else {
            set leftDir $fulldir
            set leftFile $fullname
            set leftOK 1
        }
    } elseif {$len >= 2} {
        set fullname [file join [pwd] [lindex $files 0]]
        set fulldir [file dirname $fullname]
        set leftDir $fulldir
        set leftFile $fullname
        set leftOK 1
        set fullname [file join [pwd] [lindex $files 1]]
        set fulldir [file dirname $fullname]
        set rightDir $fulldir
        set rightFile $fullname
        set rightOK 1
        if {$noautodiff == "1"} {
            enableRedo
        } else {
            after idle doDiff
        }
    }
}

proc saveOptions {} {
    global Pref
    set ch [open "~/.diffrc" "w"]

    global Pref

    set Pref(fontsize) 9
    set Pref(ignore) "-b"
    set Pref(dopt) ""
    set Pref(parse) "block"
    set Pref(lineparsewords) "0"
    set Pref(extralineparse) 1
    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

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

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