#!/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;
  }
}