![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to subroutines.pl CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Local Repository] / processmail|
Return to subroutines.pl CVS log | Up to [Local Repository] / processmail |
1.1 boris 1: # В этот файл собраны процедуры, общие для всей системы
2: # работы с ответами.
3: #
3.3 ! boris 4: #$Id: subroutines.pl,v 3.2 2013-10-11 15:39:35 boris Exp $
1.1 boris 5: #
6: sub readhash
7: {
8: my ($answers) = @_;
9: my $answer = "";
10: my $score = "";
11: my $number = -1;
12: while (<INFILE>)
13: {
14: if (/^\s*\#(\d+).*Score:\s*([+-\?])/) # Нашли новый ответ
15: {
16: if ($DEBUG)
17: {
18: print STDERR "\#$number. Score: $score\n",$answer;
19: }
3.3 ! boris 20: if ($answer ne "" && $number >= 0)
1.1 boris 21: {
22: $$answers[$number]->{$answer}->{score} = $score;
1.4 boris 23: %{$$answers[$number]->{$answer}->{teams}} = ();
1.1 boris 24: }
25: $answer = "";
26: $number = $1;
27: $score = $2;
28: next;
29: }
30: if (/^Team:/)
31: {
32: next;
33: }
34: if (/^\s*\*\*\*\s*$/)
35: {
3.3 ! boris 36: if ($answer ne "" && $number >= 0)
1.1 boris 37: {
38: $$answers[$number]->{$answer}->{score} = $score;
39: }
40: last;
41: }
42: $answer .= &canonize_answer;
43: }
44: return 1;
45: }
46:
47: #
48: # Читаем файл с письмами команд
49: #
50: sub readmail
51: {
52: my ($table) = @_;
53: $team="";
54: $number=-1;
55: while (<INFILE>)
56: {
57: if (/^\s*\*\*\*\s*"(.+)"\s*[,.]*\s*(\d+)*/) # Нашли новую команду
58: {
59: if ($DEBUG)
60: {
61: print STDERR "Команда: $1, рег. номер: $2\n";
62: }
63: $team = $1;
64: $number = -1;
65: if (!exists($$table{$team})) # Новая команда...
66: {
67: my @teamanswers = ();
68: my %teamhash = ('answers' => \@teamanswers,
1.2 boris 69: 'regnum' => $2,
70: 'numletters'=>0);
1.1 boris 71: $$table{$team} = \%teamhash;
72: }
1.2 boris 73: $$table{$team}->{'numletters'}++;
1.1 boris 74: if ($$table{$team}->{regnum} != $2)
75: {
3.3 ! boris 76: print STDERR "Warning: Team $team uses registration numbers ",
! 77: "'" . $$table{$team}->{regnum} . "'", " and '$2'!\n";
1.1 boris 78: }
79: next;
80: }
81: if (s/^\s*\#(\d+)\.*// && $team ne "")
82: {
83: if ($DEBUG)
84: {
85: print STDERR "Ответ $1\n";
86: print STDERR;
87: }
88: $number = $1;
89: $$table{$team}->{answers}[$number] = &canonize_answer;
90: next;
91: }
92: if (/^\*\*\*/) # Команда кончилась
93: {
94: $team="";
95: $number=-1;
96: }
97: if ($team ne "" && $number >0)
98: {
99: if ($DEBUG)
100: {
101: print STDERR;
102: }
103: $$table{$team}->{answers}[$number] .= &canonize_answer;
104: }
105: }
106: return 1;
107: }
108:
109: #
110: # Приводим ответ к канонической форме: два пробела в начале,
111: # ни одного в конце
112: #
113: sub canonize_answer
114: {
115: s/^\s*(.*)\s*$/ $1/;
116: if (/^\s*$/)
117: {
118: return "";
119: }
120: else
121: {
122: return $_."\n";
123: }
124: }
125:
126: #
127: # Заполняем поля %answers
128: #
129: sub collect_answers
130: {
131: my ($teams,$answers) = @_;
3.3 ! boris 132: for ($i=$MINQUEST;$i<=$MAXQUEST;$i++)
1.1 boris 133: {
134: foreach $team (keys %$teams)
135: {
136: $answer = $$teams{$team}->{answers}[$i];
137: if ($answer eq "")
138: {
139: next;
140: }
1.4 boris 141: $$answers[$i]->{$answer}->{teams}->{$team}=1;
142: if (!exists $$answers[$i]->{$answer}->{score})
1.1 boris 143: {
144: $$answers[$i]->{$answer}->{score} = '?';
145: }
146: }
147: }
148: return 1;
149:
150: }
151:
152: #
153: # Сбрасываем ответы на вопрос $number с оценкой $symbol
154: #
155: sub dumphash
156: {
157: my ($teams,$answers,$number,$symbol) = @_;
158: foreach $answer (keys %{$answers->[$number]})
159: {
160: if ($$answers[$number]->{$answer}{score} eq $symbol)
161: {
162: print "\#$number. Frequency: ",
1.4 boris 163: scalar keys %{$answers->[$number]->{$answer}->{teams}},
1.1 boris 164: ". Score: ",
165: $$answers[$number]->{$answer}{score},"\n";
166: print $answer;
167: if ($DEBUG)
168: {
1.4 boris 169: foreach $team (keys %{$answers->[$number]->{$answer}->{teams}})
1.1 boris 170: {
171: print "Team: ",
172: " \"$team\", ",$$teams{$team}->{regnum}, "\n";
173: }
174: }
175: }
176: }
177: return 1;
178: }
3.2 boris 179:
1.1 boris 180: #
181: # Сбрасываем ответы на вопрос $number с оценкой $symbol
182: # в формате, пригодном для собрания сочинений
183: #
184: sub anondump
185: {
186: my ($teams,$answers,$number,$symbol) = @_;
187: foreach $answer (keys %{$answers->[$number]})
188: {
189: if ($$answers[$number]->{$answer}{score} eq $symbol)
190: {
1.4 boris 191: my $frequency = scalar keys %{$answers->[$number]->{$answer}->{teams}};
1.1 boris 192: my $canon = $answer;
193: $canon =~ s/^ /$symbol/;
194: if ($frequency >1)
195: {
196: chomp $canon;
197: $canon .= " [$frequency]\n";
198: }
199: print $canon;
200: if ($DEBUG)
201: {
1.4 boris 202: foreach $team (keys %{$answers->[$number]->{$answer}->{teams}})
1.1 boris 203: {
204: print STDERR "Team: ",
205: " \"$team\", ",$$teams{$team}->{regnum}, "\n";
206: }
207: }
208: }
209: }
210: return 1;
211: }
212:
213: #
214: # Подсчитываем рейтинги вопросов. Рейтинг вопроса есть
215: # 1+количество команд, которые на него НЕ ответили
216: #
217: sub rate_questions
218: {
1.5 boris 219: my($teams,$answers,$ratings,$round) = @_;
1.1 boris 220: my $numteams = scalar keys %$teams;
1.5 boris 221: for ($i=$MINQUEST[$round];$i<=$MAXQUEST[$round];$i++)
1.1 boris 222: {
223: $$ratings[$i]=$numteams+1;
224: foreach $answer (keys %{$$answers[$i]})
225: {
226: if ($$answers[$i]->{$answer}{score} eq '+')
227: {
228: $$ratings[$i] -=
1.5 boris 229: scalar keys %{$answers->[$i]->{$answer}->{teams}} ;
230: if ($DEBUG) {
231: print STDERR "Частота ответа $answer",
232: scalar keys %{$answers->[$i]->{$answer}->{teams}},
233: "\n";
234: }
1.1 boris 235: }
236: }
237: }
238: }
239:
240: #
241: # Подсчитываем рейтинги команд
3.0 boris 242: # @{$nopoint_questions} - список номеров вопросов, идущих вне зачёта.
3.2 boris 243: # Для них проставляются плюсы/минусы, но они не учитываются в подсчёте
3.0 boris 244: # очков и рейтингов команд.
1.1 boris 245: #
246: sub find_scores
247: {
3.0 boris 248: my ($teams,$answers,$ratings,$round,$factor,$nopoint_questions) = @_;
1.1 boris 249: foreach $team (keys %$teams)
250: {
1.2 boris 251: if (!defined($factor)) {
252: $factor=1;
253: }
254: $$teams{$team}->{score} *=$factor;
1.1 boris 255: $$teams{$team}->{rating} = 0;
1.5 boris 256: for ($i=$MINQUEST[$round];$i<=$MAXQUEST[$round];$i++)
1.1 boris 257: {
258: my $answer=$$teams{$team}->{answers}[$i];
259: if ($$answers[$i]->{$answer}{score} eq '+')
260: {
3.0 boris 261: next if ( @{$nopoint_questions} &&
262: grep($_==$i, @{$nopoint_questions})
263: );
1.1 boris 264: $$teams{$team}->{score} += 1;
265: $$teams{$team}->{rating} +=
266: $$ratings[$i];
267: }
268: }
269: if ($DEBUG)
270: {
271: print STDERR "$team: Score ",
272: $$teams{$team}->{score},
273: ", Rating ",
274: $$teams{$team}->{rating},"\n";
275: }
276: }
277: }
278:
279:
3.1 boris 280: #
281: # Проверяем на наличие дублирующихся номеров у разных команд.
282: #
283: sub check_dup_numbers
284: {
285: my ($teams) = @_;
286:
287: my %seen;
288:
289: # Имена команд, номера которых встречаются >1 раза.
290: # Массив uniq_compr_names содержит по одному имени на каждый повторяющийся
3.2 boris 291: # номер (чуть позже мы найдём все имена, соответствующие каждому из
292: # этих номеров).
3.1 boris 293: # '+0' - чтобы номера обрабатывались как числа (072 == 72).
294: my @uniq_compr_names =
3.2 boris 295: grep( ++$seen{$teams->{$_}->{regnum}+0} > 1, keys %$teams );
3.1 boris 296:
297: # А теперь извлекаем номера из полученного списка.
298: my @dup_numbers = map {$teams->{$_}->{regnum}} @uniq_compr_names;
299: @dup_numbers = sort @dup_numbers;
300:
301: # И печатаем предупреждение.
302: if ( @dup_numbers ) {
303: print STDERR "\nВНИМАНИЕ! Одинаковые номера у нескольких команд:\n";
304: foreach my $num ( @dup_numbers ) {
3.2 boris 305: my @dup_names = grep($teams->{$_}->{regnum}+0 == $num+0, keys %$teams);
3.1 boris 306: print STDERR "\tНомер $num: " . join(", ", @dup_names) . "\n";
307: }
308: print STDERR "\n";
309: }
310: }
1.1 boris 311:
312:
3.2 boris 313: #
314: # Считаем ответы на вопрос $number с оценкой $symbol
315: # (фактически, это anondump(), только без печати списка
316: # таких ответов).
317: #
318: sub countanswers
319: {
320: my ($teams,$answers,$number,$symbol) = @_;
321: my $num=0;
322: foreach $answer (keys %{$answers->[$number]})
323: {
324: if ($$answers[$number]->{$answer}{score} eq $symbol)
325: {
326: $num++;
327: }
328: }
329: return $num;
330: }
331:
1.1 boris 332:
3.1 boris 333: 1;