#!/usr/bin/perl
use strict;

my $delim  = ',';
my $key    = '';
my $roster = '';
my $regex  = '';
my $look   = undef;
my $perm   = '';
my @F      = ();

while ( 1 )
{
	my $f = lc shift;
	
	if ( length $f < 1 )
	{
		last;
	}
	
	if ( $f eq '-d' )
	{
		$delim = shift;
		eval( "\$delim = \"$delim\";" );
	}
	elsif ( $f eq '-f' )
	{
		my $filelist = shift;
		@F = split( /,/, $filelist );
	}
	elsif ( $f eq '-h' )
	{
		print <<EOH;
Usage: perl gradebook.pl [-f [file1,file2]|-re [regex]] [-k file] [-r file]
                         [-d delim] [-L ver ques ans] [-p file] [-h]

  -d is the file-internal delimiter; defaults to ",", but "\\t" is common

  -f is the (comma-separated) list of input grade files
	
  -k is the answer key; script will default to pulling scores directly from the
     grade files, but if key is specified script will manually grade exams

     Key format is
     /[regex]/ [answers1]
     /[regex]/ [answers2]
     ...etc...
     Here, [regex] is for pattern-matching the special code entered on the exam.
     Answer format for standard answers is ABCEDBA if the first seven answers
     are A, B, C, E, D, B, A; for multiple-correct answers, use [ACD] (braces
     included) in place of a single letter; use - to ignore a question

     As an example:
     /1/ AB-[BD]
     /2/ D-[BA]A
     
  -L lists all students with version [ver] who responded [ans] to question
     [ques]; this is a feature for finding "reasonable" answers to ill-posed
     questions that might be supported by on-exam work. Pray you never have to
     use it.
     
  -p is a file of exam permutations; aligns questions by labels and spits out
     responses so that you can see which questions had the highest error rates;
     assumes that the same question has the same answers, on different versions
     of the exam; results dump to filename, appended with '-out'
     
     Key format is
     /[regex]/ [label1] [label2] ...
     /[regex]/ [label3] [label1] ...
     ...etc...
     Here, question 1 of the first version is the same as question 2 of the
     second; a good default label is the question number on the first version
     of the exam, but labels such as "consumer-choice-i" will also be okay;
     whitespace is not acceptable in question labels
     
     As an example:
     /1/ 1 silly-question 3 4              5
     /2/ 3              4 1 5 silly-question
	   
  -r is the [delim]-delimited class roster from MyUCLA
	
  -re is a regular expression for file-matching

  -h shows this help

	
Note: one of -f or -re must be specified.
EOH

		exit 1;
	}
	elsif ( $f eq '-k' )
	{
		$key = shift;
	}
	elsif ( $f eq '-l' )
	{
		$look = {
			version  => shift,
			question => shift,
			answer   => shift
		};
	}
	elsif ( $f eq '-p' )
	{
		$perm = shift;
	}
	elsif ( $f eq '-r' )
	{
		$roster = shift;
	}
	elsif ( $f eq '-re' )
	{
		$regex = shift;
	}
	else
	{
		print "Unrecognized flag $f; use -h for help.\n";
		exit 2;
	}
}

if ( length $regex > 0 )
{
	opendir( DIR, '.' );
	my @FILES = readdir( DIR );
	closedir( DIR );
	
	for ( @FILES )
	{
		if ( /$regex/ )
		{
			push @F, $_;
		}
	}
}

if ( length $perm > 0 && !-e $perm )
{
	print "Error: permutation file '$perm' does not exist; use -h for help.\n";
	exit 8;
}

