Return to subroutines.pl CVS log

Up to [Local Repository] / processmail

New change from Lev

# В этот файл собраны процедуры, общие для всей системы
# работы с ответами.
#
#$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;