#!/usr/local/bin/perl
# curve
#------------------------------------------------------------------------------
# curve is a simple command-line Perl program designed to set an exam curve, 
# a tedious task familiar to most university teachers.
#
# To use curve, open a unix/linux scrolling terminal window 
# ('scrolling' to see all the output) and at the command prompt type
#
#    curve POINTS FILE1 FILE2 FILE3 ... FILEn
#
# where POINTS is the (nonnegative integer) maximum points possible on the 
# exam and FILEi (for 1 <= i <= n) is a text file of scores with 
# at most one nonnegative decimal score per line.  
# POINTS is used only to set the histogram size.
# In FILEi blank lines or lines beginning with '#' will be ignored, and  
# lines containing two or more scores or scores not of the form 
# x or x.y (x and y nonempty words over the alphabet {0,...,9}) 
# will cause an error message.
#
# curve can be altered easily to use grade values other than 
# the University of Wisconsin-Madison's 'F D C BC B AB A' by
# simply changing the values of the @grades array (down about 35 lines)
# and the method grade_point (down about 500 lines).
#
# curve is my first major Perl program, and so could probably be written
# much better.  If you'd like to modify it for the good of humanity,
# feel free, as it's open source.  
#
# Credits. Thanks to Prof. Joel Robbin whose curve setting program
# inspired this one, to Rob Owen for testing and his Perls of wisdom, and
# to Holly Swisher for helping with a curvy 'CURVE' on the welcome page.
#
# --Alex Raichev
#   version 1.0: Summer 2003, University of Wisconsin-Madison, math department
#   version 1.1: Oct 2003
#   version 1.2: 09 Dec 2003
#   version 1.3: 13 May 2004 (modified to handle decimal scores)
#------------------------------------------------------------------------------
use strict;
use POSIX qw(ceil floor);
use Term::ANSIColor;

# create some variables which are, for the most part, self-explanatory
my ($last_grade,$points,$quit,$line_number,$err_msg,$N,$sum,$gpa,$mean,
    $sum_dist,$sd,$bin_size,$mode,$choice,$grade,$cutoff,$tally,$percent,
    $label,$mark);
my (@grades,@line,@scores,@quartiles,@cutoffs,@tallies,@percents,@marks);

