Solution tester for [Perl 'Medium' QOTW - Tournament Schedule]

Daniel Martin <martin-+m399P62/[email protected]> Mon, 17 Jan 2005 16:09:16 -0500

Newsgroups	gmane.comp.lang.perl.qotw.discuss
Message-ID	<[email protected]>

Attached is a quick-and-dirty, and highly ugly, solution verifyer for
this problem.  I've used it to verify that 2 out of the 3 solutions
posted so far are correct - one I had to translate into perl and out
of ruby first, but that was pretty easy.  (And in fact, I'm now
ashamed at how convoluted, long and ugly my solution is, but oh well)

To run it, just do:

perl checkit.pl my_perl_file.pl

If you want to specify that it should only check certain values
(e.g. selected powers of two), just do:

perl checkit.pl my_perl_file.pl allocate_schedule 2 4 8 16 32 64 128

If you called your subroutine something other than
'allocate_schedule', then give that as the second argument.

checkit.pl (text/x-perl, 2.6 KB)

#!/usr/bin/perl
use strict;

# This script checks solutions to perl-qotw 2005-1
#
# Since the challenge was to "write a perl function that...", the
# script needs a filename and a function name.

my (@msgstack) = ();
sub errormsg ($) {
  print join(':', @msgstack, $_[0]), "\n";
}

sub check_one_answer ($$) {
  my ($n, $answer) = @_;
  if (ref($answer) ne 'ARRAY') {
    errormsg "Answer is not an array value"; return 0;
  }
  if (scalar(@$answer) != $n - 1) {
    errormsg "Answer has the wrong length (@{[scalar(@$answer)]})"; return 0;
  }
  my %seenpairs = ();
  my ($i,$j);
  for $i (0..$n-2) {
    my $part = $answer->[$i];
    push @msgstack, "Day $i";
    if (ref($part) ne 'ARRAY') {errormsg "Day spec. is not array ref";return 0;}
    if ($#{$part} != $n-1) {
      errormsg "Wrong number of matches: @{[$#{$part}+1]}";
      return 0;
    }
    my @part = @$part;
    for $j (0..$n-1) {
      if ($part[$j] ne (0 + $part[$j]))
      {
        errormsg "Non-numeric match: $j vs $part[$j]"; return 0;
      }
      if ($seenpairs{$j,$part[$j]})
      {
        errormsg "Already seen the match-up $j vs $part[$j]";
	return 0;
      }
      if ($part[$j] < 0 or $part[$j] >= $n)
      {
        errormsg "Illegal match: $j vs $part[$j]";
	return 0;
      }
      if ($part[$part[$j]] != $j)
      {
        errormsg "$j vs $part[$j] but $part[$j] vs $part[$part[$j]]";
        return 0;
      }
      $seenpairs{$j,$part[$j]} = 1;
    }
    pop @msgstack;
  }
  return 1;
}

sub docheck ($$@) {
  my ($filename, $funcname, @testpoints) = @_;
  my ($shortfilename) = $filename;
  $shortfilename =~ s/\W//;
  @msgstack = ();
  my ($packagename) = sprintf('Qotw::Test::File%s::p%04X',
                              $shortfilename, rand (1 << 31));
  $!=$@='';
  eval "package $packagename; do '$filename'; die(\$\@) if (\$\@);";
  push @msgstack, $filename;
  if ($!) {
    errormsg "Couldn't read $filename: $!\n";
    return 0;
  }
  if ($@) {
    errormsg "Couldn't compile $filename: $@\n";
    return 0;
  }
  if (!@testpoints) {
    @testpoints = map { 2*(1+int(rand($_))) } (2..50);
  }
  my ($t);
  for $t (@testpoints) {
    push @msgstack, "$t days";
    my $ans = eval ('&' . "${packagename}::${funcname}($t)" );
    if ($@) {errormsg "eval aborted: $@"; return 0;}
    use Data::Dumper;
    if (!check_one_answer($t, $ans)) {print Dumper($ans);return 0;}
    pop @msgstack;
  }
  return 1;
}

if (__PACKAGE__ eq 'main')
{
  my $f = shift @ARGV;
  my $func = shift @ARGV;
  $func ||= 'allocate_schedule';
  my @t = @ARGV;
  @ARGV = ();

  if (docheck($f, $func, @t)) {
    print "$func in $f PASSED\n";
    exit 0;
  }
  else
  {
    print "$func in $f FAILED\n";
    exit 1;
  }
}