/pliant/appli/forum/difference.pli
1	module "/pliant/language/unsafe.pli"
2	module "/pliant/language/context.pli"
3	module "/pliant/language/stream.pli"
4	module "/pliant/admin/file.pli"
5
6
7
8	#  Longuest Common Substring computation algorithm
9
10
11	if pliant_debugging_level>=2
12	function lcs_check a b m lcs
13	arg Array:Int a b m ; arg Int lcs
14	check m:size=a:size+1
15	var Int maxi := -1 ; var Int n := 0
16	for (var Int i) 0 a:size-1
17	if m:i=defined
18	check (b m:i)=a:i
19	var Int mi := m i
20	check m:i>maxi
21	maxi := m i
22	n += 1
23	check n=lcs or lcs=undefined
24	check (m a:size)=b:size
25
26
27	doc
28	[On return of 'lcs_compute' 'm' will map positions in 'a' to positions in 'b']
29
30	constant verbose false
31
32	type TwoInt
33	field Int i j
34
35	function lcs_compute a b m
36	arg Array:Int a b ; arg_w Array:Int m
37	if verbose
38	console "      "
39	for (var Int i) 0 a:size-1
40	console (right (string a:i) 3 " ") " "
41	console eol
42	console "     " (repeat a:size "----") eol
43	(var (Array List:TwoInt) trans) size := a:size+1
44	(var Array:Int last) size := a:size+1
45	for (var Int i) 0 a:size
46	last i := 0
47	(var Array:Int cur) size := a:size+1
48	cur 0 := 0
49	for (var Int j) 0 b:size-1
50	var Int c := b j
51	for (var Int i) 0 a:size-1
52	var Int v := max (last i+1) cur:i
53	if a:i=c and last:i=v
54	v += 1
55	var TwoInt t ; t i := i ; t j := j ; trans v += t
56	cur i+1 := v
57	if verbose
58	console (right (string b:j) 3 " ") " | "
59	for (var Int i) 1 a:size
60	console (right (string cur:i) 3 " ") " "
61	console eol
62	swap last cur
63	m size := a:size+1 ; m a:size := b size
64	for (var Int i) 0 a:size-1
65	m i := undefined
66	var TwoInt limit ; limit i := a size ; limit j := b size
67	var Int v := last a:size
68	while v>0
69	var Pointer:TwoInt p :> trans:v first
70	while p:i>=limit:i or p:j>=limit:j
71	p :> trans:v next p
72	m p:i := p j
73	limit := p
74	v -= 1
75	if verbose
76	console "     " (repeat a:size "----") eol
77	console "      "
78	for (var Int i) 0 a:size-1
79	console (right (string m:i) 3 " ") " "
80	console eol
81	if pliant_debugging_level>=2
82	lcs_check a b m (last a:size)
83
84
85	doc
86	[If both files are long, computation can be very long since the complexity is the product of the number of lines. ]
87	[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.]
88
89	function lcs_fast_compute a b m
90	arg Array:Int a b ; arg_w Array:Int m
91	if a:size*b:size<2^20 # resonably small computation
92	lcs_compute a b m
93	return
94	# search for unique lines (appearing only onces in both 'a' and 'b')
95	var Int maxi := 0
96	for (var Int i) 0 a:size-1
97	maxi := max maxi a:i
98	for (var Int j) 0 b:size-1
99	maxi := max maxi b:j
100	(var Array:Int ca) size := maxi+1
101	for (var Int u) 0 maxi
102	ca u := 0
103	var Array:Int cb := ca
104	for (var Int i) 0 a:size-1
105	ca a:i += 1
106	for (var Int j) 0 b:size-1
107	cb b:j += 1
108	# find corresponding unique line in 'b'
109	var (Dictionary Int Int) dict
110	for (var Int j) 0 b:size-1
111	if (ca b:j)=1 and (cb b:j)=1
112	dict insert b:j j
113	# search for the longuest match of 'a' and 'b' near the middle
114	var Int best := 0 ; var Int besti := undefined ; var Int bestj := undefined
115	var Int n := 0
116	var Int j := 0
117	for (var Int i) a:size\4 a:size*3\4
118	if a:i=b:j
119	n += 1
120	eif (ca a:i)=1 and (cb a:i)=1
121	j := dict a:i ; check a:i=b:j
122	n := 1
123	else
124	n := 0
125	if n>best
126	best := n ; besti := i-n+1 ; bestj := j-n+1
127	if j<b:size
128	j += 1
129	if best<3 # no significant match
130	lcs_compute a b m
131	return
132	# compute the LCS for the beginning
133	(var Array:Int aa) size := besti
134	for (var Int i) 0 aa:size-1
135	aa i := a i
136	(var Array:Int bb) size := bestj
137	for (var Int j) 0 bb:size-1
138	bb j := b j
139	lcs_fast_compute aa bb (var Array:Int mm)
140	m size := a:size+1 ; m a:size := b size
141	for (var Int i) 0 besti-1
142	m i := mm i
143	# handling the middle part is trivial
144	for (var Int i) besti besti+best-1
145	m i := i+bestj-besti
146	# compute the LCS for the end
147	besti += best ; bestj += best
148	(var Array:Int aa) size := a:size-besti
149	for (var Int i) 0 aa:size-1
150	aa i := a besti+i
151	(var Array:Int bb) size := b:size-bestj
152	for (var Int j) 0 bb:size-1
153	bb j := b bestj+j
154	lcs_fast_compute aa bb (var Array:Int mm)
155	for (var Int i) 0 a:size-besti-1
156	m besti+i := shunt mm:i=defined bestj+mm:i undefined
157	# done
158	if pliant_debugging_level>=2
159	lcs_check a b m undefined
160
161
162
163	#  Map changes to a third sequence
164
165
166	constant flag_num1    0*2^29
167	constant flag_num2    1*2^29
168	constant flag_current 2*2^29
169	constant flag_mask    3*2^29
170
171	function copy a i b j flag n
172	arg Array:Int a ; arg_rw Int i ; arg_rw Array:Int b ; arg_rw Int j ; arg Int flag n
173	for (var Int u) 0 n-1
174	b j := flag+i
175	i += 1 ; j += 1
176
177	function similar a i b j n -> c
178	arg Array:Int a ; arg Int i ; arg Array:Int b ; arg Int j n ; arg CBool c
179	if i+n>a:size or j+n>b:size
180	return false
181	for (var Int u) 0 n-1
182	if (a i+u)<>(b j+u)
183	return false
184	c := true
185
186	function patch_apply num1 num2 current final rejected -> status
187	arg Array:Int num1 num2 current ; arg_w Array:Int final rejected ; arg Status status
188	status := success
189	lcs_fast_compute num1 num2 (var Array:Int patch)
190	var Int l := 0
191	for (var Int i) 0 num1:size-1
192	if patch:i=defined
193	l += 1
194	final size := current:size+(num1:size+num2:size-2*l)
195	rejected size := num1:size+(num1:size+num2:size-2*l)
196	lcs_fast_compute num1 current (var Array:Int map)
197	var Int i1 := 0 ; var Int i2 := 0
198	var Int c := 0 ; var Int f := 0
199	var Int o := 0 ; var Int r := 0
200	while i1<num1:size or i2<num2:size
201	if patch:i1=i2
202	i1 += 1 ; i2 += 1
203	else
204	var Int next1 := i1
205	while patch:next1=undefined
206	next1 += 1
207	var Int next2 := patch next1
208	# we have a change num1[i1,next1[ to num2[i2,next2[ to apply
209	copy num1 o rejected r flag_num1 i1-o
210	var Int nextc := map i1
211	if nextc=defined and (similar current nextc num1 i1 next1-i1) # apply
212	copy current c final f flag_current nextc-c
213	copy num2 i2 final f flag_num2 next2-i2 ; c += next1-i1
214	copy num1 o rejected r flag_num1 next1-i1
215	else
216	copy num2 i2 rejected r flag_num2 next2-i2 ; o += next1-i1
217	status := failure
218	i1 := next1 ; i2 := next2
219	copy current c final f flag_current current:size-c
220	final size := f
221	copy num1 o rejected r flag_num1 num1:size-o
222	rejected size := r
223
224
225
226	# file patch
227
228
229	function file_is_ascii f -> c
230	arg Str f ; arg CBool c
231	(var Stream s) open f in+safe
232	var Int line := 0
233	while not s:atend
234	s read_available (var Address adr) (var Int size)
235	for (var Int i) 0 size-1
236	if ((adr translate Byte i) map uInt8)<8
237	return false
238	if ((adr translate Byte i) map uInt8)="[lf]":0:number
239	line := 0
240	else
241	line += 1
242	if line>=4096
243	return false
244	c := true
245
246
247	function load_file file -> lines
248	arg Str file ; arg Array:Str lines
249	(var Stream s) open file in+safe
250	var List:Str list ; var Int count := 0
251	while not s:atend
252	list += s readline ; count +=1
253	lines size := count
254	var Pointer:Str l :> list first ; var Int i := 0
255	while exists:l
256	lines i := l ; i += 1
257	l :> list next l
258	check i=count
259
260	function store_file lines s
261	arg List:Str lines ; arg_rw Stream s
262	var Pointer:Str l :> lines first
263	while exists:l
264	s writeline l
265	l :> lines next l
266
267	function convert_to_numbers lines nums dict base
268	arg Array:Str lines ; arg_w Array:Int nums ; arg_rw (Dictionary Str Int) dict ; arg Int base
269	nums size := lines:size
270	for (var Int i) 0 lines:size-1
271	var Pointer:Int p :> dict first lines:i
272	if exists:p
273	nums i := p
274	else
275	nums i := base+i
276	dict insert lines:i base+i
277
278	function file_difference file1 file2 patch force sections -> different
279	arg Str file1 file2 patch ; arg CBool force ; arg (Index Int Str) sections ; arg CBool different
280	var FileInfo q1 := file_query file1 standard
281	var FileInfo q2 := file_query file2 standard
282	if not file_is_ascii:file1 or not file_is_ascii:file2
283	(var Stream s) open patch out+safe+mkdir
284	s writeline "Pliant difference"
285	s writeline "old_datetime: "+(string q1:datetime)
286	s writeline "old_size: "+(string q1:size)
287	s writeline "new_datetime: "+(string q2:datetime)
288	s writeline "new_size: "+(string q2:size)
289	s writeline "encoding: binary"
290	s writeline ""
291	different := force or q1:size<>q2:size ; var Address buffer := null ; var Int reserved := 0
292	var Intn remain := q1 size
293	(var Stream s1) open file1 in+safe
294	if not different
295	(var Stream s2) open file2 in+safe
296	while remain>0
297	s1 read_available (var Address adr) (var Int size) (shunt remain>2^20 2^20 (cast remain Int))
298	s raw_write adr size
299	if not different
300	if size>reserved
301	buffer := memory_resize buffer size null ; reserved := size
302	s2 raw_read buffer size
303	if (memory_different adr size buffer size)
304	different := true
305	remain -= size
306	memory_free buffer
307	if not different
308	s close
309	file_delete patch
310	return false
311	var Intn remain := q2 size
312	(var Stream s2) open file2 in+safe
313	while remain>0
314	s2 read_available (var Address adr) (var Int size) (shunt remain>2^20 2^20 (cast remain Int))
315	s raw_write adr size
316	remain -= size
317	s close
318	else
319	var Array:Str lines1 := load_file file1
320	var Array:Str lines2 := load_file file2
321	if not force and lines1:size=lines2:size
322	part same
323	for (var Int i) 0 lines1:size-1
324	if lines1:i<>lines2:i
325	leave same
326	return false
327	# convert lines to numbers
328	var (Dictionary Str Int) dict
329	convert_to_numbers lines1 (var Array:Int num1) dict 0
330	convert_to_numbers lines2 (var Array:Int num2) dict lines1:size
331	# compute lines mapping 'map'
332	part diff "compute files difference"
333	lcs_fast_compute num1 num2 (var Array:Int map)
334	# build diff lines list in 'diff'
335	var List:Str diff
336	var Int changes_count := 0
337	var Int changed_lines := 0
338	var Int i1 := 0 ; var Int i2 := 0
339	while i1<lines1:size or i2<lines2:size
340	if map:i1=i2
341	diff += "  "+lines1:i1
342	i1 += 1 ; i2 += 1
343	else
344	if exists:sections and exists:(sections first i1)
345	diff += ": "+sections:i1
346	var Int next1 := i1
347	while next1<lines1:size and map:next1=undefined
348	next1 += 1
349	var Int next2 := map next1
350	changes_count += 1
351	changed_lines += max next1-i1 next2-i2
352	while i1<next1
353	diff += "- "+lines1:i1
354	i1 += 1
355	while i2<next2
356	diff += "+ "+lines2:i2
357	i2 += 1
358	# write result down
359	(var Stream s) open patch out+safe+mkdir
360	s writeline "Pliant difference"
361	s writeline "old_datetime: "+(string q1:datetime)
362	s writeline "old_size: "+(string q1:size)
363	s writeline "new_datetime: "+(string q2:datetime)
364	s writeline "new_size: "+(string q2:size)
365	s writeline "encoding: ascii"
366	s writeline "changes_count: "+string:changes_count
367	s writeline "changed_lines: "+string:changed_lines
368	s writeline ""
369	store_file diff s
370	s close
371	different := true
372
373	function file_difference file1 file2 patch
374	arg Str file1 file2 patch
375	file_difference file1 file2 patch true (null map (Index Int Str))
376
377
378	function file_header patch h1 h2 binary lines sections
379	arg Str patch ; arg_w FileInfo h1 h2 ; arg_w CBool binary ; arg_w Int lines ; arg_w List:Str sections
380	h1 datetime := undefined ; h1 size := undefined
381	h2 datetime := undefined ; h2 size := undefined
382	binary := false
383	lines := 0
384	sections := var List:Str empty_list
385	(var Stream s) open patch in+safe
386	while not s:atend and { var Str l := s readline ; l<>"" }
387	if (l parse "old_datetime" ":" (var DateTime dt))
388	h1 datetime := dt
389	eif (l parse "old_size" ":" (var Intn nn))
390	h1 size := nn
391	eif (l parse "new_datetime" ":" (var DateTime dt))
392	h2 datetime := dt
393	eif (l parse "new_size" ":" (var Intn nn))
394	h2 size := nn
395	eif (l parse "encoding" ":" "binary")
396	binary := true
397	eif (l parse "changed_lines" ":" (var Int n))
398	lines := n
399	eif (l parse "section" ":" any:(var Str str))
400	sections += str
401
402	function file_header patch h1 h2 binary lines
403	arg Str patch ; arg_w FileInfo h1 h2 ; arg_w CBool binary ; arg_w Int lines
404	file_header patch h1 h2 binary lines (var List:Str sections)
405
406	function file_extract patch new section file sections -> some_changes
407	arg Str patch file ; arg CBool new ; arg Str section file ; arg_w (Index Int Str) sections ; arg CBool some_changes
408	some_changes := false
409	var CBool binary := false
410	(var Stream s) open patch in+safe
411	var DateTime old_datetime := undefined ; var Intn old_size := 0
412	var DateTime new_datetime := undefined ; var Intn new_size := 0
413	var CBool binary := false
414	while not s:atend and { var Str l := s readline ; l<>"" }
415	if (l parse "old_datetime" ":" (var DateTime dt))
416	old_datetime := dt
417	eif (l parse "old_size" ":" (var Intn nn))
418	old_size := nn
419	eif (l parse "new_datetime" ":" (var DateTime dt))
420	new_datetime := dt
421	eif (l parse "new_size" ":" (var Intn nn))
422	new_size := nn
423	eif (l parse "encoding" ":" "binary")
424	binary := true
425	if exists:sections
426	sections := var (Index Int Str) empty_sections
427	(var Stream d) open file out+safe
428	if binary
429	if new and section=""
430	var Intn remain := old_size
431	while remain>0
432	s read_available (var Address adr) (var Int size) (shunt remain>2^20 2^20 (cast remain Int))
433	remain -= size
434	some_changes := true
435	var Intn remain := shunt new new_size old_size
436	while remain>0
437	s read_available (var Address adr) (var Int size) (shunt remain>2^20 2^20 (cast remain Int))
438	d raw_write adr size
439	remain -= size
440	else
441	var Str current := ""
442	var Int line_number := 0
443	while not s:atend
444	var Str l := s readline
445	if (l 0 2)=": "
446	current := l 2 l:len
447	if exists:sections
448	sections insert line_number current
449	eif (l 0 2)="  "
450	d writeline (l 2 l:len)
451	line_number += 1
452	eif (l 0 2)=(shunt new and (section="" or current=section) "+ " "- ")
453	if (l 0 2)="+ "
454	some_changes := true
455	d writeline (l 2 l:len)
456	line_number += 1
457	if (l 0 2)="  "
458	current := ""
459	d close
460	file_configure file "datetime "+string:(shunt new new_datetime old_datetime)
461
462	function file_extract patch new section file -> some_changes
463	arg Str patch file ; arg CBool new ; arg Str section file ; arg CBool some_changes
464	some_changes := file_extract patch new section file (null map (Index Int Str))
465
466	function file_extract_old patch file
467	arg Str patch file
468	file_extract patch false "" file
469
470	function file_extract_new patch file
471	arg Str patch file
472	file_extract patch true "" file
473
474
475	function store_file a lines1 lines2 current file
476	arg Array:Int a ; arg Array:Str lines1 lines2 current ; arg Str file
477	(var Stream s) open file out+safe+mkdir
478	for (var Int i) 0 a:size-1
479	var Int flag := a:i .and. flag_mask
480	var Int index := a:i-flag
481	var Pointer:Str l
482	if flag=flag_num1
483	l :> lines1 index
484	eif flag=flag_num2
485	l :> lines2 index
486	eif flag=flag_current
487	l :> current index
488	else
489	l :> null map Str
490	if exists:l
491	s writeline l
492
493	function file_patch_apply patch section current final rejected -> status
494	arg Str patch section current final rejected ; arg Status status
495	file_header patch (var FileInfo h1) (var FileInfo h2) (var CBool binary) (var Int lines)
496	if not file_is_ascii:current or binary
497	if section<>""
498	status := failure
499	eif h1:datetime=(file_query current standard):datetime
500	file_extract_new patch final
501	status := success
502	else
503	file_copy current final
504	file_extract_new patch rejected
505	status := failure
506	else
507	var Str temp := file_temporary
508	file_extract patch true section temp ; var Array:Str lines2 := load_file temp
509	file_extract patch false section temp ; var Array:Str lines1 := load_file temp
510	var Array:Str curlines := load_file current
511	# convert lines to numbers
512	var (Dictionary Str Int) dict
513	convert_to_numbers lines1 (var Array:Int num1) dict 0
514	convert_to_numbers lines2 (var Array:Int num2) dict lines1:size
515	convert_to_numbers curlines (var Array:Int cur) dict lines1:size+lines2:size
516	# try to apply
517	part apply "apply patch"
518	status := patch_apply num1 num2 cur (var Array:Int fin) (var Array:Int rej)
519	# write result down
520	if final<>""
521	store_file fin lines1 lines2 curlines final
522	if status=failure and rejected<>""
523	var Str temp2 := file_temporary
524	store_file rej lines1 lines2 curlines temp2
525	file_tree_create rejected
526	file_difference temp temp2 rejected
527	file_delete temp2
528	file_delete temp
529
530
531	export file_is_ascii
532	export file_difference file_header file_extract file_extract_old file_extract_new
533	export file_patch_apply