# if program was started incorrectly give some advice and exit program
if (@ARGV < 2 || $ARGV[0] =~ /\D/) {
  print <<"ERROR";
To run curve type 

   `curve POINTS FILE1 FILE2 FILE3 ... FILEn'

where POINTS is the (natural number) maximum points possible on the exam and
FILEi (for 1 <= i <= n) is a text file of scores with 
at most one nonnegative decimal score per line.  
POINTS is used only to set the histogram size.
In FILEi blank lines or lines beginning with '#' will be ignored, and  
lines containing two or more scores or scores not of the form
x or x.y (x and y nonempty words over the alphabet {0,...,9}) 
will cause an error message.

By the way, curve's source code can be altered easily to use grade values
other than the University of Wisconsin-Madison's "F D C BC B AB A".  
See the source code header for more details.

ERROR
  exit;
}

# set your grade values here, listed in decreasing order of excellence
# these are the grades we use at the University of Wisconsin-Madison
@grades = ("A","AB","B","BC","C","D","F"); 

# a number often used in loops
$last_grade = @grades-1;

# maximum points possible (e.g. what is the exam out of)
# only used in setting initial cutoffs and histogram scale
$points = shift; 

# read scores from files ingnoring lines that begin with # and blank lines
$quit = 0;
$err_msg = "You didn't give me any scores.";
while (<>) {
  chop;
  next if (/^\#/ || /^\s*$/); 
  @line = split;
  s/\s+//g;   
  if (@line > 1) {
    $err_msg = "There's an error in file $ARGV on line $..\nIt contains more than one item: @line.";
    $quit = 1;
    last;
  }elsif (!(/^\d+(\.\d+)?$/)) {
    $err_msg = "There's an error in file $ARGV on line $..\nIt contains the nonscore $_";
    $quit = 1;
    last;
  }else {push(@scores,$_);}
  close ARGV if eof;  # resets the line number variable $. to 0 for each new file
}

# if a score file contains bad input output error and exit program
if ($quit || !@scores) {
  print "$err_msg \nI quit.\n\n";
  exit;
}

# sort scores in increasing order
@scores = sort {$a <=> $b} @scores; 

# compute the statistics that won't change
$N = @scores;  # number of scores
# the mean
$sum = 0;
foreach (@scores) {$sum += $_} 
$mean = &round($sum/$N,1);	
# the standard deviation
foreach (@scores) {$sum_dist += ($_ - $mean)**2;}
$sd = &round(sqrt($sum_dist/($N)),1); 
# the quartiles
@quartiles = &quartiles(@scores);

# initialize @cutoffs 
# Except for the lowest cutoff which i initialize to 0, 
# i initialize all cutoffs to $points, thereby making the cutoffs independent 
# of the specific values of @grades and making it possible to set some but not 
# all cutoffs without affecting the tallies.
# Of course, you can initialize how you want.
# @cutoffs = (0,&round(.6*$points),&round(.7*$points),&round(.75*$points),
#            &round(.8*$points),&round(.85*$points),&round(.9*$points)); 
foreach ((0..$last_grade-1)) {push (@cutoffs,$points);}
push (@cutoffs,0);

# create an initial bin size for histogram
$bin_size = &round(.05*$points);

# fire up the display
&welcome;
&compute_stats;
&compute_histo;
&print_stats();
&print_menu; 
$mode = "stats";

# the main control loop
until ($quit) {
  $choice = <STDIN>;
  chop($choice);
  $choice =~ tr/a-z/A-Z/; # uppercase everything
  $choice =~ s/[\[\] ]//g; # get rid of brackets and spaces
  if ($choice eq "Q") {$quit = 1;}
  elsif ($choice eq "S") {
    &print_stats();
    &print_menu;
  }elsif ($choice eq "C") {
    &change_cutoffs;
    ($mode eq "stats") ? &print_stats() : &print_histo();
    &print_menu; 
  }elsif ($choice eq "P") {
    &change_percents;
    ($mode eq "stats") ? &print_stats() : &print_histo();
    &print_menu; 
  }elsif ($choice eq "ES") {
    print "Copy statistics to file (in current directory) => ";
    $_ = <STDIN>;
    chop;
    &print_stats($_);
    print "Statistics written to $_.\n";
    &print_menu;
  }elsif ($choice eq "H") {
    &print_histo();
    &print_menu; 
  }elsif ($choice eq "B") {
    &change_bin;
    ($mode eq "stats") ? &print_stats() : &print_histo();
    &print_menu;
  }elsif ($choice eq "EH") {
    print "Copy histogram to file (in current directory) => ";
    $_ = <STDIN>;
    chop;
    &print_histo($_);
    print "Histogram written to $_.\n";
    &print_menu;
  }else {print "Bad input. Try again. \nOption choice => ";}
}
print "Bye bye.\n\n";

# formats and subroutines
#------------------------------------------------------------------------------
# statistics menu 1
format STATS1 =
|  @>>>   @>>>>>>>>>>>   @>>>>>>>>>>>   @>>>>>>>>>>> |  
$grade,$cutoff,$tally,$percent
.
#------------------------------------------------------------------------------
# statistics menu 2
format STATS2 =
|----------------------------------------------------|  
| points possible:        	        @>>>>>>>>>>> |  
$points
| number of scores: 		        @>>>>>>>>>>> |
$N
| mean:			         @>>>   @>>>>>>>>>>> |
&grade($mean),$mean
| quartiles:  @>>>>>>>>>>> @>>>>>>>>>>> @>>>>>>>>>>> |
$quartiles[0],$quartiles[1],$quartiles[2]
| standard deviation:    	        @>>>>>>>>>>> |
$sd
| grade point average:			@>>>>>>>>>>> |
$gpa
 ====================================================
.
#------------------------------------------------------------------------------
# histogram
format HISTO =
 @>>>>>>>> -|@<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 $label,$mark	    
.
#------------------------------------------------------------------------------
# Prints welcome page.
sub welcome {
  system("clear");
  print <<'WELCOME';
 *----------------------------------------* 
*                    _              	   *
|            __ | | |_) \  /  __     	   |
|           |   |_| | \  \/  |__     	   |
|           |__              |__     1.3   |
|                                          |
| A little program designed for taking 	   |
| the drudgery out from exam curve making. |
|                                          |
| --Written in Perl by Alex Raichev 	   |
|   at the University of Wisconsin-Madison |
|   Summer 2003                            |
*                      			   *
 *----------------------------------------* 

Best viewed with a scrolling terminal window.

Hit enter to begin...
WELCOME
  $_ =<STDIN>;
}
#------------------------------------------------------------------------------
# Prints options menu.
sub print_menu {
  my $S  = colored("S",'bold');
  my $C  = colored("C",'bold');
  my $P  = colored("P",'bold');
  my $ES = colored("ES",'bold');
  my $H  = colored("H",'bold');
  my $B  = colored("B",'bold');
  my $EH = colored("EH",'bold');
  my $Q  = colored("Q",'bold');
  print <<"MENU";

* OPTIONS MENU *
 -----------------------------------------------------------------
| STATISTICS --> $S\:show   $C\:cutoffs     $P\:percentages   $ES\:export |
|                                                                 |
| HISTOGRAM  --> $H\:show   $B\:bin size   $EH\:export                  |
|                                                        $Q\:quit   |
 -----------------------------------------------------------------
MENU
  print "Option choice => ";
}
#------------------------------------------------------------------------------
# Computes statistics that can change.
sub compute_stats {
  # reset @tallies to all zeros 
  foreach ((0..$last_grade)) {$tallies[$_] = 0;}
  # recalculate @tallies
  foreach (@scores) {
    # if this score corresponds to a grade then tally one more for that grade
    # note that it is possible for a score not to correspond to a grade,
    # for the cutoffs could've been set really high
    if (&grade($_)) {++$tallies[&grade_index(&grade($_))];}}
  # recalculate @percents
  foreach ((0..$last_grade)) {
    $percents[$_] = &round( 100*($tallies[$_]/$N),1 ) . " \%"; 
  }
  # compute the mean GPA
  my $sum = 0;
  foreach (@scores) {$sum += &grade_point(&grade($_));} 
  $gpa = &round($sum/$N,2);
}
#------------------------------------------------------------------------------
# Prints all statistics to screen or to $filename if given.
sub print_stats {
  my ($filename,$ofh);
  $filename = shift || "";
  system("clear");
  # if $filename is given print to that file
  if ($filename ne "") {
    $ofh = *FILE;
    open($ofh,"> $filename") || die "Can't create that file";
  }# otherwise print to screen
  else {$ofh = *STDOUT;}
  # use STATS1 format 
  select($ofh);
  $~ = "STATS1";  
  # print first table
  print "* STATISTICS *\n";
  print " ==================================================== \n";  
  print "| grade         cutoff          count     percentage |\n";  
  foreach (0..$last_grade) {
    $grade   = $grades[$_];
    $cutoff  = $cutoffs[$_];
    $tally   = $tallies[$_];
    $percent = $percents[$_];
    write; 
  }  
  # switch to STATS2 format
  $~ = "STATS2";  
  # print second table
  write; 
  # clean up
  if ($filename ne "") {close($ofh)};
  select(STDOUT);
  $mode = "stats";
}
#------------------------------------------------------------------------------
# Gets new cutoffs from user and replaces old cutoffs with them.
sub change_cutoffs {
   my ($quit,$changes,$grade,$cutoff,$good_input);
   my @changes;
   $quit = 0;
   until ($quit) {
     print "Enter some cutoffs (`",
	   $grades[0],":",&round(.9*$points)," ", 
           $grades[1],":",&round(.8*$points), 
	   "' for example) or `X' to cancel.\n=> ";
     $changes = <STDIN>;
     chop($changes);
     $changes =~ tr/a-z/A-Z/; # uppercase everything
     $changes =~ s/^\s*([A-Z0-9: ]*)\s*$/$1/; # get rid of extra spaces
     @changes = split(/\s+/,$changes);
     if ($changes[0] eq "X") {$quit = 1}
     else { # check input 
       $good_input = 1;
       if ($changes eq "") {$good_input = 0;}
       else {
         foreach (@changes) {
           ($grade,$cutoff) = split(/:/,$_);
           if (&grade_index($grade) < 0 || $cutoff !~ /^\d+(\.\d+)?$/ 
	       || $cutoff > $points ) {
             $good_input = 0;
	     last;
           }
	 }
       }
       # if input makes sense change cutoffs 
       if ($good_input) {
         foreach (@changes) {
           ($grade,$cutoff) = split(/:/,$_);
	   $cutoffs[&grade_index($grade)] = $cutoff;
	 }
	 &compute_stats;
	 $mode = "stats";
	 $quit = 1;
       }# otherwise try again
       else {print "Bad input. Try again.\n";}  
     }
   }
}
#------------------------------------------------------------------------------
# Gets new percentages from user and replaces old percentages with them
# as closely as possible by changing the cutoffs from the lowest grade on up.
# Rounding leftovers get lumped together in the highest grade.
# In short, fills in from bottow up.
sub change_percents {
   my ($quit,$changes,$good_input,$sum,$count,$total_count,$error);
   my @changes;
   $quit = 0;
   until ($quit) {
     print "Enter all percentages in the order @grades \n";
     # print an example of good input (without using the specifics of @grades)
     print "(`";
     $sum = 0;
     foreach ((0..$last_grade-1)) {
       $sum += &round(100/@grades);
       print &round(100/@grades) . " ";
     }
     print 100-$sum . "' for example) or `X' to cancel.\n=> ";  
     # read input
     $changes = <STDIN>;
     chop($changes);
     $changes =~ tr/a-z/A-Z/; # uppercase everything
     $changes =~ s/^\s*([A-Z0-9 ]*)\s*$/$1/; # get rid of extra spaces
     @changes = split(/\s+/,$changes);
     if ($changes[0] eq "X") {$quit = 1}
     else { # check input 
       $good_input = 1;
       if (@changes != @grades) {
         $good_input = 0;
	 $error = "Incorrect number of percentages.";
       }else {
         $sum = 0;
	 foreach (@changes) {$sum += $_;}	 
         if ($sum != 100) {
	   $good_input = 0;
	   $error = "Percentages don't add up to 100 (but rather $sum).";
	 }
       }	 
       # if input makes sense change cutoffs 
       # percentages are filled in from the highest grade on down so
       # rounding leftovers get lumped together in the lowest grade
       # (whose cutoff will always be made 0)
       if ($good_input) {
         $total_count = 0;
         foreach ((0..$last_grade-1)) {
	   $count = &round(($changes[$_]/100)*$N);
	   $total_count += $count;
	   if ($total_count <= $N) {
	     $cutoffs[$_] = $scores[$N - $total_count]; 
	     # since @scores is sorted increasing order
	   }else {$cutoffs[$_] = 0;}
	 }
	 $cutoffs[$last_grade] = 0;
	 &compute_stats;
	 $mode ="stats";
	 $quit = 1;
       }# otherwise try again
       else {print "$error Try again.\n";}  
     }
   }
}
#------------------------------------------------------------------------------
# Computes relevant histogram quantities.  
sub compute_histo {
   # reset @marks
   # @marks holds the x's (visual count) for each bin of the histogram
   @marks = ();
   # calculate @marks
   foreach (@scores) {$marks[floor($_/$bin_size)] .= "x";}
}
#------------------------------------------------------------------------------
# Prints histogram to screen or to $filename if given.
sub print_histo {
  my ($filename,$ofh);
  $filename = shift || "";
  system("clear");
  # if $filename is given print to that file
  if ($filename ne "") {
    $ofh = *FILE;
    open($ofh,"> $filename") || die "Can't create that file";
  }# otherwise print to screen
  else {$ofh = *STDOUT;}
  # use HISTO format when printing
  select($ofh);
  $~ = "HISTO";  
  # print
  print "* HISTOGRAM *\n";
  print "Number of scores = $N    Bin size = $bin_size\n\n";
  my $i;
  for ($i = 0; $i <= ceil($points/$bin_size); $i++) {
    $label = $i*$bin_size;
    $mark  = $marks[$i] || "";
    write;
  }   
  # clean up
  if ($filename ne "") {close($ofh)};
  select(STDOUT);
  $mode = "histo";
}
#------------------------------------------------------------------------------
# Gets new bin size for histogram from user and replaces old bin size with it.
sub change_bin {
   my ($quit,$change);
   $quit = 0;
   until ($quit) {
     print "Enter bin size (currently bin size = $bin_size) " . 
           "or `X' to cancel => ";
     $change = <STDIN>;
     chop($change);
     $change =~ tr/a-z/A-Z/; # uppercase everything
     $change =~ s/^\s*([A-Z0-9 ]*)\s*$/$1/; # get rid of extra spaces
     if ($change eq "X") {$quit = 1}
     else {
       # check input 
       if ($change eq "" || $change =~ /\D/ || $change > $points || $change == 0) {
         print "Bad input. Try again.\n";}
       # input good, change bin size
       else {
         $bin_size = $change;
	 &compute_histo;
	 $mode = "histo";
	 $quit = 1;
       }
     }
   }
}
#------------------------------------------------------------------------------
# Returns the highest grade for which the input is >= its cutoff or returns ""
# if there is no such grade. Note that the latter case can occur; 
# for instance, the cutoffs could've been set really high.
sub grade {
  my $value = shift;
  foreach (0..$last_grade) {
    if ($value >= $cutoffs[$_]) {return $grades[$_];}
  }
  return "";
}
#------------------------------------------------------------------------------
# Returns the grade points for which the input grade corresponds or returns 0
# if there are no such grade points. Note that the latter case can occur; 
# for instance, the cutoffs could've been set really high.
# THIS IS THE ONLY GRADE SPECIFIC METHOD OF CURVE.
sub grade_point {
  my $grade = shift;
  if    ($grade eq "A")  {return 4;}
  elsif ($grade eq "AB") {return 3.5;}
  elsif ($grade eq "B")  {return 3;}
  elsif ($grade eq "BC") {return 2.5;}
  elsif ($grade eq "C")  {return 2;}
  elsif ($grade eq "D")  {return 1;}
  else 			 {return 0;}
}
#------------------------------------------------------------------------------
# Returns the index of the input in @grades or -1 if there's no such index. 
sub grade_index {
  my $grade = shift;
  foreach ((0..$last_grade)) {
    if ($grade eq $grades[$_]) {return $_;}
  }
  return -1;
}
#------------------------------------------------------------------------------
# Returns an array of three elements, 
# the quartiles (rounded to one decimal place) for the input array (of numbers)
sub quartiles {
   my ($n,$n1,$n2,$Q1,$Q2,$Q3);
   my (@a,@a1,@a2);
   
   @a = @_;
   $n = @a;
   if ($n%2 == 1) {
      $Q2 = $a[floor($n/2)];
      @a1 = @a[(0..floor($n/2))];
      @a2 = @a[(floor($n/2)..$n-1)];
   }else {
      $Q2 = ($a[$n/2 - 1] + $a[$n/2]) / 2;
      @a1 = @a[(0..$n/2 - 1)];
      @a2 = @a[($n/2..$n-1)];
   }
   $n1 = @a1;
   if ($n1%2 == 1) {$Q1 = $a1[floor($n1/2)];}
   else {$Q1 = ($a1[$n1/2 - 1] + $a1[$n1/2]) / 2;}
   $n2 = @a2;
   if ($n2%2 == 1) {$Q3 = $a2[floor($n2/2)];}
   else {$Q3 = ($a2[$n2/2 - 1] + $a2[$n2/2]) / 2;}
   return (&round($Q1,1),&round($Q2,1),&round($Q3,1));
}
#------------------------------------------------------------------------------
# Returns the rounded value of the input to $places places after decimal point.
# If $places is not specified, it rounds to the nearest integer.
sub round {
  my ($value,$places);
  $value = shift || return 0;
  $places = shift || 0;
  return sprintf "%.${places}f", $value;
}