#!/usr/local/bin/perl
# -*-Perl-*-
# ndiffpost.perl -- Reads the result of a diff command, and reports on the numerical
# differences found in the blocks of differences.
#
# Copyright (c) 1987-1988 Robert E. Bruccoleri
#   
# Copyright (c) 1990-1997 Bristol-Myers Squibb Company
#    
# This software and related documentation is being provided by the
# copyright holders under the following license.  By obtaining, using
# and/or copying this software, you agree that you have read,
# understood, and will comply with the following terms and conditions:
# 
# Permission to use, copy, modify, and distribute this software and its
# documentation for any purpose and without fee is hereby granted,
# provided that the above copyright notice and this permission notice
# and warranty disclaimer appear in all copies.
# 
# ROBERT E. BRUCCOLERI AND BRISTOL-MYERS SQUIBB COMPANY DISCLAIMS, AND
# THE USER WAIVES, ALL REPRESENTATIONS AND WARRANTIES, EXPRESS OR
# IMPLIED, WITH REGARD TO THIS SOFTWARE AND ITS RELATED DOCUMENTATION,
# INCLUDING WITHOUT LIMITATION ALL IMPLIED WARRANTIES OF MERCHANTABILITY
# AND FITNESS FOR A PARTICULAR USE OR PURPOSE.  ROBERT E. BRUCCOLERI AND
# BRISTOL-MYERS SQUIBB COMPANY MAKES NO REPRESENTATION OR WARRANTY,
# EXPRESS OR IMPLIED, AS TO WHETHER THE USE OF THIS SOFTWARE AND ITS
# RELATED DOCUMENTATION INFRINGES ANY PATENT, COPYRIGHT, OR OTHER
# INTELLECTUAL PROPERTY RIGHT OF ANY OTHER PARTY. IN NO EVENT SHALL
# ROBERT E. BRUCCOLERI OR BRISTOL-MYERS SQUIBB COMPANY BE LIABLE FOR ANY
# SPECIAL, DIRECT, INDIRECT, INCIDENTAL, PUNITIVE, OR CONSEQUENTIAL
# DAMAGES, OR ANY OTHER DAMAGES OF ANY NATURE WHATSOEVER, THAT MAY BE
# INCURRED BY THE USER OR ANY OTHER PARTY ARISING OUT OF OR IN
# CONNECTION WITH ANY USE OR PERFORMANCE OF THIS SOFTWARE OR ANY USE OF
# ANY DATA OR RESULTS GENERATED BY THE SOFTWARE, INCLUDING WITHOUT
# LIMITATION LOSS OF DATA AND LOST PROFITS OR REVENUES, WHETHER OR NOT
# DR. BRUCCOLERI AND BRISTOL-MYERS SQUIBB COMPANY HAVE BEEN ADVISED OF
# THE POSSIBILITY OF DAMAGES, AND USER HEREBY WAIVES, RELEASES, AND
# FOREVER DISCLAIMS ALL DAMAGES, CLAIMS, AND CAUSES OF ACTION IT MAY
# HAVE AGAINST DR. BRUCCOLERI AND BRISTOL-MYERS SQUIBB COMPANY WITH
# RESPECT TO ANY LOSSES, DAMAGES, COSTS, EXPENSES, AND LIABILITIES OF
# ANY NATURE THAT MAY BE INCURRED BY IT ARISING OUT OF OR IN CONNECTION
# WITH USER'S USE OF THE SOFTWARE AND ITS RELATED DOCUMENTATION.  USER
# SHALL BE SOLELY RESPONSIBLE FOR ALL LOSSES, DAMAGES, COSTS, EXPENSES,
# AND LIABILITIES OF ANY NATURE INCURRED BY USER RESULTING FROM OR IN
# CONNECTION WITH USER'S USE OF THE SOFTWARE AND ITS RELATED
# DOCUMENTATION.  THE USER UNDERSTANDS AND ACCEPTS THE ABOVE LIMITATIONS
# ON DAMAGES AND REMEDIES AS A CONDITION OF OBTAINING USE OF THE
# SOFTWARE AND RELATED DOCUMENTATION WITHOUT CHARGE.
#
# Author: Robert E. Bruccoleri
# Bristol-Myers Squibb Pharmaceutical Research Institute
# November 1, 1991
#
# Usage: diff ... | ndiffpost -cutoff=real -sort -ignore=file
#
# if cutoff is specified, then only those blocks which have relative differences
# bigger than that will be output.
#

