Add Plan Comparison to System/base regression tests

[GoogleCodeExporter]

The regression tests in System/base should have an extra step where the
plans generated through code generation and by the interpreter are dumped
out and compared to see that they match exactly. the comparator needs to be
a little smart to ignore things like differences in token and variable ids.

from Mike:

Here's the script that I wrote way back when for comparing the output of
the PlanWriter?. It assumes that it's working on two different directories,
but it shouldn't be hard to modify it so that it just works with files of
different extensions.

~MJI

{{{
#!/usr/bin/perl -w
BEGIN {
  push @INC, "/home/miatauro/lib/perl5/site_perl/5.8.0";
}
use warnings qw/all/;
use strict;

use Algorithm::Diff;

my %plans = ();
my $token_key_rx = qr/Key=\d+\s+Master=(?:\d+|NONE)/;
my $merge_key_rx = qr/Merged Key=\d+/;

collect_plan_output_files($_) foreach @ARGV;

foreach(sort keys %plans) {
  if(@{$plans{$_}} != @ARGV) {
    print "Not every set of output files has $_.  Skipping.\n";
    next;
  }
  plan_compare(@{$plans{$_}});
}

sub collect_plan_output_files {
  my $dir = shift;
  local $_;
  opendir my $dh, $dir or die "Couldn't open directory $dir: $!\n";
  my @files = grep {/RUN_.+\.output/} readdir $dh;
  closedir $dh;

  foreach my $plan (@files) {
    $plan =~ /RUN_(.+?)\./;
    $plans{$1} = [] unless exists $plans{$1};
    push @{$plans{$1}}, "$dir/$plan";
  }
}

sub plan_compare {
  my $planfile1 = shift;
  my $planfile2 = shift;

  my $plan1 = get_plan($planfile1);
  my $plan2 = get_plan($planfile2);

  my $diff = Algorithm::Diff->new($plan1, $plan2);

  my %diffs1 = ();
  my %diffs2 = ();
  my @lines1 = ();
  my @lines2 = ();

  $diff->Base(1); #use line numbers
  while($diff->Next()) {
    next if($diff->Same()); #skip anything that's the same
    my @items1 = $diff->Items(1);
    my @items2 = $diff->Items(2);

    @items1 = remove_rx($token_key_rx, @items1); #token key differences
don't matter
    @items2 = remove_rx($token_key_rx, @items2);
    next if (@items1 == @items2 && @items1 == 0);

    if(@items1 == @items2) {
      @items1 = remove_rx($merge_key_rx, @items1); #merged key differences
don't matter
      @items2 = remove_rx($merge_key_rx, @items2); #as long as there are
the same number of merged tokens
      next if(@items1 == @items2 && @items1 == 0);
    }

    @items1 = remove_rx(qr/world\./, @items1); #differences in the world
object don't matter
    @items2 = remove_rx(qr/world\./, @items2);

    @items1 = remove_rx(qr/ound plan/, @items1); #differences in step
numbers don't matter
    @items2 = remove_rx(qr/ound plan/, @items2);
    next if(@items1 == @items2 && @items1 == 0);

    if(@items1 > 0) {
      $diffs1{$diff->Min(1)} = \@items1;
      push @lines1, $diff->Min(1);
    }
    if(@items2 > 0) {
      $diffs2{$diff->Min(2)} = \@items2 ;
      push @lines2, $diff->Min(2);
    }
  }

  #if(@lines1 != @lines2) {
  #  print "Plans $planfile1 and $planfile2 are very definitely different.\n";
  #}

  my $min = (@lines1 < @lines2 ? @lines1 : @lines2);

  foreach my $i (0..$min) {
    next if !(defined($lines1[$i]) && defined($lines2[$i]));

    my $subdiff = Algorithm::Diff->new($diffs1{$lines1[$i]},
$diffs2{$lines2[$i]});
    while($subdiff->Next()) {
      next if ($subdiff->Same());
      my @subitems1 = $subdiff->Items(1);
      my @subitems2 = $subdiff->Items(2);
      print "=====================\n";
      print "$planfile1: [", $lines1[$i] + $subdiff->Min(1), "]\n";
      map {print $_} @subitems1;
      print "======================\n";
      print "$planfile2: [", $lines2[$i] + $subdiff->Min(2), "]\n";
      map {print $_} @subitems2;
    }
  }

  if(@lines1 > @lines2) {
    foreach($min+1..$#lines1) {
      print "===================\n";
      print "$planfile1: [", $lines1[$_], "]\n";
      map {print $_} @{$diffs1{$lines1[$_]}};
    }
  }
  elsif(@lines2 > @lines1) {
    foreach($min+1..$#lines2) {
      print "===================\n";
      print "$planfile2: [", $lines2[$_], "]\n";
      map {print $_} @{$diffs2{$lines2[$_]}};
    }
  }
}

sub get_plan {
  my $file = shift;
  open my $fh, $file or die "Failed to open file $file: $!\n";
  return extract_plan($fh);
}

sub extract_plan {
  my $fh = shift;
  my @plan = ();
  local $_;
  while(<$fh>) {
    #print "$.: $_";
    last if /Objects\s+\*+/;
  }
  #print "Pushing line: $_";
  push @plan, $_;
  while(<$fh>) {
    #given the current plan output
    #there are only merged and inactive tokens after this point,
    #which don't really matter
    last if(/Merged Tokens:\s*\*{4,}/);

    if(/.+\s*\*{4,}/ || # Objects **** or Variables ***** etc.
       /.+=.+:.+/ || #object.var=type:DOMAIN
       /\[\s+.+:.+\s+\]/ || # [ INT_INTERVAL:CLOSED[50, 65] ]
       /\.+\((?:.+=.+[}\]])*\)/ ||
#object.predicate(parameter=type:DOMAINparameter=type:DOMAIN)
       /$token_key_rx/ || #Key=123 Master=none
       /$merge_key_rx/ ) {
    #print "Pushing line: $_";
      push @plan, $_;
    }
  }
  return \@plan;
}

sub remove_rx {
  my $rx = shift;
  return grep {$_ !~ /$rx/} @_;
}

}}}

Original issue reported on code.google.com by tristanb...@gmail.com on 9 Sep 2009 at 10:37

[GoogleCodeExporter]

See also #15 - report any progress to that owner since it might help.

Original comment by tristanb...@gmail.com on 9 Sep 2009 at 10:43

[GoogleCodeExporter]

Original comment by miata...@gmail.com on 4 May 2010 at 3:31

[GoogleCodeExporter]

Original comment by javier.barreiro@gmail.com on 22 Nov 2010 at 10:29

• Added labels: Milestone-EUROPA-X