[BACK]Return to subroutines.pl CVS log [TXT] [DIR] Up to [Local Repository] / processmail

Diff for /processmail/subroutines.pl between versions 1.1 and 3.4

version 1.1, 2002/02/04 17:18:33 version 3.4, 2013/10/30 20:29:22
Line 17  sub readhash Line 17  sub readhash
             {              {
                 print STDERR "\#$number. Score: $score\n",$answer;                  print STDERR "\#$number. Score: $score\n",$answer;
             }              }
             if ($answer ne "" && $number >0)              if ($answer ne "" && $number >= 0)
             {              {
                 $$answers[$number]->{$answer}->{score} = $score;                  $$answers[$number]->{$answer}->{score} = $score;
                   %{$$answers[$number]->{$answer}->{teams}} = ();
             }              }
             $answer = "";              $answer = "";
             $number = $1;              $number = $1;
Line 32  sub readhash Line 33  sub readhash
         }          }
         if (/^\s*\*\*\*\s*$/)          if (/^\s*\*\*\*\s*$/)
         {          {
             if ($answer ne "" && $number >0)              if ($answer ne "" && $number >= 0)
             {              {
                 $$answers[$number]->{$answer}->{score} = $score;                  $$answers[$number]->{$answer}->{score} = $score;
             }              }
Line 65  sub readmail Line 66  sub readmail
             {              {
                 my @teamanswers = ();                  my @teamanswers = ();
                 my %teamhash = ('answers' => \@teamanswers,                   my %teamhash = ('answers' => \@teamanswers, 
                                 'regnum' => $2);                                  'regnum' => $2,
                                   'numletters'=>0);
                 $$table{$team} = \%teamhash;                  $$table{$team} = \%teamhash;
             }              }
               $$table{$team}->{'numletters'}++;
             if ($$table{$team}->{regnum} != $2)              if ($$table{$team}->{regnum} != $2)
             {              {
                 print STDERR "Warning: Team $team uses registration nos. ",                  print STDERR "Warning: Team $team uses registration numbers ",
                 $$table{$team}->{regnum}, " and $2!\n";                        "'" . $$table{$team}->{regnum} . "'", " and '$2'!\n";
             }              }
             next;              next;
         }          }
