1: # В этот файл собраны процедуры, общие для всей системы
2: # работы с ответами.
3: #
4: #$Id: subroutines.pl,v 3.0 2008/03/23 17:50:50 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: # Сбрасываем ответы на вопрос $number с оценкой $symbol
181: # в формате, пригодном для собрания сочинений
182: #
183: sub anondump
184: {
185: my ($teams,$answers,$number,$symbol) = @_;
186: foreach $answer (keys %{$answers->[$number]})
187: {
188: if ($$answers[$number]->{$answer}{score} eq $symbol)
189: {
190: my $frequency = scalar keys %{$answers->[$number]->{$answer}->{teams}};
191: my $canon = $answer;
192: $canon =~ s/^ /$symbol/;
193: if ($frequency >1)
194: {
195: chomp $canon;
196: $canon .= " [$frequency]\n";
197: }
198: print $canon;
199: if ($DEBUG)
200: {
201: foreach $team (keys %{$answers->[$number]->{$answer}->{teams}})
202: {
203: print STDERR "Team: ",
204: " \"$team\", ",$$teams{$team}->{regnum}, "\n";
205: }
206: }
207: }
208: }
209: return 1;
210: }
211:
212: #
213: # Подсчитываем рейтинги вопросов. Рейтинг вопроса есть
214: # 1+количество команд, которые на него НЕ ответили
215: #
216: sub rate_questions
217: {
218: my($teams,$answers,$ratings,$round) = @_;
219: my $numteams = scalar keys %$teams;
220: for ($i=$MINQUEST[$round];$i<=$MAXQUEST[$round];$i++)
221: {
222: $$ratings[$i]=$numteams+1;
223: foreach $answer (keys %{$$answers[$i]})
224: {
225: if ($$answers[$i]->{$answer}{score} eq '+')
226: {
227: $$ratings[$i] -=
228: scalar keys %{$answers->[$i]->{$answer}->{teams}} ;
229: if ($DEBUG) {
230: print STDERR "Частота ответа $answer",
231: scalar keys %{$answers->[$i]->{$answer}->{teams}},
232: "\n";
233: }
234: }
235: }
236: }
237: }
238:
239: #
240: # Подсчитываем рейтинги команд
241: # @{$nopoint_questions} - список номеров вопросов, идущих вне зачёта.
242: # Для них проставляются плясы/минусы, но они не учитываются в подсчёте
243: # очков и рейтингов команд.
244: #
245: sub find_scores
246: {
247: my ($teams,$answers,$ratings,$round,$factor,$nopoint_questions) = @_;
248: foreach $team (keys %$teams)
249: {
250: if (!defined($factor)) {
251: $factor=1;
252: }
253: $$teams{$team}->{score} *=$factor;
254: $$teams{$team}->{rating} = 0;
255: for ($i=$MINQUEST[$round];$i<=$MAXQUEST[$round];$i++)
256: {
257: my $answer=$$teams{$team}->{answers}[$i];
258: if ($$answers[$i]->{$answer}{score} eq '+')
259: {
260: next if ( @{$nopoint_questions} &&
261: grep($_==$i, @{$nopoint_questions})
262: );
263: $$teams{$team}->{score} += 1;
264: $$teams{$team}->{rating} +=
265: $$ratings[$i];
266: }
267: }
268: if ($DEBUG)
269: {
270: print STDERR "$team: Score ",
271: $$teams{$team}->{score},
272: ", Rating ",
273: $$teams{$team}->{rating},"\n";
274: }
275: }
276: }
277:
278:
279: 1;
280:
281:
282:
283:
284:
285:
286:
287:
288:
289:
290:
291:
292:
293:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>