Return to subroutines.pl CVS log

Up to [Local Repository] / processmail

Initial revision

# В этот файл собраны процедуры, общие для всей системы
# работы с ответами.
#
#$Id: subroutines.pl,v 1.1 2002/02/04 17:18:33 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;
	    }
	    $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);
		$$table{$team} = \%teamhash;
	    }
	    if ($$table{$team}->{regnum} != $2)
	    {
		print STDERR "Warning: Team $team uses registration nos. ",
		$$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=1;$i<=$MAXQUEST;$i++)
    {
	foreach $answer (keys %{$$answers[$i]})
	{
	    @{$$answers[$i]->{$answer}->{teams}} = ();
	}

	foreach $team (keys %$teams)
	{
	    $answer = $$teams{$team}->{answers}[$i];
	    if ($answer eq "")
	    {
		next;
	    }
	    if (exists $$answers[$i]->{$answer})
	    {
		push @{$$answers[$i]->{$answer}->{teams}}, $team;
	    }
	    else
	    {
		my @tmp=($team);
		$$answers[$i]->{$answer}->{teams} = \@tmp;
		$$answers[$i]->{$answer}->{score} = '?';
	    }
	}
	foreach $answer (keys %{$$answers[$i]})
	{
	    if (scalar @{$$answers[$i]->{$answer}->{teams}} == 0)
	    {
		delete $$answers[$i]->{$answer};
	    }
	}
    }
    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 @{$answers->[$number]->{$answer}->{teams}},
	    ". Score: ",
	    $$answers[$number]->{$answer}{score},"\n"; 
	    print $answer;
	    if ($DEBUG)
	    {
		foreach $team (@{$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 @{$answers->[$number]->{$answer}->{teams}};
	    my $canon = $answer;
	    $canon =~ s/^ /$symbol/;
	    if ($frequency >1)
	    {
		chomp $canon;
		$canon .= " [$frequency]\n";
	    }
	    print $canon;
	    if ($DEBUG)
	    {
		foreach $team (@{$answers->[$number]->{$answer}->{teams}})
		{
		    print STDERR "Team: ",
		    " \"$team\", ",$$teams{$team}->{regnum}, "\n";
		}
	    }
	}
    }
    return 1;
}

#
# Подсчитываем рейтинги вопросов. Рейтинг вопроса есть 
# 1+количество команд, которые на него НЕ ответили
#
sub rate_questions
{
    my($teams,$answers,$ratings) = @_;
    my $numteams = scalar keys %$teams;
    for ($i=1;$i<=$MAXQUEST;$i++)
    {
	$$ratings[$i]=$numteams+1;
	foreach $answer (keys %{$$answers[$i]})
	{
	    if ($$answers[$i]->{$answer}{score} eq '+')
	    {
		$$ratings[$i] -= 
		    scalar @{$answers->[$i]->{$answer}->{teams}} ;
	    }
	}
    }
    if ($DEBUG)
    {
	for ($i=1;$i<=$MAXQUEST;$i++)
	{
	    print STDERR "Вопрос $i, Рейтинг: ", $$ratings[$i], "\n";
	}
    }   
}

#
# Подсчитываем рейтинги команд
#
sub find_scores
{
    my ($teams,$answers,$ratings) = @_;
    foreach $team (keys %$teams)
    {
	$$teams{$team}->{score} = 0;
	$$teams{$team}->{rating} = 0;
	for ($i=1;$i<=$MAXQUEST;$i++)
	{
	    my $answer=$$teams{$team}->{answers}[$i];
	    if ($$answers[$i]->{$answer}{score} eq '+')
	    {
		$$teams{$team}->{score}  += 1;
		$$teams{$team}->{rating} +=
		    $$ratings[$i];
	    }
	}
	if ($DEBUG)
	{
	    print STDERR "$team: Score ",
	    $$teams{$team}->{score},
	    ", Rating ",
	    $$teams{$team}->{rating},"\n";
	}
    }
}


1;