my $use_perm = length $perm > 0;
my $perms    = [];
if ( $use_perm )
{
	open( PERM, "<$perm" );
	
	while ( <PERM> )
	{
		chomp;
		
		/\/([^\/]+)\/\s+(.*)/;
		
		my $this_perm = { key => $1 };
		my @labels    = split /\s+/, $2;
		
		$this_perm->{labels} = \@labels;
		my $solns = [];
		
		for ( 0 .. $#labels )
		{
			my @Z = qw(0 0 0 0 0);
			push @$solns, \@Z;
		}
		$this_perm->{solns} = $solns;
		
		push @$perms, $this_perm;
	}
}

if ( defined $look )
{
	if ( $look->{version} !~ /^\d+$/ )
	{
		print "Error: version specified by -L is non-numeric; use -h for help.\n";
		exit 5;
	}
	
	if ( $look->{question} !~ /^\d+$/ )
	{
		print "Error: question specified by -L is non-numeric; use -h for help.\n";
		exit 6;
	}
	
	if ( $look->{answer} !~ /^[A-E\-]$/i )
	{
		print "Error: answer specified by -L is not one of A, B, C, D, E, or -; use -h for help.\n";
		exit 7;
	}
}

my $found      = [];
my $use_key    = length $key > 0;
my $use_roster = length $roster > 0;
my $K          = [];
if ( $use_key )
{
	if ( !-e $key )
	{
		print "Error: key file $key does not exist; use -h for help.\n";
		exit 4;
	}

	my $toint = -ord( 'A' ) + 1;
	open( KEY, "<$key" );
	while ( <KEY> )
	{
		chomp;
		$_ =~ /\/([^\/]+)\/\s+(.*)/;

		my $kk = {
			code => $1,
			ans  => []
		};

		my $ans = uc $2;
		for ( my $i = 0; $i < length $ans; ++$i )
		{
			my $c = substr( $ans, $i, 1 );

			if ( $c =~ /[A-E\-]/i )
			{
				push( @{$kk->{ans}}, ord( $c ) + $toint );
			}
			elsif ( $c eq '[' )
			{
				my $cc = '';

				while ( ++$i < length $ans )
				{
					if ( substr( $ans, $i, 1 ) eq ']' )
					{
						push( @{$kk->{ans}}, "[$cc]" );
						last;
					}

					$cc .= ord( substr( $ans, $i, 1 ) ) + $toint;
				}
			}
			elsif ( $c !~ /\s/ )
			{
				print "Error: key file contains invalid character '$c'; use -h for help.\n";
				exit 6;
			}
		}

		push @$K, $kk;
	}
	close( KEY );
}

if ( length $roster > 0 && !-e $roster )
{
	print "Error: roster file $roster does not exist; use -h for help.\n";
	exit 5;
}

if ( $#F == -1 )
{
	print "Error: must specify file inputs; use -h for help.\n";
	exit 3;
}



my $OFFSET_CODE     = XLtoAR( 'AN' );
my $OFFSET_EXAM     = XLtoAR( 'BM' );
my $scores          = {};
my $exam_count      = 0;
my $student_count   = 0;
my $unmatched_count = 0;

my $Lversion  = -1;
my $Lquestion = -1;
my $Lanswer   = 0;

if ( defined $look )
{
	$Lversion  = $look->{version};
	$Lquestion = $look->{question};
	$Lanswer   = ord( uc $look->{answer} ) - ord( 'A' ) + 1;
	
	if ( $look->{answer} eq '-' )
	{
		$Lanswer = 0;
	}
}

for my $f ( @F )
{
	if ( -e $f )
	{
		open( INPUT, "<$f" );
		while ( <INPUT> )
		{
			chomp;
			
			my @A    = split /$delim/;
			my $id   = $A[34];
			my $fn   = $A[36];
			my $ln   = $A[35];
			my $s    = 0;
			my $code = $A[$OFFSET_CODE];
			
			$id =~ s/[^\d]+//g;
			$id =~ s/(\d{3})(?!$)/$1\-/g;
			$fn =~ s/(?:^\s+|")//g;
			$ln =~ s/(?:^\s+|")//g;
			$s  =~ s/[^\d]+//g;

			++$exam_count;

			if ( !$use_key )
			{
				$s = $A[53];
			}
			else
			{
				my $kcode;
				my $a;
				my $r;

				for my $k ( @$K )
				{
					$kcode = $k->{code};
					if ( $code =~ /$kcode/ )
					{
						for my $q ( 1 .. @{$k->{ans}} )
						{
							$a = $k->{ans}->[$q - 1];
							$r = $A[$OFFSET_EXAM + $q - 1 ];
							
							if ( $kcode == $Lversion && $q == $Lquestion && $r =~ /$Lanswer/ )
							{
								push( @$found, "$id: $ln, $fn" );
							}
							
							if ( $a !~ /\-/ )
							{
								$s += $r =~ /$a/;
							}
							
							if ( $use_perm && $r > 0 )
							{
								for ( 0 .. $#{$perms} )
								{
									my $pcode = $perms->[$_]->{key};
									if ( $code =~ /$pcode/ )
									{
										$perms->[$_]->{solns}->[$q - 1]->[$r - 1] += 1;
										last;
									}
								}
							}
						}

						$code = $kcode;
						
						last;
					}
				}
			}
			
			# $code =~ s/^"(.*)"$/$1/g;

			my $student = {
				code      => $code,
				firstname => $fn,
				id        => $id,
				lastname  => $ln,
				score     => $s
			};

			if ( $use_roster )
			{
				$scores->{$id} = $student;
			}
			else
			{
				$scores->{$ln . ', ' . $fn . ', ' . $id} = $student;
			}

			if ( !$s )
			{
				print STDERR "ALERT: student $ln, $fn has score 0 with special code '$code'. (file: $f)\n";
			}

			if ( length $id < 1 )
			{
				print STDERR "ALERT: student $ln, $fn specified no UID. (file: $f)\n";
			}
		}
		close( INPUT );
	}
	else
	{
		print STDERR "File $f not found.\n";
		exit 7;
	}
}

if ( $use_roster )
{
	my $used = {};
	
	open( ROSTER, "<$roster" );
	while ( <ROSTER> )
	{
		chomp;
		$_ =~ s/[\r\n]+//g;

		if ( !/^\d{3}\-\d{3}\-\d{3}/ )
		{
			print $_ . "\n";
		}
		else
		{
			# look up student and print
			my @A = split /$delim/;
			++$student_count;

			if ( !defined $scores->{$A[0]} )
			{
				print STDERR "ALERT: cannot find score for $A[1] ($A[0]); assigning 0.\n";

				printf( "%s%s%d%s%s\n", $_, $delim, 0, $delim, '#' );
			}
			else
			{
				my $student = $scores->{$A[0]};

				printf( "%s%s%s%s%s\n", $_,                $delim,
				                        $student->{score}, $delim,
				                        $student->{code} );

				$used->{$A[0]} = 1;
			}
		}
	}
	close( ROSTER );

	for ( keys %$scores )
	{
		if ( !$used->{$_} )
		{
			my $code = $scores->{$_}->{code};
			print STDERR "ALERT: exam UID $_ (code $code) cannot be located on roster.\n";

			++$unmatched_count;
		}
	}
}
else
{
	for ( sort keys %$scores )
	{
		my $student = $scores->{$_};

		printf( "%s%s%s%s%s%s%d%s%s\n", $student->{lastname},  $delim,
		                                $student->{firstname}, $delim,
		                                $student->{id},        $delim,
		                                $student->{score},     $delim,
		                                $student->{code} );
	}
}

if ( defined $look )
{
	print STDERR "\n\nLOOKED FOR version $Lversion, question $Lquestion, answer $Lanswer. Found " . ( scalar @$found ) . " results.\n";
	
	if ( scalar @$found < 1 )
	{
		print STDERR "(no results)\n";
	}
	else
	{
		for ( @$found )
		{
			print STDERR $_ . "\n";
		}
	}
}

if ( $use_perm )
{
	my $labels  = $perms->[0]->{labels};
	my $permout = $perm;
	
	if ( $permout =~ /\./ )
	{
		$permout =~ s/(\.[^\.]+)$/-out\1/;
	}
	else
	{
		$permout .= '-out';
	}
	
	open( PERMOUT, ">$permout" );
	
	print PERMOUT "\t";
	for ( 0 .. $#{$perms} )
	{
		print PERMOUT $perms->[$_]->{key} . "\t\t\t\t\t";
	}
	print PERMOUT "\n\t";
	for ( 0 .. $#{$perms} )
	{
		print PERMOUT "A\tB\tC\tD\tE\t";
	}
	print PERMOUT "\n";
	
	for ( 0 .. $#{$labels} )
	{
		my $label = $labels->[$_];
		print PERMOUT $label . "\t";
		
		for ( 0 .. $#{$perms} )
		{
			my $this_perm = $perms->[$_];
			
			for ( 0 .. $#{$this_perm->{labels}} )
			{
				if ( $this_perm->{labels}->[$_] eq $label )
				{
					print PERMOUT join "\t", @{$this_perm->{solns}->[$_]};
					print PERMOUT "\t";
					last;
				}
			}
		}
		
		print PERMOUT "\n";
	}
}

if ( $use_roster )
{
	print STDERR "\n\nSUMMARY: $exam_count exams, $student_count students, $unmatched_count unmatched.\n";
}
else
{
	print STDERR "\n\nSUMMARY: exams graded (tip: use roster for more statistics)\n";
}







sub XLtoAR
{
	my $xl = shift;
	my $ar = 0;

	for ( 1 .. length( $xl ) )
	{
		$ar *= 26;
		$ar += ord( uc( substr( $xl, $_ - 1, 1 ) ) ) - ord( 'A' ) + 1;
	}

	$ar -= 1;
	return $ar;
}