Patch title: Release 85 bulk changes
Abstract:
File: /pliant/appli/forum/difference.pli
Key:
    Removed line
    Added line
module "/pliant/language/unsafe.pli"
module "/pliant/language/context.pli"
module "/pliant/language/stream.pli"
module "/pliant/admin/file.pli"


#-------------------------------------------------------------------------
#  Longuest Common Substring computation algorithm


if pliant_debugging_level>=2
  function lcs_check a b m lcs
    arg Array:Int a b m ; arg Int lcs
    check m:size=a:size+1
    var Int maxi := -1 ; var Int n := 0
    for (var Int i) 0 a:size-1
      if m:i=defined
        check (b m:i)=a:i
        var Int mi := m i
        check m:i>maxi
        maxi := m i
        n += 1
    check n=lcs or lcs=undefined
    check (m a:size)=b:size


doc
  [On return of 'lcs_compute' 'm' will map positions in 'a' to positions in 'b']

constant verbose false

type TwoInt
  field Int i j

function lcs_compute a b m
  arg Array:Int a b ; arg_w Array:Int m
  if verbose
    console "      "
    for (var Int i) 0 a:size-1
      console (right (string a:i) 3 " ") " "
    console eol
    console "     " (repeat a:size "----") eol
  (var (Array List:TwoInt) trans) size := a:size+1
  (var Array:Int last) size := a:size+1
  for (var Int i) 0 a:size
    last i := 0
  (var Array:Int cur) size := a:size+1
  cur 0 := 0
  for (var Int j) 0 b:size-1
    var Int c := b j
    for (var Int i) 0 a:size-1
      var Int v := max (last i+1) cur:i
      if a:i=c and last:i=v
        v += 1
        var TwoInt t ; t i := i ; t j := j ; trans v += t
      cur i+1 := v 
    if verbose
      console (right (string b:j) 3 " ") " | "
      for (var Int i) 1 a:size
        console (right (string cur:i) 3 " ") " "
      console eol
    swap last cur
  m size := a:size+1 ; m a:size := b size
  for (var Int i) 0 a:size-1
    m i := undefined
  var TwoInt limit ; limit i := a size ; limit j := b size
  var Int v := last a:size
  while v>0
    var Pointer:TwoInt p :> trans:v first
    while p:i>=limit:i or p:j>=limit:j
      p :> trans:v next p
    m p:i := p j
    limit := p
    v -= 1
  if verbose
    console "     " (repeat a:size "----") eol
    console "      "
    for (var Int i) 0 a:size-1
      console (right (string m:i) 3 " ") " "
    console eol
  if pliant_debugging_level>=2
    lcs_check a b m (last a:size)


doc
  [If both files are long, computation can be very long since the complexity is the product of the number of lines. ]
  [In such a case, we try to find an as long as possible matching area near the middle of the first file, then we compute the beginning on one side, and the end on another, thus significantly reducing the overall computation cost.]

function lcs_fast_compute a b m 
  arg Array:Int a b ; arg_w Array:Int m
  if a:size*b:size<2^20 # resonably small computation
    lcs_compute a b m
    return
  # search for unique lines (appearing only onces in both 'a' and 'b')
  var Int maxi := 0
  for (var Int i) 0 a:size-1
    maxi := max maxi a:i
  for (var Int j) 0 b:size-1
    maxi := max maxi b:j
  (var Array:Int ca) size := maxi+1
  for (var Int u) 0 maxi
    ca u := 0
  var Array:Int cb := ca
  for (var Int i) 0 a:size-1
    ca a:i += 1
  for (var Int j) 0 b:size-1
    cb b:j += 1
  # find corresponding unique line in 'b'
  var (Dictionary Int Int) dict
  for (var Int j) 0 b:size-1
    if (ca b:j)=1 and (cb b:j)=1
      dict insert b:j j
  # search for the longuest match of 'a' and 'b' near the middle
  var Int best := 0 ; var Int besti := undefined ; var Int bestj := undefined
  var Int n := 0
  var Int j := 0
  for (var Int i) a:size\4 a:size*3\4
    if a:i=b:j
      n += 1
    eif (ca a:i)=1 and (cb a:i)=1
      j := dict a:i ; check a:i=b:j
      n := 1
    else
      n := 0
    if n>best
      best := n ; besti := i-n+1 ; bestj := j-n+1
    if j<b:size
      j += 1
  if best<3 # no significant match
    lcs_compute a b m
    return
  # compute the LCS for the beginning
  (var Array:Int aa) size := besti
  for (var Int i) 0 aa:size-1
    aa i := a i
  (var Array:Int bb) size := bestj
  for (var Int j) 0 bb:size-1
    bb j := b j
  lcs_fast_compute aa bb (var Array:Int mm)
  m size := a:size+1 ; m a:size := b size
  for (var Int i) 0 besti-1
    m i := mm i
  # handling the middle part is trivial
  for (var Int i) besti besti+best-1
    m i := i+bestj-besti
  # compute the LCS for the end
  besti += best ; bestj += best
  (var Array:Int aa) size := a:size-besti
  for (var Int i) 0 aa:size-1
    aa i := a besti+i
  (var Array:Int bb) size := b:size-bestj
  for (var Int j) 0 bb:size-1
    bb j := b bestj+j
  lcs_fast_compute aa bb (var Array:Int mm)
  for (var Int i) 0 a:size-besti-1
    m besti+i := shunt mm:i=defined bestj+mm:i undefined
  # done
  if pliant_debugging_level>=2
    lcs_check a b m undefined