Line 109  sub readmail Line 112  sub readmail
 #  #
 sub canonize_answer  sub canonize_answer
 {  {
     s/^\s*(.*)\s*$/  $1/;      s/^\s*(.*?)\s*$/  $1/;    
     if (/^\s*$/)       if (/^\s*$/) 
     {      {
         return "";          return "";
Line 126  sub canonize_answer Line 129  sub canonize_answer
 sub collect_answers  sub collect_answers
 {  {
     my ($teams,$answers) = @_;      my ($teams,$answers) = @_;
     for ($i=1;$i<=$MAXQUEST;$i++)      for ($i=$MINQUEST;$i<=$MAXQUEST;$i++)
     {      {
         foreach $answer (keys %{$$answers[$i]})  
         {  
             @{$$answers[$i]->{$answer}->{teams}} = ();  
         }  
   
         foreach $team (keys %$teams)          foreach $team (keys %$teams)
         {          {
             $answer = $$teams{$team}->{answers}[$i];              $answer = $$teams{$team}->{answers}[$i];
Line 140  sub collect_answers Line 138  sub collect_answers
             {              {
                 next;                  next;
             }              }
             if (exists $$answers[$i]->{$answer})              $$answers[$i]->{$answer}->{teams}->{$team}=1;
             {              if (!exists $$answers[$i]->{$answer}->{score})
                 push @{$$answers[$i]->{$answer}->{teams}}, $team;  
             }  
             else  
             {              {
                 my @tmp=($team);  
                 $$answers[$i]->{$answer}->{teams} = \@tmp;  
                 $$answers[$i]->{$answer}->{score} = '?';                  $$answers[$i]->{$answer}->{score} = '?';
             }              }
         }          }
         foreach $answer (keys %{$$answers[$i]})  
         {  
             if (scalar @{$$answers[$i]->{$answer}->{teams}} == 0)  
             {  
                 delete $$answers[$i]->{$answer};  
             }  
         }  
     }      }
     return 1;      return 1;
   
Line 174  sub dumphash Line 160  sub dumphash
         if ($$answers[$number]->{$answer}{score} eq $symbol)          if ($$answers[$number]->{$answer}{score} eq $symbol)
         {          {
             print "\#$number. Frequency: ",               print "\#$number. Frequency: ", 
             scalar @{$answers->[$number]->{$answer}->{teams}},              scalar keys %{$answers->[$number]->{$answer}->{teams}},
             ". Score: ",              ". Score: ",
             $$answers[$number]->{$answer}{score},"\n";               $$answers[$number]->{$answer}{score},"\n"; 
             print $answer;              print $answer;
             if ($DEBUG)              if ($DEBUG)
             {              {
                 foreach $team (@{$answers->[$number]->{$answer}->{teams}})                  foreach $team (keys %{$answers->[$number]->{$answer}->{teams}})
                 {                  {
                     print "Team: ",                      print "Team: ",
                     " \"$team\", ",$$teams{$team}->{regnum}, "\n";                      " \"$team\", ",$$teams{$team}->{regnum}, "\n";
Line 190  sub dumphash Line 176  sub dumphash
     }      }
     return 1;      return 1;
 }  }
   
 #  #
 # Сбрасываем ответы на вопрос $number с оценкой $symbol  # Сбрасываем ответы на вопрос $number с оценкой $symbol
 # в формате, пригодном для собрания сочинений  # в формате, пригодном для собрания сочинений
Line 201  sub anondump Line 188  sub anondump
     {      {
         if ($$answers[$number]->{$answer}{score} eq $symbol)          if ($$answers[$number]->{$answer}{score} eq $symbol)
         {          {
             my $frequency = scalar @{$answers->[$number]->{$answer}->{teams}};              my $frequency = scalar keys %{$answers->[$number]->{$answer}->{teams}};
             my $canon = $answer;              my $canon = $answer;
             $canon =~ s/^ /$symbol/;              $canon =~ s/^ /$symbol/;
             if ($frequency >1)              if ($frequency >1)
Line 212  sub anondump Line 199  sub anondump
             print $canon;              print $canon;
             if ($DEBUG)              if ($DEBUG)
             {              {
                 foreach $team (@{$answers->[$number]->{$answer}->{teams}})                  foreach $team (keys %{$answers->[$number]->{$answer}->{teams}})
                 {                  {
                     print STDERR "Team: ",                      print STDERR "Team: ",
                     " \"$team\", ",$$teams{$team}->{regnum}, "\n";                      " \"$team\", ",$$teams{$team}->{regnum}, "\n";
Line 229  sub anondump Line 216  sub anondump
 #  #
 sub rate_questions  sub rate_questions
 {  {
     my($teams,$answers,$ratings) = @_;      my($teams,$answers,$ratings,$round) = @_;
     my $numteams = scalar keys %$teams;      my $numteams = scalar keys %$teams;
     for ($i=1;$i<=$MAXQUEST;$i++)      for ($i=$MINQUEST[$round];$i<=$MAXQUEST[$round];$i++)
     {      {
         $$ratings[$i]=$numteams+1;          $$ratings[$i]=$numteams+1;
         foreach $answer (keys %{$$answers[$i]})          foreach $answer (keys %{$$answers[$i]})
Line 239  sub rate_questions Line 226  sub rate_questions
             if ($$answers[$i]->{$answer}{score} eq '+')              if ($$answers[$i]->{$answer}{score} eq '+')
             {              {
                 $$ratings[$i] -=                   $$ratings[$i] -= 
                     scalar @{$answers->[$i]->{$answer}->{teams}} ;                  scalar keys %{$answers->[$i]->{$answer}->{teams}} ;
                   if ($DEBUG) {
                       print STDERR "Частота ответа $answer", 
                       scalar keys %{$answers->[$i]->{$answer}->{teams}},
                                     "\n";
                   }
             }              }
         }          }
     }      }
     if ($DEBUG)  
     {  
         for ($i=1;$i<=$MAXQUEST;$i++)  
         {  
             print STDERR "Вопрос $i, Рейтинг: ", $$ratings[$i], "\n";  
         }  
     }     
 }  }
   
 #  #
 # Подсчитываем рейтинги команд  # Подсчитываем рейтинги команд
   # @{$nopoint_questions} - список номеров вопросов, идущих вне зачёта.
   # Для них проставляются плюсы/минусы, но они не учитываются в подсчёте
   # очков и рейтингов команд.
 #  #
 sub find_scores  sub find_scores
 {  {
     my ($teams,$answers,$ratings) = @_;      my ($teams,$answers,$ratings,$round,$factor,$nopoint_questions) = @_;
     foreach $team (keys %$teams)      foreach $team (keys %$teams)
     {      {
         $$teams{$team}->{score} = 0;          if (!defined($factor)) {
               $factor=1;
           }
           $$teams{$team}->{score} *=$factor;
         $$teams{$team}->{rating} = 0;          $$teams{$team}->{rating} = 0;
         for ($i=1;$i<=$MAXQUEST;$i++)          for ($i=$MINQUEST[$round];$i<=$MAXQUEST[$round];$i++)
         {          {
             my $answer=$$teams{$team}->{answers}[$i];              my $answer=$$teams{$team}->{answers}[$i];
             if ($$answers[$i]->{$answer}{score} eq '+')              if ($$answers[$i]->{$answer}{score} eq '+')
             {              {
                   next if  ( @{$nopoint_questions} && 
                             grep($_==$i, @{$nopoint_questions})
                            );
                 $$teams{$team}->{score}  += 1;                  $$teams{$team}->{score}  += 1;
                 $$teams{$team}->{rating} +=                  $$teams{$team}->{rating} +=
                     $$ratings[$i];                      $$ratings[$i];
Line 283  sub find_scores Line 277  sub find_scores
 }  }
   
   
 1;  #
   # Проверяем на наличие дублирующихся номеров у разных команд.
   #
   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;
Removed from v.1.1  
changed lines
  Added in v.3.4

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>