#! /usr/bin/env tclsh
namespace eval private {
package require {ycl proc}
[yclprefix] proc alias [yclprefix]::proc::alias
alias aliases [yclprefix] proc aliases
aliases {
{ycl list} {
linsert
lreplace
take
}
{ycl math} {
=
}
{ycl proc} {
imports
stub
}
}
variable doc
stub {diff file} {fname1 fname2 args} {
aliases {
{ycl dir stat}
{ycl dir} {
stat
}
{ycl file} {
cat
}
{ycl string} {
map
}
}
} {
set stats [stat run $fname1]
set name1time [clock format [dict get $stats mtime] -format {%Y-%m-%d %H:%M:%S %z}]
set list1 [split [cat fname1] \n]
set list2 [split [cat fname2] \n]
diff $list1 $list2 {*}$args
}
stub diff {list1 list2 args} {
aliases {
{ycl dict} {
merge
}
{ycl proc} {
optswitch
}
{ycl string} {
map
}
}
} {
set consolidate 1
set {default context} none
set numbers 0
set firstnum 0
set format unified
set usecontext 0
set {default xsym} -
set {default ysym} +
set xinfo {}
set yinfo {}
while {[llength $args]} {
take args arg
optswitch $arg {
consolidate {
take args arg
= consolidate {!!$arg}
}
context {
take args arg
if {[string is double $arg]} {
set context $arg
set usecontext 1
} else {
optswitch $arg {
none - full {
set context $arg
}
}
}
}
firstnum {
take args arg
= firstnum {$arg + 0}
}
xinfo {
take args xinfo
}
yinfo {
take args yinfo
}
format {
take args arg
optswitch $arg {
normal {
set format $arg
set {default xsym} <
set {default ysym} >
}
unified {
set format $arg
set {default context} 3
}
}
}
numbers {
take args arg
= numbers {!!$arg}
}
xsym {
take args xsym
}
ysym {
take args ysym
}
}
}
if {![info exists context]} {
set context ${default context}
}
if {![info exists xsym]} {
set xsym ${default xsym}
}
if {![info exists ysum]} {
set ysym ${default ysym}
}
set len1 [llength $list1]
set len2 [llength $list2]
= last {max($len1, $len2) - 1}
set matches [lcsmatch $list1 $list2]
if {![llength $matches]} return
set priorcontext {}
set xcursor 0
set ycursor 0
set time [clock seconds]
set ftime [clock format $time -format {%Y-%m%d %H:%M:%S %z}]
foreach infovar {xinfo yinfo} localvar {x y} {
upvar 0 $infovar info
foreach key {time name} default [list $ftime sequence] {
if {[dict exists $info key]} {
set $localvar$key [dict get $xinfo key]
} else {
set $localvar$key $default
}
}
}
puts "--- $xname\t$xtime"
puts "+++ $yname\t$ytime"
set script {
if {$usecontext} {
set context1 $context
} else {
set context1 3
}
while {[llength $matches]} {
@initialize i@
@initialize j@
take matches match
lassign $match xidx yidx length
if {$consolidate && $length <= (
[string is double -strict $context] ? $context : 3)} {
continue
}
set needdivider 0
switch $format {
normal {
set xrange [expr {$xcursor + $firstnum}],[
expr {$xidx + $firstnum - 1}]
set yrange [expr {$ycursor + $firstnum}],[
expr {$yidx + $firstnum - 1}]
}
unified {
= xstart {$xcursor + $firstnum}
= ystart {$ycursor + $firstnum}
if {$usecontext} {
= xlen {$xidx - $xcursor + min($xidx + $length, $context)}
= ylen {$yidx - $ycursor + min($yidx + $length, $context)}
= xstart {max(0,$xstart - $context)}
= ystart {max(0,$ystart - $context)}
= xlen {$xlen + $context}
= ylen {$ylen + $context}
} else {
= xlen {$xidx - $xcursor + $xidx + $length}
= ylen {$yidx - $ycursor + $yidx + $length}
}
set xrange $xstart,$xlen
set yrange $ystart,$ylen
}
}
set {need context} 0
if {$xcursor < $xidx} {
if {$ycursor < $yidx} {
switch $format {
normal {
set needdivider 1
puts ${xrange}c[expr {$ycursor + $firstnum}],[
expr {$yidx + $firstnum - 1}]
}
unified {
puts "@@ $xsym$xrange $ysym$yrange @@"
}
}
} else {
puts ${xrange}d$ycursor
}
} elseif {$ycursor < $yidx} {
puts ${xcursor}a$yrange
}
if {$xcursor < $xidx} {
set {need context} -1
if {$usecontext} {
foreach item $priorcontext {
puts " $item"
}
}
while {$xcursor < $xidx} {
set item [lindex $list1 $xcursor]
incr xcursor
puts "@ivar@$xsym$item"
@incr i@
}
}
if {${needdivider}} {
puts ---
}
if {$ycursor < $yidx} {
set {need context} 1
while {$ycursor < $yidx} {
set item [lindex $list2 $ycursor]
incr ycursor
puts "@jvar@$ysym$item"
@incr j@
}
}
switch $context {
full {
set cursor $xidx
= nextcursor {$xidx + $length}
while {$cursor < $nextcursor} {
set item [lindex $list1 $cursor]
puts "@jvar@ $item"
incr cursor
@incr i@
@incr j@
}
}
none - default {
if {$usecontext} {
if {${need context} != 0} {
if {${need context} < 0} {
upvar 0 xidx thisidx list1 thislist
set cursor $xidx
} else {
upvar 0 yidx thisidx list2 thislist
set cursor $yidx
}
= thisend {$thisidx + $context}
while {$cursor < $thisend} {
set item [lindex $thislist $cursor]
incr cursor
puts " $item"
}
}
= xstart {$xidx + $length - $context}
= xend {$xidx + $length - 1}
set priorcontext [lrange $list1 $xstart $xend]
}
incr i $length
incr j $length
}
}
= xcursor {$xidx + $length}
= ycursor {$yidx + $length}
}
}
set replacements {
{@initialize i@} {set i [expr {$xcursor + $firstnum}]}
{@initialize j@} {set j [expr {$ycursor + $firstnum}]}
{@incr i@} {incr i}
{@incr j@} {incr j}
{@ivar@} {$i }
{@jvar@} {$j }
}
if {!$numbers} {
merge replacements {
{@initialize i@} {}
{@incr i@} {}
{@ivar@} {}
{@jvar@} {}
}
}
map {*}$replacements script
try $script
}
proc lcs {x y} {
set map {}
set found {}
set {chosen length} 0
set xlen [llength $x]
set ylen [llength $y]
set i 0
foreach item $x {
dict lappend map $item $i
incr i
}
set yidx -1
foreach item $y {
incr yidx
if {[dict exists $map $item]} {
set len1 1
set xmap [dict get $map $item]
{trim indices} xmap $xlen ${chosen length}
dict set map $item $xmap
for {set i 0} {$i < [llength $xmap]} {incr i} {
set xidx [lindex $xmap $i]
set xidxend $xidx
set yidxend $yidx
set len1 0
while {$xidxend < $xlen && $yidxend < $ylen} {
set xval [lindex $x $xidxend]
set yval [lindex $y $yidxend]
if {$xval eq $yval} {
incr len1
incr xidxend
incr yidxend
} else {
if {$len1 > ${chosen length}
|| ${chosen length} == 0} {
set {chosen length} $len1
{trim indices} xmap $xlen ${chosen length}
dict set map $item $xmap
set found [list $xidx $yidx $len1]
}
break
}
}
if {$len1 > ${chosen length}
|| ${chosen length} == 0} {
set {chosen length} $len1
{trim indices} xmap $xlen ${chosen length}
dict set map $item $xmap
set found [list $xidx $yidx $len1]
}
}
}
}
return $found
}
dict set doc procs lcsmatch {
description {
finds the first longest common subseqence in $x and $y
iteratively searches before and after the longest common
subsequence for another longest common subseqence and continues the
process until no additional common subsequences are found
returns a list of the found common subsequences
none of which overlap
}
}
proc lcsmatch {x y} {
set xlength [llength $x]
set ylength [llength $y]
set xcursor 0
set ycursor 0
set res {}
lappend queue [lcs $x $y]
lappend queue [list [llength $x] [llength $y] 0]
while {[llength $queue]} {
set item [lindex $queue 0]
lassign $item xidx yidx len
if {$xidx <= $xcursor} {
take queue item
lappend res $item
= xcursor {$xidx + $len}
= ycursor {$yidx + $len}
continue
}
= xend {$xidx - 1}
= yend {$yidx - 1}
set x2 [lrange $x $xcursor $xend]
set y2 [lrange $y $ycursor $yend]
set found [lcs $x2 $y2]
if {[llength $found]} {
{adjust indices} found $xcursor $ycursor
linsert queue 0 $found
} else {
take queue item
lappend res $item
= xcursor {[lindex $item 0] + [lindex $item 2]}
= ycursor {[lindex $item 1] + [lindex $item 2]}
}
}
# get rid of the synthetic entry that marked the end of the list
lreplace res end end
return $res
}
proc {adjust indices} {listvar xcursor ycursor } {
upvar 1 $listvar list
lassign $list xstart ystart len
= xstart {$xstart + $xcursor}
= ystart {$ystart + $ycursor}
set list [list $xstart $ystart $len]
return
}
proc {trim indices} {indicesvar length min} {
upvar $indicesvar indices
= cutoff {$length - $min}
set lastidx [lsearch -bisect -integer $indices $cutoff]
set indices [lrange $indices[set indices {}] 0 $lastidx]
}
imports [namespace parent] [namespace current] {
diff
{{diff file}}
lcs
lcsmatch
}
}