#!/usr/bin/perl

# tpr04b.pl - tsort golf game test program  VERSION 1.4

use strict;

my $script = 'tsort.pl';

# -----------------------------------------------------

# [data, should_fail]

my @cases = (

[<<END, 0],
a b
c d
b c
END

[<<END, 0],
a d
c d
b d
END

[<<END, 0],
b c
f g
e f
e f
a b
END

[<<END, 0],
a a
b b
END

[<<END, 1],
a b
b a
END

[<<END, 0],
..... .....
.... ....
... ...
.. ..
END

[<<END, 0],
..... .....
.... ....
.... ....
... ...
.. ..
END

[<<END,0],
g |
| a
a +
+ *
* [
[ ]
] (
( )
END

[<<END,1],
g |
| a
a +
+ *
* [
[ ]
] (
( |
( )
END

[<<END, 1],
..... ....
..... ...
.... ....
... ...
.. ..
END

[<<END, 0],
one two
two three
three four
four five
five six
six seven
seven eight
eight nine
nine ten
END

[<<END, 0],
nine ten
eight nine
seven eight
six seven
five six
four five
three four
two three
one two
END

[<<END, 0],
tennine ten
eight tennine
nine three
one nine
END

[<<END, 0],
nine ten
eight nine
seven eight
six seven
five six
four five
three four
two three
one two
nine ten
eight nine
seven eight
six seven
five six
four five
three four
two three
one two
END

);

# -----------------------------------------------------

# get file contents for scoring and validation

open IN, $script or die "could not open $script: $!";
my $contents = join '', <IN>;
close IN;

for($contents)
	{
	tr/\r//;			# remove all CRs
	s/\s*\z/\n/;	# trim end;
	/^#!perl\s/ or die "Script does not start with #!perl\\s";
	/\brand\b/ and die "Script contains rand() function";
	/[^ -~\n\t]/ and die "Script contains illegal character @{[ord $&]}";
	}

my $have_stderr_redirect = 1;

if ($^O eq 'MSWin32') {
   if (Win32::IsWinNT()) {
      print "You are running Windows NT/2000\n";
   } else {
      print "You are running Windows, but not Windows NT/2000\n";
      $have_stderr_redirect = 0;
   }
} else {
   print "Congratulations! You are not running Windows.\n";
}

sub GolfScore {
	 my $golf = length($contents) - 8;
	 my ($body) = $contents =~ /#!perl(.*)\n\z/s;
	 my $whitespace = () = $body =~ /\s/g;
	 my $letters = $body =~ tr/a-zA-Z//;	# hehe - he said tr/// not y///
	 my $total = 10 * $whitespace + 3 * $letters +
	 	1 * (length($contents) - $whitespace - $letters);
	 my $fraction = length($contents) / $total;
	 $fraction = 0.99 if $fraction > 0.99;
   return sprintf '%.2f', $golf + $fraction;
}

sub PrintGolfScore {
   my @scr = @_;
   my $tot = 0;
   for my $s (@scr) {
      my $g = GolfScore($s);
      print "$s: $g\n";
      $tot += $g;
   }
   print "You shot a round of $tot strokes.\n";
}

sub BuildFile {
   my ($fname, $data) = @_;
   local (*FF);
   open(FF, '>'.$fname) or die "error: open '$fname'";
   print FF $data;
   close(FF);
}

my $testnumber = 1;

sub CheckOneTsort {
   my ($data, $shouldfail) = @_;
   my $intmp  = 'in.tmp';
   my $errtmp = 'err.tmp';
   BuildFile($intmp, $data);
   my $cmd = "$^X $script $intmp";
   $cmd .= " 2>$errtmp" if $have_stderr_redirect;
   printf "%3d: running: '$cmd'...", $testnumber++;
   my $out = `$cmd`;
	 my $rc = $? >> 8;
   print "done.\n";
	 if($shouldfail)
	 	{
		die "\nOops, you failed to exit with a non-zero exit code for case:\n$data"
			unless $rc;
		return 1;	# it passed
		}
	 else
	 	{
		die "\nOops, failed, you exited with a non-zero exit code $rc for case:\n$data"
			if $rc;
		}
   if ($have_stderr_redirect) {
			if(-s $errtmp)
				{
				open ERR, $errtmp or die "error $! opening $errtmp";
				local $/;
				print <ERR>;
				close ERR;
        die "oops, you wrote to stderr (see $errtmp)\n";
				}
   } else {
      warn "warning: cannot check you did not write to" .
           " stderr on this platform.\n";
   }
	 if (not ValidateTsort($data, $out)) {
      die "\nOops, you failed.\n";
   }
}

# -----------------------------------------------------

sub ValidateTsort
	{
	my ($input, $output, %names, %positions, @positions) = @_;
	die "output has space or tab at end of line for case:\n$input"
		if $output =~ /[ \t]\n/;
	die "output is not formatted properly for case:\n$input"
		unless $output =~ /^([!-~]+\n)+\z/;
	@names{$input =~ /[!-~]+/g} = ();
	@positions = $output =~ /[!-~]+/g;
	@positions == keys %names or
		die "output has incorrect number of node names for case:\n$input";
	"@{[sort keys %names]}" eq "@{[sort @positions]}" or
		die "output node names do not match input node names for case:\n$input";
	@positions{@positions} = 1 .. @positions;
	while( $input =~ /([!-~]+)\s+([!-~]+)/g )
		{
		$positions{$1} <= $positions{$2} or
			die "$1 is after $2 in output, should be before for case:\n$input";
		}
	return 1;
	}

sub CheckTsort {
   my ($scr) = @_;
   for my $r (@cases) { CheckOneTsort($r->[0], $r->[1]) }
}

# -----------------------------------------------------

select(STDERR);$|=1;select(STDOUT);$|=1;  # auto-flush
-f $script or die "error: file '$script' not found.\n";
PrintGolfScore($script);
CheckTsort($script);
PrintGolfScore($script);
print "\nHooray, you PASSED.\n\n";

#use File::Slurp;
#append_file 'run.log', "Score: @{[GolfScore()]}  @{[
	#scalar localtime]}\n\n$contents\n";