#!/usr/bin/perl -w

use strict;

use Getopt::Std;

use vars qw ( $opt_a $opt_c );

# Compare a file of quiz ANSWERS against the reference (CHECK).
my %ANSWERS;
my %CHECK;

if ( ! getopts( 'a:c:' ) )
  {
    die "Usage:  check-answers.pl -a answerfile -c checkfile";
  }

if ( ! $opt_a || ! $opt_c )
{
  die "Must provide both AnswerFile (-a) and CheckFile (-c)";
}

sub word_of
{
  # From a normalized answer, that is with two slashes for hooks, return
  # the word between the slashes
  my ($a) = @_;
#print "Word of (in):  $a;  ";
  $a =~ s#.*/(.*)/.*#$1#;
#print "(out):  $a\n";
  return $a;
}

sub by_word 
{
  my ($a, $b) = @_;
  return &word_of( $a ) cmp &word_of ( $b );
}

sub srack 
{
  my ($r) = @_;
  if ($r) 
  {
   #print ((length $r) . " $r\n");
    my $retval = join "", sort split //, $r; 
    return $retval;
  } 
  else 
  { 
    #print "0\n";
    return ""; 
  }
}

sub is_poss_answer
{
  my ($q, $a) = @_;
  my $s1 = &srack($a);
  my $s2 = &srack($q);
  return $s1 eq $s2;
  #return &srack($a) eq &srack($q);
}

sub ingest_file
{
  my ($hash, $fn) = @_;

  open F, "<$fn" or die "Failed to open $fn ($!)";

  while (<F>) 
  {
    #print "Ingesting $_";
    chomp;
    $_ = uc $_;
    my ($q, @A) = split /\s+/;
    foreach my $a (@A)
    # For now, we assume the first word is just a rack for
    # which the quizzee has typed in answers.  This question
    # in any case will never get normalized--how do we know what it's
    # supposed to be converted to?
    {
      ##############################################################
      # Check for invalid chars
      if ( $a =~ /~[A-Z\/]/ )
      {
        die "Answer contains invalid characters:  ($q) $a";
      }
      if ( $a =~ m#/.*/.*/# )
      {
        die "Answer contains too many slashes:  ($q) $a";
      } 

      ##############################################################
      # Add slashes if needed
      if ( $a =~ m#/.*/# )
      {
        0; # Already 2 slahses, Nothing to do
      } elsif ( $a =~ m#/# )
      {
        # Trickiest case, only one slash
        # We can place the slash on either side if
        # we can determine that a letter sequence on either side of the
        # single slash is a possible solution to the question.
        my $l1; my $l2;
        ($l1, $l2) = split /\//, $a;
        if ( &is_poss_answer( $q, $l1 ) && &is_poss_answer( $q, $l2 ) )
        {
          # Neither is a possible answer--user needs to specify
          die "Two possible answers either side of single slash:  ($q) $a";
        }
        elsif ( &is_poss_answer( $q, $l1 ) )
        {
          $a = "/$a";
        } 
        elsif ( &is_poss_answer( $q, $l2 ) )
        {
          $a = "$a/";
        } else 
        {
          # Neither is a possible answer--user needs to specify
          die "No possible answers on either side of single slash:  ($q) $a";
        }
      } else 
      {
        # No slashes, must be assumed to surround
        $a = "/$a/";
      }

      ##############################################################
      # Normalize hook lists
      my ($h1, $w, $h2) = split /\//, $a;
      $a = &srack( $h1 ) . '/' . $w . '/' . &srack ( $h2 );

      ##############################################################
      # Push the normalized answer onto the array corresponding to this q
      #print "Pushing $a\n";
      push @{${$hash}{$q}->{ANSWERS}}, $a;

    }

    #print join ",", sort by_word @{${$hash}{$q}->{ANSWERS}};
    #print "\n";
    ##############################################################
    # Sort the answers alpha by word
    @{${$hash}{$q}->{ANSWERS}} 
      = sort {return &word_of( $a ) cmp &word_of ( $b );}
        @{${$hash}{$q}->{ANSWERS}};
  }

  close F;

}

&ingest_file( \%ANSWERS, $opt_a );
&ingest_file( \%CHECK,   $opt_c );

my @ANSWERS = sort keys %ANSWERS;

# Now we have two hashes, one with answers and one to check them against

open RIGHT, ">/tmp/right.txt" or die "Failed to open RIGHT ($!)";
open WRONG, ">/tmp/wrong.txt" or die "Failed to open WRONG ($!)";
foreach my $q (sort keys %CHECK)
{
  my $passed = 1;
  my $a = shift @ANSWERS;

  if ( ! defined $a || $a gt $q )
  {
    die "Question not found in answers:  $q";
  }

  if ( ! defined $q || $a lt $q )
  {
    die "Extraneous question found in answers:  $a";
  }

  my @REFERENCE = @{$CHECK{$q}->{ANSWERS}};
  my @TEST      = @{$ANSWERS{$q}->{ANSWERS}};

  my $pass = 1;
  while (@TEST)
  {
    my $try = shift @TEST;
    my $ref = shift @REFERENCE;
    last unless ( defined $ref || defined $try );
    # print "Checking $try against $ref\n";
    if ( ! defined $ref || ( &word_of( $try ) lt &word_of( $ref ) ) )
    {
      print "Failed $q for fake $try\n";
      $passed = 0;
      unshift @REFERENCE, $ref;
    }
    elsif ( ! defined $try || ( &word_of( $try ) gt &word_of( $ref ) ) )
    {
      print "Failed $q for missed $ref\n";
      $passed = 0;
      unshift @TEST, $try;
    }
    elsif ($try ne $ref) 
    { 
      $pass = 0; 
      $passed = 0;
      print "Failed $q for $try ne $ref\n";
    }
  }
  if ( $passed )
  {
    print RIGHT "$q\n";
  }
  else
  {
    print WRONG "$q\n";
  }

}
close WRONG;
close RIGHT;