#-------------------------------------------------------------------------
#  Map changes to a third sequence


constant flag_num1    0*2^29
constant flag_num2    1*2^29
constant flag_current 2*2^29
constant flag_mask    3*2^29

function copy a i b j flag n
  arg Array:Int a ; arg_rw Int i ; arg_rw Array:Int b ; arg_rw Int j ; arg Int flag n
  for (var Int u) 0 n-1
    b j := flag+i
    i += 1 ; j += 1

function similar a i b j n -> c
  arg Array:Int a ; arg Int i ; arg Array:Int b ; arg Int j n ; arg CBool c
  if i+n>a:size or j+n>b:size
    return false
  for (var Int u) 0 n-1
    if (a i+u)<>(b j+u)
      return false
  c := true

function patch_apply num1 num2 current final rejected -> status
  arg Array:Int num1 num2 current ; arg_w Array:Int final rejected ; arg Status status
  status := success
  lcs_fast_compute num1 num2 (var Array:Int patch)
  var Int l := 0
  for (var Int i) 0 num1:size-1
    if patch:i=defined
      l += 1
  final size := current:size+(num1:size+num2:size-2*l)
  rejected size := num1:size+(num1:size+num2:size-2*l)
  lcs_fast_compute num1 current (var Array:Int map)
  var Int i1 := 0 ; var Int i2 := 0
  var Int c := 0 ; var Int f := 0
  var Int o := 0 ; var Int r := 0
  while i1<num1:size or i2<num2:size
    if patch:i1=i2
      i1 += 1 ; i2 += 1
    else
      var Int next1 := i1
      while patch:next1=undefined
        next1 += 1
      var Int next2 := patch next1
      # we have a change num1[i1,next1[ to num2[i2,next2[ to apply
      copy num1 o rejected r flag_num1 i1-o
      var Int nextc := map i1
      if nextc=defined and (similar current nextc num1 i1 next1-i1) # apply
        copy current c final f flag_current nextc-c
        copy num2 i2 final f flag_num2 next2-i2 ; c += next1-i1
        copy num1 o rejected r flag_num1 next1-i1
      else
        copy num2 i2 rejected r flag_num2 next2-i2 ; o += next1-i1
        status := failure
      i1 := next1 ; i2 := next2
  copy current c final f flag_current current:size-c
  final size := f
  copy num1 o rejected r flag_num1 num1:size-o
  rejected size := r


#--------------------------------------------------------------------------
# file patch


function file_is_ascii f -> c
  arg Str f ; arg CBool c
  (var Stream s) open f in+safe
  var Int line := 0
  while not s:atend
    s read_available (var Address adr) (var Int size)
    for (var Int i) 0 size-1
      if ((adr translate Byte i) map uInt8)<8
        return false
      if ((adr translate Byte i) map uInt8)="[lf]":0:number
        line := 0
      else
        line += 1
        if line>=4096
          return false
  c := true


function load_file file -> lines
  arg Str file ; arg Array:Str lines
  (var Stream s) open file in+safe
  var List:Str list ; var Int count := 0
  while not s:atend
    list += s readline ; count +=1
  lines size := count
  var Pointer:Str l :> list first ; var Int i := 0
  while exists:l
    lines i := l ; i += 1
    l :> list next l
  check i=count

function store_file lines s
  arg List:Str lines ; arg_rw Stream s
  var Pointer:Str l :> lines first
  while exists:l
    s writeline l
    l :> lines next l

function convert_to_numbers lines nums dict base
  arg Array:Str lines ; arg_w Array:Int nums ; arg_rw (Dictionary Str Int) dict ; arg Int base
  nums size := lines:size
  for (var Int i) 0 lines:size-1
    var Pointer:Int p :> dict first lines:i
    if exists:p
      nums i := p
    else
      nums i := base+i
      dict insert lines:i base+i

