# В этот файл собраны процедуры, общие для всей системы
# работы с ответами.
#
#$Id: subroutines.pl,v 3.4 2013/10/30 20:29:22 boris Exp $
#
sub readhash
{
my ($answers) = @_;
my $answer = "";
my $score = "";
my $number = -1;
while (<INFILE>)
{
if (/^\s*\#(\d+).*Score:\s*([+-\?])/) # Нашли новый ответ
{
if ($DEBUG)
{
print STDERR "\#$number. Score: $score\n",$answer;
}
if ($answer ne "" && $number >= 0)
{
$$answers[$number]->{$answer}->{score} = $score;
%{$$answers[$number]->{$answer}->{teams}} = ();
}
$answer = "";
$number = $1;
$score = $2;
next;
}
if (/^Team:/)
{
next;
}
if (/^\s*\*\*\*\s*$/)
{
if ($answer ne "" && $number >= 0)
{
$$answers[$number]->{$answer}->{score} = $score;
}
last;
}
$answer .= &canonize_answer;
}
return 1;
}
#
# Читаем файл с письмами команд
#
sub readmail
{
my ($table) = @_;
$team="";
$number=-1;
while (<INFILE>)
{
if (/^\s*\*\*\*\s*"(.+)"\s*[,.]*\s*(\d+)*/) # Нашли новую команду
{
if ($DEBUG)
{
print STDERR "Команда: $1, рег. номер: $2\n";
}
$team = $1;
$number = -1;
if (!exists($$table{$team})) # Новая команда...
{
my @teamanswers = ();
my %teamhash = ('answers' => \@teamanswers,
'regnum' => $2,
'numletters'=>0);
$$table{$team} = \%teamhash;
}
$$table{$team}->{'numletters'}++;
if ($$table{$team}->{regnum} != $2)
{
print STDERR "Warning: Team $team uses registration numbers ",
"'" . $$table{$team}->{regnum} . "'", " and '$2'!\n";
}
next;
}
if (s/^\s*\#(\d+)\.*// && $team ne "")
{
if ($DEBUG)
{
print STDERR "Ответ $1\n";
print STDERR;
}
$number = $1;
$$table{$team}->{answers}[$number] = &canonize_answer;
next;
}
if (/^\*\*\*/) # Команда кончилась
{
$team="";
$number=-1;
}
if ($team ne "" && $number >0)
{
if ($DEBUG)
{
print STDERR;
}
$$table{$team}->{answers}[$number] .= &canonize_answer;
}
}
return 1;
}
#
# Приводим ответ к канонической форме: два пробела в начале,
# ни одного в конце
#
sub canonize_answer
{
s/^\s*(.*?)\s*$/ $1/;
if (/^\s*$/)
{
return "";
}
else
{
return $_."\n";
}
}
#
# Заполняем поля %answers
#
sub collect_answers
{
my ($teams,$answers) = @_;
for ($i=$MINQUEST;$i<=$MAXQUEST;$i++)
{
foreach $team (keys %$teams)
{
$answer = $$teams{$team}->{answers}[$i];
if ($answer eq "")
{
next;
}
$$answers[$i]->{$answer}->{teams}->{$team}=1;
if (!exists $$answers[$i]->{$answer}->{score})
{
$$answers[$i]->{$answer}->{score} = '?';
}
}
}
return 1;
}
#
# Сбрасываем ответы на вопрос $number с оценкой $symbol
#
sub dumphash
{
my ($teams,$answers,$number,$symbol) = @_;
foreach $answer (keys %{$answers->[$number]})
{
if ($$answers[$number]->{$answer}{score} eq $symbol)
{
print "\#$number. Frequency: ",
scalar keys %{$answers->[$number]->{$answer}->{teams}},
". Score: ",
$$answers[$number]->{$answer}{score},"\n";
print $answer;
if ($DEBUG)
{
foreach $team (keys %{$answers->[$number]->{$answer}->{teams}})
{
print "Team: ",
" \"$team\", ",$$teams{$team}->{regnum}, "\n";
}
}
}
}
return 1;
}
#
# Сбрасываем ответы на вопрос $number с оценкой $symbol
# в формате, пригодном для собрания сочинений
#
sub anondump
{
my ($teams,$answers,$number,$symbol) = @_;
foreach $answer (keys %{$answers->[$number]})
{
if ($$answers[$number]->{$answer}{score} eq $symbol)
{
my $frequency = scalar keys %{$answers->[$number]->{$answer}->{teams}};
my $canon = $answer;
$canon =~ s/^ /$symbol/;
if ($frequency >1)
{
chomp $canon;
$canon .= " [$frequency]\n";
}
print $canon;
if ($DEBUG)
{
foreach $team (keys %{$answers->[$number]->{$answer}->{teams}})
{
print STDERR "Team: ",
" \"$team\", ",$$teams{$team}->{regnum}, "\n";
}
}
}
}
return 1;
}
#
# Подсчитываем рейтинги вопросов. Рейтинг вопроса есть
# 1+количество команд, которые на него НЕ ответили
#
sub rate_questions
{
my($teams,$answers,$ratings,$round) = @_;
my $numteams = scalar keys %$teams;
for ($i=$MINQUEST[$round];$i<=$MAXQUEST[$round];$i++)
{
$$ratings[$i]=$numteams+1;
foreach $answer (keys %{$$answers[$i]})
{
if ($$answers[$i]->{$answer}{score} eq '+')
{
$$ratings[$i] -=
scalar keys %{$answers->[$i]->{$answer}->{teams}} ;
if ($DEBUG) {
print STDERR "Частота ответа $answer",
scalar keys %{$answers->[$i]->{$answer}->{teams}},
"\n";
}
}
}
}
}
#
# Подсчитываем рейтинги команд
# @{$nopoint_questions} - список номеров вопросов, идущих вне зачёта.
# Для них проставляются плюсы/минусы, но они не учитываются в подсчёте
# очков и рейтингов команд.
#
sub find_scores
{
my ($teams,$answers,$ratings,$round,$factor,$nopoint_questions) = @_;
foreach $team (keys %$teams)
{
if (!defined($factor)) {
$factor=1;
}
$$teams{$team}->{score} *=$factor;
$$teams{$team}->{rating} = 0;
for ($i=$MINQUEST[$round];$i<=$MAXQUEST[$round];$i++)
{
my $answer=$$teams{$team}->{answers}[$i];
if ($$answers[$i]->{$answer}{score} eq '+')
{
next if ( @{$nopoint_questions} &&
grep($_==$i, @{$nopoint_questions})
);
$$teams{$team}->{score} += 1;
$$teams{$team}->{rating} +=
$$ratings[$i];
}
}
if ($DEBUG)
{
print STDERR "$team: Score ",
$$teams{$team}->{score},
", Rating ",
$$teams{$team}->{rating},"\n";
}
}
}
#
# Проверяем на наличие дублирующихся номеров у разных команд.
#
sub check_dup_numbers
{
my ($teams) = @_;
my %seen;
# Имена команд, номера которых встречаются >1 раза.
# Массив uniq_compr_names содержит по одному имени на каждый повторяющийся
# номер (чуть позже мы найдём все имена, соответствующие каждому из
# этих номеров).
# '+0' - чтобы номера обрабатывались как числа (072 == 72).
my @uniq_compr_names =
grep( ++$seen{$teams->{$_}->{regnum}+0} > 1, keys %$teams );
# А теперь извлекаем номера из полученного списка.
my @dup_numbers = map {$teams->{$_}->{regnum}} @uniq_compr_names;
@dup_numbers = sort @dup_numbers;
# И печатаем предупреждение.
if ( @dup_numbers ) {
print STDERR "\nВНИМАНИЕ! Одинаковые номера у нескольких команд:\n";
foreach my $num ( @dup_numbers ) {
my @dup_names = grep($teams->{$_}->{regnum}+0 == $num+0, keys %$teams);
print STDERR "\tНомер $num: " . join(", ", @dup_names) . "\n";
}
print STDERR "\n";
}
}
#
# Считаем ответы на вопрос $number с оценкой $symbol
# (фактически, это anondump(), только без печати списка
# таких ответов).
#
sub countanswers
{
my ($teams,$answers,$number,$symbol) = @_;
my $num=0;
foreach $answer (keys %{$answers->[$number]})
{
if ($$answers[$number]->{$answer}{score} eq $symbol)
{
$num++;
}
}
return $num;
}
1;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>