3 use vars qw($VERSION @EXPORT_OK @ISA @EXPORT);
4 use integer; # see below in _replaceNextLargerWith() for mod to make
5 # if you don't use this
9 @EXPORT_OK = qw(LCS diff traverse_sequences);
10 $VERSION = sprintf('%d.%02d', (q$Revision: 1.10 $ =~ /\d+/g));
12 # McIlroy-Hunt diff algorithm
13 # Adapted from the Smalltalk code of Mario I. Wolczko, <mario@wolczko.com>
14 # by Ned Konz, perl@bike-nomad.com
18 Algorithm::Diff - Compute `intelligent' differences between two files / lists
22 use Algorithm::Diff qw(diff LCS traverse_sequences);
24 @lcs = LCS( \@seq1, \@seq2 );
26 @lcs = LCS( \@seq1, \@seq2, $key_generation_function );
28 $lcsref = LCS( \@seq1, \@seq2 );
30 $lcsref = LCS( \@seq1, \@seq2, $key_generation_function );
32 @diffs = diff( \@seq1, \@seq2 );
34 @diffs = diff( \@seq1, \@seq2, $key_generation_function );
36 traverse_sequences( \@seq1, \@seq2,
38 DISCARD_A => $callback,
39 DISCARD_B => $callback,
42 traverse_sequences( \@seq1, \@seq2,
44 DISCARD_A => $callback,
45 DISCARD_B => $callback,
47 $key_generation_function );
51 (by Mark-Jason Dominus)
53 I once read an article written by the authors of C<diff>; they said
54 that they hard worked very hard on the algorithm until they found the
57 I think what they ended up using (and I hope someone will correct me,
58 because I am not very confident about this) was the `longest common
59 subsequence' method. in the LCS problem, you have two sequences of
64 a b c d e f g i j k r x y z
66 and you want to find the longest sequence of items that is present in
67 both original sequences in the same order. That is, you want to find
68 a new sequence I<S> which can be obtained from the first sequence by
69 deleting some items, and from the secend sequence by deleting other
70 items. You also want I<S> to be as long as possible. In this case
75 From there it's only a small step to get diff-like output:
80 This module solves the LCS problem. It also includes a canned
81 function to generate C<diff>-like output.
83 It might seem from the example above that the LCS of two sequences is
84 always pretty obvious, but that's not always the case, especially when
85 the two sequences have many repeated elements. For example, consider
90 A naive approach might start by matching up the C<a> and C<b> that
91 appear at the beginning of each sequence, like this:
96 This finds the common subsequence C<a b c z>. But actually, the LCS
104 This module provides three exportable functions, which we'll deal with in
105 ascending order of difficulty: C<LCS>, C<diff>, and
106 C<traverse_sequences>.
110 Given references to two lists of items, LCS returns an array containing their
111 longest common subsequence. In scalar context, it returns a reference to
114 @lcs = LCS( \@seq1, \@seq2 );
115 $lcsref = LCS( \@seq1, \@seq2 );
117 C<LCS> may be passed an optional third parameter; this is a CODE
118 reference to a key generation function. See L</KEY GENERATION
121 @lcs = LCS( \@seq1, \@seq2, $keyGen );
122 $lcsref = LCS( \@seq1, \@seq2, $keyGen );
124 Additional parameters, if any, will be passed to the key generation
129 @diffs = diff( \@seq1, \@seq2 );
130 $diffs_ref = diff( \@seq1, \@seq2 );
132 C<diff> computes the smallest set of additions and deletions necessary
133 to turn the first sequence into the second, and returns a description
134 of these changes. The description is a list of I<hunks>; each hunk
135 represents a contiguous section of items which should be added,
136 deleted, or replaced. The return value of C<diff> is a list of
137 hunks, or, in scalar context, a reference to such a list.
139 Here is an example: The diff of the following two sequences:
142 b c d e f j k l m r s t
164 There are five hunks here. The first hunk says that the C<a> at
165 position 0 of the first sequence should be deleted (C<->). The second
166 hunk says that the C<d> at position 2 of the second sequence should
167 be inserted (C<+>). The third hunk says that the C<h> at position 4
168 of the first sequence should be removed and replaced with the C<f>
169 from position 4 of the second sequence. The other two hunks similarly.
171 C<diff> may be passed an optional third parameter; this is a CODE
172 reference to a key generation function. See L</KEY GENERATION
175 Additional parameters, if any, will be passed to the key generation
178 =head2 C<traverse_sequences>
180 C<traverse_sequences> is the most general facility provided by this
181 module; C<diff> and C<LCS> are implemented as calls to it.
183 Imagine that there are two arrows. Arrow A points to an element of
184 sequence A, and arrow B points to an element of the sequence B.
185 Initially, the arrows point to the first elements of the respective
186 sequences. C<traverse_sequences> will advance the arrows through the
187 sequences one element at a time, calling an appropriate user-specified
188 callback function before each advance. It willadvance the arrows in
189 such a way that if there are equal elements C<$A[$i]> and C<$B[$j]>
190 which are equal and which are part of the LCS, there will be some
191 moment during the execution of C<traverse_sequences> when arrow A is
192 pointing to C<$A[$i]> and arrow B is pointing to C<$B[$j]>. When this
193 happens, C<traverse_sequences> will call the C<MATCH> callback
194 function and then it will advance both arrows.
196 Otherwise, one of the arrows is pointing to an element of its sequence
197 that is not part of the LCS. C<traverse_sequences> will advance that
198 arrow and will call the C<DISCARD_A> or the C<DISCARD_B> callback,
199 depending on which arrow it advanced. If both arrows point to
200 elements that are not part of the LCS, then C<traverse_sequences> will
201 advance one of them and call the appropriate callback, but it is not
202 specified which it will call.
204 The arguments to C<traverse_sequences> are the two sequences to
205 traverse, and a callback which specifies the callback functions, like
208 traverse_sequences( \@seq1, \@seq2,
209 { MATCH => $callback_1,
210 DISCARD_A => $callback_2,
211 DISCARD_B => $callback_3,
214 Callbacks are invoked with at least the indices of the two arrows as
215 their arguments. They are not expected to return any values. If a
216 callback is omitted from the table, it is not called.
218 If arrow A reaches the end of its sequence, before arrow B does,
219 C<traverse_sequences> will call the C<A_FINISHED> callback when it
220 advances arrow B, if there is such a function; if not it will call
221 C<DISCARD_B> instead. Similarly if arrow B finishes first.
222 C<traverse_sequences> returns when both arrows are at the ends of
223 their respective sequences. It returns true on success and false on
224 failure. At present there is no way to fail.
226 C<traverse_sequences> may be passed an optional fourth parameter; this
227 is a CODE reference to a key generation function. See L</KEY
228 GENERATION FUNCTIONS>.
230 Additional parameters, if any, will be passed to the key generation
233 =head1 KEY GENERATION FUNCTIONS
235 C<diff>, C<LCS>, and C<traverse_sequences> accept an optional last parameter.
236 This is a CODE reference to a key generating (hashing) function that should
237 return a string that uniquely identifies a given element.
238 It should be the case that if two elements are to be considered equal,
239 their keys should be the same (and the other way around).
240 If no key generation function is provided, the key will be the
243 By default, comparisons will use "eq" and elements will be turned into keys
244 using the default stringizing operator '""'.
246 Where this is important is when you're comparing something other than
247 strings. If it is the case that you have multiple different objects
248 that should be considered to be equal, you should supply a key
249 generation function. Otherwise, you have to make sure that your arrays
250 contain unique references.
252 For instance, consider this example:
259 return bless { name => '', ssn => '', @_ }, $package;
265 my $new = bless { %$old }, ref($old);
270 return shift()->{'ssn'};
273 my $person1 = Person->new( name => 'Joe', ssn => '123-45-6789' );
274 my $person2 = Person->new( name => 'Mary', ssn => '123-47-0000' );
275 my $person3 = Person->new( name => 'Pete', ssn => '999-45-2222' );
276 my $person4 = Person->new( name => 'Peggy', ssn => '123-45-9999' );
277 my $person5 = Person->new( name => 'Frank', ssn => '000-45-9999' );
281 my $array1 = [ $person1, $person2, $person4 ];
282 my $array2 = [ $person1, $person3, $person4, $person5 ];
283 Algorithm::Diff::diff( $array1, $array2 );
285 everything would work out OK (each of the objects would be converted
286 into a string like "Person=HASH(0x82425b0)" for comparison).
290 my $array1 = [ $person1, $person2, $person4 ];
291 my $array2 = [ $person1, $person3, $person4->clone(), $person5 ];
292 Algorithm::Diff::diff( $array1, $array2 );
294 $person4 and $person4->clone() (which have the same name and SSN)
295 would be seen as different objects. If you wanted them to be considered
296 equivalent, you would have to pass in a key generation function:
298 my $array1 = [ $person1, $person2, $person4 ];
299 my $array2 = [ $person1, $person3, $person4->clone(), $person5 ];
300 Algorithm::Diff::diff( $array1, $array2, \&Person::hash );
302 This would use the 'ssn' field in each Person as a comparison key, and
303 so would consider $person4 and $person4->clone() as equal.
305 You may also pass additional parameters to the key generation function
310 This version by Ned Konz, perl@bike-nomad.com
314 Versions through 0.59 (and much of this documentation) were written by:
316 Mark-Jason Dominus, mjd-perl-diff@plover.com
318 This version borrows the documentation and names of the routines
319 from Mark-Jason's, but has all new code in Diff.pm.
321 This code was adapted from the Smalltalk code of
322 Mario Wolczko <mario@wolczko.com>, which is available at
323 ftp://st.cs.uiuc.edu/pub/Smalltalk/MANCHESTER/manchester/4.0/diff.st
325 The algorithm is that described in
326 I<A Fast Algorithm for Computing Longest Common Subsequences>,
327 CACM, vol.20, no.5, pp.350-353, May 1977, with a few
328 minor improvements to improve the speed.
332 # Create a hash that maps each element of $aCollection to the set of positions
333 # it occupies in $aCollection, restricted to the elements within the range of
334 # indexes specified by $start and $end.
335 # The fourth parameter is a subroutine reference that will be called to
336 # generate a string to use as a key.
337 # Additional parameters, if any, will be passed to this subroutine.
339 # my $hashRef = _withPositionsOfInInterval( \@array, $start, $end, $keyGen );
341 sub _withPositionsOfInInterval
343 my $aCollection = shift; # array ref
349 for ( $index = $start; $index <= $end; $index++ )
351 my $element = $aCollection->[ $index ];
352 my $key = &$keyGen( $element, @_ );
353 if ( exists( $d{ $key } ) )
355 push( @{ $d{ $key } }, $index );
359 $d{ $key } = [ $index ];
362 return wantarray ? %d: \%d;
365 # Find the place at which aValue would normally be inserted into the array. If
366 # that place is already occupied by aValue, do nothing, and return undef. If
367 # the place does not exist (i.e., it is off the end of the array), add it to
368 # the end, otherwise replace the element at that point with aValue.
369 # It is assumed that the array's values are numeric.
370 # This is where the bulk (75%) of the time is spent in this module, so try to
373 sub _replaceNextLargerWith
375 my ( $array, $aValue, $high ) = @_;
379 if ( $high == -1 || $aValue > $array->[ -1 ] )
381 push( @$array, $aValue );
385 # binary search for insertion point...
389 while ( $low <= $high )
391 $index = ( $high + $low ) / 2;
392 # $index = int(( $high + $low ) / 2); # without 'use integer'
393 $found = $array->[ $index ];
395 if ( $aValue == $found )
399 elsif ( $aValue > $found )
409 # now insertion point is in $low.
410 $array->[ $low ] = $aValue; # overwrite next larger
414 # This method computes the longest common subsequence in $a and $b.
416 # Result is array or ref, whose contents is such that
417 # $a->[ $i ] = $b->[ $result[ $i ] ]
418 # foreach $i in ( 0..scalar( @result ) if $result[ $i ] is defined.
420 # An additional argument may be passed; this is a hash or key generating
421 # function that should return a string that uniquely identifies the given
422 # element. It should be the case that if the key is the same, the elements
423 # will compare the same. If this parameter is undef or missing, the key
424 # will be the element as a string.
426 # By default, comparisons will use "eq" and elements will be turned into keys
427 # using the default stringizing operator '""'.
429 # Additional parameters, if any, will be passed to the key generation routine.
431 sub _longestCommonSubsequence
433 my $a = shift; # array ref
434 my $b = shift; # array ref
435 my $keyGen = shift; # code ref
436 my $compare; # code ref
439 # Note that these are optimized.
440 if ( !defined( $keyGen ) ) # optimize for strings
442 $keyGen = sub { $_[0] };
443 $compare = sub { my ($a, $b) = @_; $a eq $b };
448 my $a = shift; my $b = shift;
449 &$keyGen( $a, @_ ) eq &$keyGen( $b, @_ )
453 my ($aStart, $aFinish, $bStart, $bFinish, $matchVector) = (0, $#$a, 0, $#$b, []);
455 # First we prune off any common elements at the beginning
456 while ( $aStart <= $aFinish
457 and $bStart <= $bFinish
458 and &$compare( $a->[ $aStart ], $b->[ $bStart ], @_ ) )
460 $matchVector->[ $aStart++ ] = $bStart++;
464 while ( $aStart <= $aFinish
465 and $bStart <= $bFinish
466 and &$compare( $a->[ $aFinish ], $b->[ $bFinish ], @_ ) )
468 $matchVector->[ $aFinish-- ] = $bFinish--;
471 # Now compute the equivalence classes of positions of elements
472 my $bMatches = _withPositionsOfInInterval( $b, $bStart, $bFinish, $keyGen, @_ );
476 my ( $i, $ai, $j, $k );
477 for ( $i = $aStart; $i <= $aFinish; $i++ )
479 $ai = &$keyGen( $a->[ $i ] );
480 if ( exists( $bMatches->{ $ai } ) )
483 for $j ( reverse( @{ $bMatches->{ $ai } } ) )
485 # optimization: most of the time this will be true
487 and $thresh->[ $k ] > $j
488 and $thresh->[ $k - 1 ] < $j )
490 $thresh->[ $k ] = $j;
494 $k = _replaceNextLargerWith( $thresh, $j, $k );
497 # oddly, it's faster to always test this (CPU cache?).
501 [ ( $k ? $links->[ $k - 1 ] : undef ), $i, $j ];
509 for ( my $link = $links->[ $#$thresh ]; $link; $link = $link->[ 0 ] )
511 $matchVector->[ $link->[ 1 ] ] = $link->[ 2 ];
515 return wantarray ? @$matchVector : $matchVector;
518 sub traverse_sequences
520 my $a = shift; # array ref
521 my $b = shift; # array ref
522 my $callbacks = shift || { };
524 my $matchCallback = $callbacks->{'MATCH'} || sub { };
525 my $discardACallback = $callbacks->{'DISCARD_A'} || sub { };
526 my $discardBCallback = $callbacks->{'DISCARD_B'} || sub { };
527 my $matchVector = _longestCommonSubsequence( $a, $b, $keyGen, @_ );
528 # Process all the lines in match vector
533 for ( $ai = 0; $ai <= $#$matchVector; $ai++ )
535 my $bLine = $matchVector->[ $ai ];
536 if ( defined( $bLine ) )
538 &$discardBCallback( $ai, $bi++, @_ ) while $bi < $bLine;
539 &$matchCallback( $ai, $bi++, @_ );
543 &$discardACallback( $ai, $bi, @_ );
547 &$discardACallback( $ai++, $bi, @_ ) while ( $ai <= $lastA );
548 &$discardBCallback( $ai, $bi++, @_ ) while ( $bi <= $lastB );
554 my $a = shift; # array ref
555 my $matchVector = _longestCommonSubsequence( $a, @_ );
558 for ( $i = 0; $i <= $#$matchVector; $i++ )
560 if ( defined( $matchVector->[ $i ] ) )
562 push( @retval, $a->[ $i ] );
565 return wantarray ? @retval : \@retval;
570 my $a = shift; # array ref
571 my $b = shift; # array ref
574 my $discard = sub { push( @$hunk, [ '-', $_[ 0 ], $a->[ $_[ 0 ] ] ] ) };
575 my $add = sub { push( @$hunk, [ '+', $_[ 1 ], $b->[ $_[ 1 ] ] ] ) };
576 my $match = sub { push( @$retval, $hunk ) if scalar(@$hunk); $hunk = [] };
577 traverse_sequences( $a, $b,
578 { MATCH => $match, DISCARD_A => $discard, DISCARD_B => $add },
581 return wantarray ? @$retval : $retval;