function file_difference file1 file2 patch force sections -> different
  arg Str file1 file2 patch ; arg CBool force ; arg (Index Int Str) sections ; arg CBool different
  var FileInfo q1 := file_query file1 standard
  var FileInfo q2 := file_query file2 standard
  if not file_is_ascii:file1 or not file_is_ascii:file2
    (var Stream s) open patch out+safe+mkdir
    s writeline "Pliant difference"
    s writeline "old_datetime: "+(string q1:datetime)
    s writeline "old_size: "+(string q1:size)
    s writeline "new_datetime: "+(string q2:datetime)
    s writeline "new_size: "+(string q2:size)
    s writeline "encoding: binary"
    s writeline ""
    different := force or q1:size<>q2:size ; var Address buffer := null ; var Int reserved := 0
    var Intn remain := q1 size
    (var Stream s1) open file1 in+safe
    if not different
      (var Stream s2) open file2 in+safe
    while remain>0
      s1 read_available (var Address adr) (var Int size) (shunt remain>2^20 2^20 (cast remain Int))
      s raw_write adr size
      if not different
        if size>reserved
          buffer := memory_resize buffer size null ; reserved := size
        s2 raw_read buffer size
        if (memory_different adr size buffer size)
          different := true
      remain -= size
    memory_free buffer
    if not different
      s close
      file_delete patch
      return false
    var Intn remain := q2 size
    (var Stream s2) open file2 in+safe
    while remain>0
      s2 read_available (var Address adr) (var Int size) (shunt remain>2^20 2^20 (cast remain Int))
      s raw_write adr size
      remain -= size
    s close
  else
    var Array:Str lines1 := load_file file1
    var Array:Str lines2 := load_file file2
    if not force and lines1:size=lines2:size
      part same
        for (var Int i) 0 lines1:size-1
          if lines1:i<>lines2:i
            leave same
        return false
    # convert lines to numbers
    var (Dictionary Str Int) dict
    convert_to_numbers lines1 (var Array:Int num1) dict 0
    convert_to_numbers lines2 (var Array:Int num2) dict lines1:size
    # compute lines mapping 'map'
    part diff "compute files difference"
      lcs_fast_compute num1 num2 (var Array:Int map)
    # build diff lines list in 'diff'
    var List:Str diff
    var Int changes_count := 0
    var Int changed_lines := 0
    var Int i1 := 0 ; var Int i2 := 0
    while i1<lines1:size or i2<lines2:size
      if map:i1=i2
        diff += "  "+lines1:i1
        i1 += 1 ; i2 += 1
      else
        if exists:sections and exists:(sections first i1)
          diff += ": "+sections:i1
        var Int next1 := i1
        while next1<lines1:size and map:next1=undefined
          next1 += 1
        var Int next2 := map next1
        changes_count += 1
        changed_lines += max next1-i1 next2-i2
        while i1<next1
          diff += "- "+lines1:i1
          i1 += 1
        while i2<next2
          diff += "+ "+lines2:i2
          i2 += 1
    # write result down
    (var Stream s) open patch out+safe+mkdir
    s writeline "Pliant difference"
    s writeline "old_datetime: "+(string q1:datetime)
    s writeline "old_size: "+(string q1:size)
    s writeline "new_datetime: "+(string q2:datetime)
    s writeline "new_size: "+(string q2:size)
    s writeline "encoding: ascii"
    s writeline "changes_count: "+string:changes_count
    s writeline "changed_lines: "+string:changed_lines
    s writeline ""
    store_file diff s
    s close
  different := true

function file_difference file1 file2 patch
  arg Str file1 file2 patch
  file_difference file1 file2 patch true (null map (Index Int Str))


function file_header patch h1 h2 binary lines sections
  arg Str patch ; arg_w FileInfo h1 h2 ; arg_w CBool binary ; arg_w Int lines ; arg_w List:Str sections
  h1 datetime := undefined ; h1 size := undefined
  h2 datetime := undefined ; h2 size := undefined
  binary := false
  lines := 0
  sections := var List:Str empty_list
  (var Stream s) open patch in+safe
  while not s:atend and { var Str l := s readline ; l<>"" }
    if (l parse "old_datetime" ":" (var DateTime dt))
      h1 datetime := dt
    eif (l parse "old_size" ":" (var Intn nn))
      h1 size := nn
    eif (l parse "new_datetime" ":" (var DateTime dt))
      h2 datetime := dt
    eif (l parse "new_size" ":" (var Intn nn))
      h2 size := nn
    eif (l parse "encoding" ":" "binary")
      binary := true
    eif (l parse "changed_lines" ":" (var Int n))
      lines := n
    eif (l parse "section" ":" any:(var Str str))
      sections += str

