1: # В этот файл собраны процедуры, общие для всей системы
2: # работы с ответами.
3: #
4: #$Id: subroutines.pl,v 1.2 2005/01/24 03:14:49 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: }
24: $answer = "";
25: $number = $1;
26: $score = $2;
27: next;
28: }
29: if (/^Team:/)
30: {
31: next;
32: }
33: if (/^\s*\*\*\*\s*$/)
34: {
35: if ($answer ne "" && $number >0)
36: {
37: $$answers[$number]->{$answer}->{score} = $score;
38: }
39: last;
40: }
41: $answer .= &canonize_answer;
42: }
43: return 1;
44: }
45:
46: #
47: # Читаем файл с письмами команд
48: #
49: sub readmail
50: {
51: my ($table) = @_;
52: $team="";
53: $number=-1;
54: while (<INFILE>)
55: {
56: if (/^\s*\*\*\*\s*"(.+)"\s*[,.]*\s*(\d+)*/) # Нашли новую команду
57: {
58: if ($DEBUG)
59: {
60: print STDERR "Команда: $1, рег. номер: $2\n";
61: }
62: $team = $1;
63: $number = -1;
64: if (!exists($$table{$team})) # Новая команда...
65: {
66: my @teamanswers = ();
67: my %teamhash = ('answers' => \@teamanswers,
68: 'regnum' => $2,
69: 'numletters'=>0);
70: $$table{$team} = \%teamhash;
71: }
72: $$table{$team}->{'numletters'}++;
73: if ($$table{$team}->{regnum} != $2)
74: {
75: print STDERR "Warning: Team $team uses registration nos. ",
76: $$table{$team}->{regnum}, " and $2!\n";
77: }
78: next;
79: }
80: if (s/^\s*\#(\d+)\.*// && $team ne "")
81: {
82: if ($DEBUG)
83: {
84: print STDERR "Ответ $1\n";
85: print STDERR;
86: }
87: $number = $1;
88: $$table{$team}->{answers}[$number] = &canonize_answer;
89: next;
90: }
91: if (/^\*\*\*/) # Команда кончилась
92: {
93: $team="";
94: $number=-1;
95: }
96: if ($team ne "" && $number >0)
97: {
98: if ($DEBUG)
99: {
100: print STDERR;
101: }
102: $$table{$team}->{answers}[$number] .= &canonize_answer;
103: }
104: }
105: return 1;
106: }
107:
108: #
109: # Приводим ответ к канонической форме: два пробела в начале,
110: # ни одного в конце
111: #
112: sub canonize_answer
113: {
114: s/^\s*(.*)\s*$/ $1/;
115: if (/^\s*$/)
116: {
117: return "";
118: }
119: else
120: {
121: return $_."\n";
122: }
123: }
124:
125: #
126: # Заполняем поля %answers
127: #
128: sub collect_answers
129: {
130: my ($teams,$answers) = @_;
131: for ($i=1;$i<=$MAXQUEST;$i++)
132: {
133: foreach $answer (keys %{$$answers[$i]})
134: {
135: @{$$answers[$i]->{$answer}->{teams}} = ();
136: }
137:
138: foreach $team (keys %$teams)
139: {
140: $answer = $$teams{$team}->{answers}[$i];
141: if ($answer eq "")
142: {
143: next;
144: }
145: if (exists $$answers[$i]->{$answer})
146: {
147: push @{$$answers[$i]->{$answer}->{teams}}, $team;
148: }
149: else
150: {
151: my @tmp=($team);
152: $$answers[$i]->{$answer}->{teams} = \@tmp;
153: $$answers[$i]->{$answer}->{score} = '?';
154: }
155: }
156: foreach $answer (keys %{$$answers[$i]})
157: {
158: if (scalar @{$$answers[$i]->{$answer}->{teams}} == 0)
159: {
160: delete $$answers[$i]->{$answer};
161: }
162: }
163: }
164: return 1;
165:
166: }
167:
168: #
169: # Сбрасываем ответы на вопрос $number с оценкой $symbol
170: #
171: sub dumphash
172: {
173: my ($teams,$answers,$number,$symbol) = @_;
174: foreach $answer (keys %{$answers->[$number]})
175: {
176: if ($$answers[$number]->{$answer}{score} eq $symbol)
177: {
178: print "\#$number. Frequency: ",
179: scalar @{$answers->[$number]->{$answer}->{teams}},
180: ". Score: ",
181: $$answers[$number]->{$answer}{score},"\n";
182: print $answer;
183: if ($DEBUG)
184: {
185: foreach $team (@{$answers->[$number]->{$answer}->{teams}})
186: {
187: print "Team: ",
188: " \"$team\", ",$$teams{$team}->{regnum}, "\n";
189: }
190: }
191: }
192: }
193: return 1;
194: }
195: #
196: # Сбрасываем ответы на вопрос $number с оценкой $symbol
197: # в формате, пригодном для собрания сочинений
198: #
199: sub anondump
200: {
201: my ($teams,$answers,$number,$symbol) = @_;
202: foreach $answer (keys %{$answers->[$number]})
203: {
204: if ($$answers[$number]->{$answer}{score} eq $symbol)
205: {
206: my $frequency = scalar @{$answers->[$number]->{$answer}->{teams}};
207: my $canon = $answer;
208: $canon =~ s/^ /$symbol/;
209: if ($frequency >1)
210: {
211: chomp $canon;
212: $canon .= " [$frequency]\n";
213: }
214: print $canon;
215: if ($DEBUG)
216: {
217: foreach $team (@{$answers->[$number]->{$answer}->{teams}})
218: {
219: print STDERR "Team: ",
220: " \"$team\", ",$$teams{$team}->{regnum}, "\n";
221: }
222: }
223: }
224: }
225: return 1;
226: }
227:
228: #
229: # Подсчитываем рейтинги вопросов. Рейтинг вопроса есть
230: # 1+количество команд, которые на него НЕ ответили
231: #
232: sub rate_questions
233: {
234: my($teams,$answers,$ratings) = @_;
235: my $numteams = scalar keys %$teams;
236: for ($i=1;$i<=$MAXQUEST;$i++)
237: {
238: $$ratings[$i]=$numteams+1;
239: foreach $answer (keys %{$$answers[$i]})
240: {
241: if ($$answers[$i]->{$answer}{score} eq '+')
242: {
243: $$ratings[$i] -=
244: scalar @{$answers->[$i]->{$answer}->{teams}} ;
245: }
246: }
247: }
248: if ($DEBUG)
249: {
250: for ($i=1;$i<=$MAXQUEST;$i++)
251: {
252: print STDERR "Вопрос $i, Рейтинг: ", $$ratings[$i], "\n";
253: }
254: }
255: }
256:
257: #
258: # Подсчитываем рейтинги команд
259: #
260: sub find_scores
261: {
262: my ($teams,$answers,$ratings,$factor) = @_;
263: foreach $team (keys %$teams)
264: {
265: if (!defined($factor)) {
266: $factor=1;
267: }
268: $$teams{$team}->{score} *=$factor;
269: $$teams{$team}->{rating} = 0;
270: for ($i=1;$i<=$MAXQUEST;$i++)
271: {
272: my $answer=$$teams{$team}->{answers}[$i];
273: if ($$answers[$i]->{$answer}{score} eq '+')
274: {
275: $$teams{$team}->{score} += 1;
276: $$teams{$team}->{rating} +=
277: $$ratings[$i];
278: }
279: }
280: if ($DEBUG)
281: {
282: print STDERR "$team: Score ",
283: $$teams{$team}->{score},
284: ", Rating ",
285: $$teams{$team}->{rating},"\n";
286: }
287: }
288: }
289:
290:
291: 1;
292:
293:
294:
295:
296:
297:
298:
299:
300:
301:
302:
303:
304:
305:
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