1: # В этот файл собраны процедуры, общие для всей системы
2: # работы с ответами.
3: #
4: #$Id: subroutines.pl,v 3.2 2013/10/11 15:39:35 boris Exp $
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: }
20: if ($answer ne "" && $number >0)
21: {
22: $$answers[$number]->{$answer}->{score} = $score;
23: %{$$answers[$number]->{$answer}->{teams}} = ();
24: }
25: $answer = "";
26: $number = $1;
27: $score = $2;
28: next;
29: }
30: if (/^Team:/)
31: {
32: next;
33: }
34: if (/^\s*\*\*\*\s*$/)
35: {
36: if ($answer ne "" && $number >0)
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,
69: 'regnum' => $2,
70: 'numletters'=>0);
71: $$table{$team} = \%teamhash;
72: }
73: $$table{$team}->{'numletters'}++;
74: if ($$table{$team}->{regnum} != $2)
75: {
76: print STDERR "Warning: Team $team uses registration nos. ",
77: $$table{$team}->{regnum}, " and $2!\n";
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) = @_;
132: for ($i=1;$i<=$MAXQUEST;$i++)
133: {
134: foreach $team (keys %$teams)
135: {
136: $answer = $$teams{$team}->{answers}[$i];
137: if ($answer eq "")
138: {
139: next;
140: }
141: $$answers[$i]->{$answer}->{teams}->{$team}=1;
142: if (!exists $$answers[$i]->{$answer}->{score})
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: ",
163: scalar keys %{$answers->[$number]->{$answer}->{teams}},
164: ". Score: ",
165: $$answers[$number]->{$answer}{score},"\n";
166: print $answer;
167: if ($DEBUG)
168: {
169: foreach $team (keys %{$answers->[$number]->{$answer}->{teams}})
170: {
171: print "Team: ",
172: " \"$team\", ",$$teams{$team}->{regnum}, "\n";
173: }
174: }
175: }
176: }
177: return 1;
178: }
179:
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: {
191: my $frequency = scalar keys %{$answers->[$number]->{$answer}->{teams}};
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: {
202: foreach $team (keys %{$answers->[$number]->{$answer}->{teams}})
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: {
219: my($teams,$answers,$ratings,$round) = @_;
220: my $numteams = scalar keys %$teams;
221: for ($i=$MINQUEST[$round];$i<=$MAXQUEST[$round];$i++)
222: {
223: $$ratings[$i]=$numteams+1;
224: foreach $answer (keys %{$$answers[$i]})
225: {
226: if ($$answers[$i]->{$answer}{score} eq '+')
227: {
228: $$ratings[$i] -=
229: scalar keys %{$answers->[$i]->{$answer}->{teams}} ;
230: if ($DEBUG) {
231: print STDERR "Частота ответа $answer",
232: scalar keys %{$answers->[$i]->{$answer}->{teams}},
233: "\n";
234: }
235: }
236: }
237: }
238: }
239:
240: #
241: # Подсчитываем рейтинги команд
242: # @{$nopoint_questions} - список номеров вопросов, идущих вне зачёта.
243: # Для них проставляются плюсы/минусы, но они не учитываются в подсчёте
244: # очков и рейтингов команд.
245: #
246: sub find_scores
247: {
248: my ($teams,$answers,$ratings,$round,$factor,$nopoint_questions) = @_;
249: foreach $team (keys %$teams)
250: {
251: if (!defined($factor)) {
252: $factor=1;
253: }
254: $$teams{$team}->{score} *=$factor;
255: $$teams{$team}->{rating} = 0;
256: for ($i=$MINQUEST[$round];$i<=$MAXQUEST[$round];$i++)
257: {
258: my $answer=$$teams{$team}->{answers}[$i];
259: if ($$answers[$i]->{$answer}{score} eq '+')
260: {
261: next if ( @{$nopoint_questions} &&
262: grep($_==$i, @{$nopoint_questions})
263: );
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:
280: #
281: # Проверяем на наличие дублирующихся номеров у разных команд.
282: #
283: sub check_dup_numbers
284: {
285: my ($teams) = @_;
286:
287: my %seen;
288:
289: # Имена команд, номера которых встречаются >1 раза.
290: # Массив uniq_compr_names содержит по одному имени на каждый повторяющийся
291: # номер (чуть позже мы найдём все имена, соответствующие каждому из
292: # этих номеров).
293: # '+0' - чтобы номера обрабатывались как числа (072 == 72).
294: my @uniq_compr_names =
295: grep( ++$seen{$teams->{$_}->{regnum}+0} > 1, keys %$teams );
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 ) {
305: my @dup_names = grep($teams->{$_}->{regnum}+0 == $num+0, keys %$teams);
306: print STDERR "\tНомер $num: " . join(", ", @dup_names) . "\n";
307: }
308: print STDERR "\n";
309: }
310: }
311:
312:
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:
332:
333: 1;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[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