$flags = ":sort:verbose:";
$valued_options = ":cutoff:ignore:angle:";

&process_arguments("");

exit(1) if ($errcnt > 0);

if (defined $opt_angle) {
    $angle_check_max_diff = $opt_angle;
}
else {
    $angle_check_max_diff = 0.05;
}

if (defined $opt_ignore) {
    &read_ignore_patterns;
}

while (<>) {
    chop;	# strip record separator

    if (/^</) {
	$lines1[$n1++] = &trim($_);
    }
    elsif (/^>/) {
	$lines2[$n2++] = &trim($_);
    }
    elsif (/^---/) {
	;
    }
    elsif (/^([0-9]+(,[0-9]+)?[acd][0-9]+(,[0-9]+)?)/) {
	$ed_code = $new_ed_code;
	$new_ed_code = $1;
	if ($n1 != 0 || $n2 != 0) {
	    &process_a_block();
	}
    }
}

if ($n1 != 0 || $n2 != 0) {
    $ed_code = $new_ed_code;
    &process_a_block();
}

foreach $ind ($opt_sort ?
	      sort numerically 1..$output_line_count :
	      1..$output_line_count) {
    print $output_lines[$ind-1];
}


sub process_arguments {
    # Process command line switches and leave file name arguments in ARGV. Also,
    # if no filename is specified, make a default setting from the passed parameter.

    local($default_argv0) = @_;
    local(@rest);
    local($var, $val);

    while (@ARGV) {
	$_ = shift(@ARGV);
	if (/^-(.+)/) {
	    $var = $1;
	    $_ = substr($_,1);
	    ($var,$val) = ($`,$') if /=/;
#	    print "var = $var  val = $val\n";
	    if ($flags =~ /:$var:/) {
		eval "\$opt_$var = 1;";
#		printf '%s scanned. $opt_%s = %d%s', $var, $var, eval "\$opt_$var", "\n";
	    }
	    elsif ($valued_options =~ /:$var:/) {
		if ($val eq "") {
		    $val = shift(@ARGV);
		}
		eval "\$opt_$var = \$val;";
#		printf '%s scanned. $opt_%s = %s%s', $var, $var, eval "\$opt_$var", "\n";
	    }
	    else {
		printf STDERR "Unrecognized option %s\n", $var;
		$errcnt += 1;
	    }
	}
	else {
	    push(@rest, $_);
	}
    }
    @ARGV = @rest;
    return $errcnt == 0;
}


sub abs {
    my($X) = @_;
    if ($X < 0) {
	return -$X;
    }
    else {
	return $X;
    }
}

sub max {
    my($X, $Y) = @_;
    if ($X > $Y) {
	return $X;
    }
    else {
	return $Y;
    }
}

sub min {
    my($X, $Y) = @_;
    if ($X > $Y) {
	return $Y;
    }
    else {
	return $X;
    }
}

sub trim {
    my($S, $done, $l) = @_;
    $done = 0;
    while (!$done) {
	$l = length($S);
	if ($l < 1) {
	    $done = 1;
	}
	elsif (substr($S, $l-1, 1) eq ' ') {
	    $S = substr($S, 0, $l - 1);
	}
	else {
	    $done = 1;
	}
    }
    $S;
}

sub process_a_block {
    my $lines_diff = 0;
    my $wc_diff = 0;
    $mes = '';
    $maxdiff = 0;
    $must_display = 0;
    if ($#ignore_pats >= 0) {
	&process_ignore_pats;
	if ($n1 == 0 & $n2 == 0) {
	    return;
	}
    }
    $nl = $n1;
    $imax = 0;
    if ($n1 != $n2) {
	$must_display = 1;
	$lines_diff = 1;
	$mes = $mes . ' #Lines diff.';
	if ($n1 > $n2) {
	    $nl = $n2;
	}
    }
    for ($i = 0; $i <= $nl; $i++) {
	@words1 = &find_numbers($lines1[$i]);
	print $lines1[$i] . "\nhas numbers: @words1\n" if $opt_verbose;
	@words2 = &find_numbers($lines2[$i]);
	print $lines2[$i] . "\nhas numbers: @words2\n" if $opt_verbose;
	$nf1 = $#words1;
	$nf2 = $#words2;
	if ($nf1 != $nf2) {
	    $must_display = 1;
	    $wc_diff = 1;
	    $mes = $mes . sprintf(' WC: #%d', $i+1);
	    if ($nf1 > $nf2) {
		$nf1 = $nf2;
	    }
	}
	for ($iw = 0; $iw <= $nf1; $iw++) {
	    $words1[$iw] += 0;
	    $words2[$iw] += 0;
	    if ($words1[$iw] != 0 || $words2[$iw] != 0) {
		$M = &max(&abs($words1[$iw]), &abs($words2[$iw]));
		$d = &abs($words1[$iw] - $words2[$iw]);
		if (&abs($d - 360) <= $angle_check_max_diff) {
		    $mes = $mes . sprintf(' Angles (%s %s)',
					  $words1[$iw], $words2[$iw]);
		}
		else {
		    $d = &min($d, $d / $M);
		    if ($d > $maxdiff) {
			$maxdiff = $d;
			$imax = $i;
		    }
		}
	    }
	}
    }
    if ($maxdiff > 0) {
	$mes = $mes . sprintf(' Diff: %g', $maxdiff);
    }
    if ($maxdiff > $opt_cutoff) {
	$must_display = 1;
    }
    if ($must_display) {
	$buf = sprintf("%s %s\n", $ed_code, $mes);
	for ($i = 0; $i < $n1; $i++) {
	    if ($i == $imax) {
		$lines1[$i] = substr($lines1[$i], 0, 1) .
		    '*' . substr($lines1[$i], 2);
	    }
	    $buf .= sprintf("%s\n", $lines1[$i]);
	}
	$buf .= sprintf("%s\n", '---');
	for ($i = 0; $i < $n2; $i++) {
	    if ($i == $imax) {
		$lines2[$i] = substr($lines2[$i], 0, 1) .
		    '*' . substr($lines2[$i], 2);
	    }
	    $buf .= sprintf("%s\n", $lines2[$i]);
	}
	$output_line_count += 1;
	if ($opt_sort) {
	    if ($maxdiff == 0.0 or $lines_diff or $wc_diff) {
		$value[$output_line_count-1] = 3.0; # Move to top of listing.
	    }
	    else {
		$value[$output_line_count-1] = $maxdiff;
	    }
	}
	else {
	    $value[$output_line_count-1] = $output_line_count;
	}
	$output_lines[$output_line_count-1] = $buf;
    }
    $n1 = 0;
    $n2 = 0;
}

sub find_numbers {
    my ($line) = @_;
    my ($num, @ret);

    $_ = $line;
    while (s/([+-]?(\d+(\.\d*)?|\d*(\.\d+))([eEdD][+-]?\d+)?)//) {
	($num = $1) =~ tr/dD/eE/;
	push(@ret, $num);
    }
    return @ret;
}

sub numerically {
    my ($ret);

    $ret = $value[$b-1] <=> $value[$a-1];
    if ($ret == 0) {
	$ret = $a <=> $b;
    }
    return $ret;
}

sub read_ignore_patterns {
    if (!open (IN, "<$opt_ignore")) {
	warn "Unable to open $opt_ignore\n";
	return;
    }
    while (<IN>) {
	chop;
	push(@ignore_pats, $_);
    }
}

sub process_ignore_pats {
    my ($i, $j, $ok, @lines, $pat);

    @lines = ();
    for ($i = 0; $i < $n1; $i++) {
	$ok = 1;
	for ($j = 0; $j <= $#ignore_pats; $j++) {
	    $pat = $ignore_pats[$j];
	    if (substr($lines1[$i],2) =~ /$pat/) {
		$ok = 0;
		print "$pat matches $lines1[$i]\n" if $opt_verbose;
		last;
	    }
	}
	if ($ok) {
	    push(@lines, $lines1[$i]);
	}
    }
    @lines1 = @lines;
    $n1 = $#lines1 + 1;
    @lines = ();
    for ($i = 0; $i < $n2; $i++) {
	$ok = 1;
	for ($j = 0; $j <= $#ignore_pats; $j++) {
	    $pat = $ignore_pats[$j];
	    if (substr($lines2[$i],2) =~ /$pat/) {
		print "$pat matches $lines2[$i]\n" if $opt_verbose;
		$ok = 0;
		last;
	    }
	}
	if ($ok) {
	    push(@lines, $lines2[$i]);
	}
    }
    @lines2 = @lines;
    $n2 = $#lines2 + 1;
}
