Distributes stories to judges (using input from UNIX wc)

JudgeDistr.pl

#!/usr/bin/perl -w

use warnings;
use strict;
use List::Util qw/shuffle min sum/;
use feature qw/say/;
use utf8;

# Usage: 
# $wc *.txt | $0 <outfile>
my $outfile = shift or die "No args given";
if(-e $outfile) {
	die "$outfile is not writable" unless -w $outfile;
}
open WRITE, ">", $outfile;

#How many stories each participant will read
use constant SIZE => 6; 

# Parse input from the Unix wc function.
#
# Story info is stored in a hash where 
#   keys   are the story names, and
#   values are their word counts
my %w;
while (<STDIN>) {
	if (/\s+\d+\s+(\d+)\s+\d+\s+(.+)\.txt/) {
		my($words, $story) = ($1, $2);
		$w{$story} = $words;
	}
}

die "Need more stories" if keys %w <= SIZE;

# Define system state hash, %s. 
# 
#   keys are the story names, and
#   values are SIZE random story names that are not equal to each other and are
# not the same as the key (a judge should not be assigned his/her own story,
# nor should a judge have the same story twice).
# 
# Each story is in the system SIZE times.
my @keys = keys %w;

my %s;
$s{$_} = [] for @keys;

for(1..SIZE) {
	my @e = @keys;
	while(collisions_exist(\@e, \@keys, \%s)) {
		@e = shuffle(@e);
	}
	
	my $n = @e;
	
	for(my $i = 0; $i < $n; $i++) {
		my $pool = $s{$keys[$i]};
		push @$pool, $e[$i];
	}
}

#Main algorithm
for(my $i = 0; $i <= 1000; $i++) {
	
	#Define two random cells to be swapped
	my $cell1 = {
		x => int rand(SIZE),
		y => int rand(@keys),
	};
	my $cell2 = {
		x => int rand(SIZE),
		y => int rand(@keys),
	};
	
	#No point swapping cells between the same judge
	redo if $cell1->{y} == $cell2->{y};
	
	my $judge1 = $keys[$cell1->{y}];
	my $judge2 = $keys[$cell2->{y}];
	my $pool1  = $s{$judge1};
	my $pool2  = $s{$judge2};
	my $story1 = $pool1->[$cell1->{x}];
	my $story2 = $pool2->[$cell2->{x}];
	
	#Don't put a story in a pool if it's already there
	redo if grep {$story1 eq $_} @$pool2;
	redo if grep {$story2 eq $_} @$pool1;
	
	#Don't put a judge's own story in his/her pool
	redo if $judge1 eq $story2;
	redo if $judge2 eq $story1;
	

	my $work_init = work(\%s, \%w);
	cell_swap($cell1, $cell2, \%s, \@keys);
	my $work_new = work(\%s, \%w);
	
	if($work_new < $work_init) {
		$i = 0;
		say "New: $work_new";
	} else {
		cell_swap($cell1, $cell2, \%s, \@keys);
	}
}

say WRITE "$_\t".(sum map {$w{$_}} @{$s{$_}})."\t".join "\t", @{$s{$_}} for @keys;

#__SUBROUTINE DEFINITIONS__

# Given two cells in the system, the system hash, and the system's keys,
# swap the two cells
sub cell_swap {
	my($cell1, $cell2, $s, $keys) = @_;
	
	#It's really not all that confusing when you think about it!
	my $tmp = $s->{$keys->[$cell1->{y}]}->[$cell1->{x}];
	
	$s->{$keys->[$cell1->{y}]}->[$cell1->{x}] =
		$s->{$keys->[$cell2->{y}]}->[$cell2->{x}];
		
	$s->{$keys->[$cell2->{y}]}->[$cell2->{x}] = $tmp;
}

# Sub to check if there are any collisions, i.e., violations
# of the initial state's criteria: values != other values nor keys
sub collisions_exist {
	my($e, $keys, $s) = @_;
	
	my $n = @$e;
	
	for(my $i = 0; $i < $n; $i++) {
		return 1 if $e->[$i] eq $keys->[$i];
		my $pool = $s->{$keys->[$i]};
		return 1 if grep {$e->[$i] eq $_} @$pool;
	}
	0;
}

#Calculate the total work required of the judges in the current system
sub work {
	my($system, $w) = @_;
	
	my $work;
	for my $key (keys %$system) {
	
		my $sum;
		for my $i (0..SIZE-1) {
			$sum += $w->{$system->{$key}->[$i]};
		}
		
		$work += $sum*($sum+1)/2;
	}
	
	return $work;
}