function file_header patch h1 h2 binary lines
  arg Str patch ; arg_w FileInfo h1 h2 ; arg_w CBool binary ; arg_w Int lines
  file_header patch h1 h2 binary lines (var List:Str sections)
  
function file_extract patch new section file sections -> some_changes
  arg Str patch file ; arg CBool new ; arg Str section file ; arg_w (Index Int Str) sections ; arg CBool some_changes
  some_changes := false
  var CBool binary := false
  (var Stream s) open patch in+safe
  var DateTime old_datetime := undefined ; var Intn old_size := 0
  var DateTime new_datetime := undefined ; var Intn new_size := 0
  var CBool binary := false
  while not s:atend and { var Str l := s readline ; l<>"" }
    if (l parse "old_datetime" ":" (var DateTime dt))
      old_datetime := dt
    eif (l parse "old_size" ":" (var Intn nn))
      old_size := nn
    eif (l parse "new_datetime" ":" (var DateTime dt))
      new_datetime := dt
    eif (l parse "new_size" ":" (var Intn nn))
      new_size := nn
    eif (l parse "encoding" ":" "binary")
      binary := true
  if exists:sections
    sections := var (Index Int Str) empty_sections
  (var Stream d) open file out+safe
  if binary
    if new and section=""
      var Intn remain := old_size
      while remain>0
        s read_available (var Address adr) (var Int size) (shunt remain>2^20 2^20 (cast remain Int))
        remain -= size
      some_changes := true
    var Intn remain := shunt new new_size old_size
    while remain>0
      s read_available (var Address adr) (var Int size) (shunt remain>2^20 2^20 (cast remain Int))
      d raw_write adr size
      remain -= size
  else
    var Str current := ""
    var Int line_number := 0
    while not s:atend
      var Str l := s readline
      if (l 0 2)=": "
        current := l 2 l:len
        if exists:sections
          sections insert line_number current
      eif (l 0 2)="  "
        d writeline (l 2 l:len)
        line_number += 1
      eif (l 0 2)=(shunt new and (section="" or current=section) "+ " "- ")
        if (l 0 2)="+ "
          some_changes := true
        d writeline (l 2 l:len)
        line_number += 1
      if (l 0 2)="  "
        current := ""
  d close
  file_configure file "datetime "+string:(shunt new new_datetime old_datetime)

function file_extract patch new section file -> some_changes
  arg Str patch file ; arg CBool new ; arg Str section file ; arg CBool some_changes
  some_changes := file_extract patch new section file (null map (Index Int Str)) 

function file_extract_old patch file
  arg Str patch file
  file_extract patch false "" file

function file_extract_new patch file
  arg Str patch file
  file_extract patch true "" file


function store_file a lines1 lines2 current file
  arg Array:Int a ; arg Array:Str lines1 lines2 current ; arg Str file
  (var Stream s) open file out+safe+mkdir
  for (var Int i) 0 a:size-1
    var Int flag := a:i .and. flag_mask
    var Int index := a:i-flag
    var Pointer:Str l
    if flag=flag_num1
      l :> lines1 index
    eif flag=flag_num2
      l :> lines2 index
    eif flag=flag_current
      l :> current index
    else
      l :> null map Str
    if exists:l
      s writeline l

function file_patch_apply patch section current final rejected -> status
  arg Str patch section current final rejected ; arg Status status
  file_header patch (var FileInfo h1) (var FileInfo h2) (var CBool binary) (var Int lines)
  if not file_is_ascii:current or binary
    if section<>""
      status := failure
    eif h1:datetime=(file_query current standard):datetime
      file_extract_new patch final
      status := success
    else
      file_copy current final
      file_extract_new patch rejected
      status := failure
  else
    var Str temp := file_temporary
    file_extract patch true section temp ; var Array:Str lines2 := load_file temp
    file_extract patch false section temp ; var Array:Str lines1 := load_file temp
    var Array:Str curlines := load_file current
    # convert lines to numbers
    var (Dictionary Str Int) dict
    convert_to_numbers lines1 (var Array:Int num1) dict 0
    convert_to_numbers lines2 (var Array:Int num2) dict lines1:size
    convert_to_numbers curlines (var Array:Int cur) dict lines1:size+lines2:size
    # try to apply
    part apply "apply patch"
      status := patch_apply num1 num2 cur (var Array:Int fin) (var Array:Int rej)
    # write result down
    if final<>""
      store_file fin lines1 lines2 curlines final
    if status=failure and rejected<>""
      var Str temp2 := file_temporary
      store_file rej lines1 lines2 curlines temp2
      file_tree_create rejected
      file_difference temp temp2 rejected
      file_delete temp2
    file_delete temp


export file_is_ascii
export file_difference file_header file_extract file_extract_old file_extract_new
export file_patch_apply