#!/usr/bin/perl # Spočítá z výsledků hodnoty Pentamindu pro každého hráče a zobrazí pořadí. # Copyright © 2004-2009 Dan Zeman # Licence: GNU GPL # 27.9.2009: ladící režim zobrazuje i nezapočítané výsledky s udáním důvodu use utf8; # říct Perlu, že konstantní řetězce ve zdrojáku jsou v UTF use Encode; # knihovna pro překódování ne-ASCII znaků use DBI; # spolupráce se serverem MySQL # Říct Perlu, kde najde Danovy sdílené knihovny. # CGI skripty běží pod uživatelem apache, který nemá tyto knihovny v cestě. BEGIN {unshift(@INC, '/s/w/lib/dan') unless(grep {$_ eq '/s/w/lib/dan'} @INC)}use dancgi; # čtení parametrů z webu nebo z ARGV use jazyky; # jazykové verze textů use csort; # české a anglické abecední řazení UTF znaků use cas; # funkce pro práci s daty a časem use mso; # funkce pro generování stránek o olympiádě binmode(STDOUT, ":utf8"); # říct Perlu, že UTF chceme i na výstupu # Načíst parametry z URL. dancgi::cist_parametry(\%konfig); # Umožnit volat skript z příkazového řádku a předat parametry tam (např. perl prihlaseni.pl akce=caroly). dancgi::rozebrat_parametry($ARGV[0], \%konfig); if($konfig{jazyk} eq "") { $konfig{jazyk} = "cs"; } $jazyky::jazyk = $konfig{jazyk}; # Připojit se k databázi. $databaze = mso::pripojit_se_k_databazi(); # Vypsat stránku. mso::vypsat_stranku( { "nazev" => "MSO: $konfig{rok}: ".jazyky::zjistit("pentamind"), "nadpis" => jazyky::zjistit("pentamind_nadpis"), "telo" => sestavit_vysledky($konfig{rok}, \%konfig), "rok" => $konfig{rok} }); ############################################################################### # PODPROGRAMY ############################################################################### #------------------------------------------------------------------------------ # Sestaví HTML zprávu o výsledcích Pentamindu (Pětimysli). # Pozor, NEHLÍDÁ následující: # - že na vstupu byly výsledky všech turnajů. # - že na vstupu byl pro každou dvojici turnaj-hráč nejvýše jeden výsledek. # - že hráč v započítaných turnajích sehrál alespoň polovinu partií. #------------------------------------------------------------------------------ sub sestavit_vysledky { my $rok = shift; my $konfig = shift; # Případný požadavek na hraní hymny si zapamatovat pro tento běh, ale z %{$konfig} ho odstranit, aby nezůstal v žádných odkazech. my $hymna = $konfig->{hymna}; delete($konfig->{hymna}); # Získat z databáze výsledky turnajů v daném roce, které se podle propozic # mají započítat do Pentamindu a kterých se zúčastnilo alespoň 8 hráčů. my $vysledky = mso::dotazat_se_databaze($databaze, 'kod_hry', 'kod_akce', 'pentamind', 'pocet_bloku', 'pocet_ucastniku', 'pentaskup', 'poradi', 'kod_osoby', 'jmeno', 'prijmeni', 'zeme', 'obec', "vysledky WHERE (rok = '$rok') AND ((pentamind = '1') OR (pentamind = '2'))"); # Získat z databáze názvy akcí. my $nazev_jazyk = jazyky::zjistit("klic_nazev"); my $akce = mso::dotazat_se_databaze($databaze, "kod_hry", "kod_turnaje", $nazev_jazyk, "akce WHERE rok = '$rok'"); my %nazev_akce; foreach my $a (@{$akce}) { $nazev_akce{$a->{kod_hry}}{$a->{kod_turnaje}} = $a->{$nazev_jazyk}; } # Spočítat všem hráčům body do Pětimysli, označit výsledky a hráče, které se podle pravidel mají vyřadit. my $osoby_serazene = spocitat($rok, $konfig, $vysledky); # Vyrobit HTML. my $html; # Zjistit, které ročníky MSO už proběhly nebo probíhají. my $roky = mso::dotazat_se_databaze($databaze, "rok", "zacatek", "rocniky ORDER BY rok"); my @odkazy_na_jine_roky; foreach my $irok (@{$roky}) { last if(datum2eden($irok->{zacatek})>ted()->{eden}); if($irok->{rok}==$rok) { push(@odkazy_na_jine_roky, $irok->{rok}); } else { my $parametry = dancgi::sestavit_parametry_odkaz($konfig, "telo=pentamind.pl", "rok=$irok->{rok}"); push(@odkazy_na_jine_roky, "$irok->{rok}"); } } $html .= "

".jazyky::zjistit("pentamind_se_konal_v_letech")." ".join(", ", @odkazy_na_jine_roky).".\n"; # Přidat odkaz na propozice. my $parametry = dancgi::sestavit_parametry_odkaz($konfig, "telo=propozice.pl", "hra=pet", "turnaj=oly"); $html .= jazyky::zjistit("propozice_najdete_zde", $rok, $parametry)."

\n"; # Přidat na pozadí hrající hymnu. if($hymna ne "") { $hymna = "$konfig->{_cesta_html_prohlizec}/obr/hymny/".lc($hymna).".mid"; $html .= "\n"; $html .= "\n"; } # Pokud je poslední den Deskohraní, čeká se na doplnění posledních výsledků a nechceme, # aby si lidé mohli prohlížet téměř kompletní pořadí Pětimysli před jeho oficiálním vyhlášením, # můžeme ho vypnout nastavením $utajit = 1. my $utajit = 0; if(!$utajit || $rok!=ted()->{rok}) { # Vypsat hráče na výstup v pořadí podle počtu bodů. $html .= ""; my $poradi = 0; foreach my $osoba (@{$osoby_serazene}) { my $vyrazen = 0; # Vynechat hráče, kterým se nezapočítal žádný výsledek. if($osoba->{pentamind<0}) { if($konfig->{debug}) { $html .= "\n"; } next; } # Vynechat hráče, kteří se zúčastnili méně než 3 turnajů. if(scalar(@{$osoba->{vysledky}})<3) { # Ani v ladícím výpisu ale nechceme vidět prázdné záznamy osob, které nemají ani žádný nezapočítaný výsledek. if($konfig->{debug} && scalar(@{$osoba->{vysledky}})+scalar(@{$osoba->{nezapocitane_vysledky}})>0) { $vyrazen++; } else { next; } } # Vynechat hráče, kteří se nezúčastnili alespoň 1 víceblokového turnaje. unless($osoba->{viceblok}) { if($konfig->{debug}) { $vyrazen++; } else { next; } } $html .= ""; if($vyrazen) { $html .= ""; # sloupec 1 } else { $poradi++; $html .= ""; # sloupec 1 } $html .= ""; # sloupec 2 $html .= ""; # sloupec 3 $html .= ""; # sloupec 4 $html .= sprintf("", $osoba->{pentamind}+0.5); # sloupec 5 # Sestavit odkaz na vlajku. my $cesta = "$konfig->{_cesta_html_prohlizec}/obr/vlajky/".lc($osoba->{zeme}).".png"; $html .= ""; # sloupec 6 # U prvního místa přidat odkaz na hymnu. if($poradi==1) { # Znak U+266B (nota) je vidět ve Firefoxu, ale Internet Explorer si neumí sáhnout do správného fontu. # Obrázková verze: výšku omezuju na 20, při zmenšení na 18 pixelů už se u noty ztrácí nožička. # my $nota = chr(hex("266B")); my $nota = "{_cesta_html_prohlizec}/obr/nota.png\" height=\"20\" alt=\"Hymna vítěze\">"; $html .= ""; # sloupec 7 } $html .= "\n"; # V ladícím režimu upozornit na hráče, kteří měli být vynecháni, protože se zúčastnili méně než 3 turnajů. if($konfig->{debug}) { if(scalar(@{$osoba->{vysledky}})<3) { $html .= "\n"; } elsif(!$osoba->{viceblok}) { if($rok<2009) { $html .= "\n"; } else { $html .= "\n"; } } } foreach my $vysledek (@{$osoba->{vysledky}}) { my $viceblok = ($konfig->{debug} && $rok>=2004 && $rok<=2008 && $vysledek->{pocet_bloku}>=2) ? ' (víceblokový)' : ($konfig->{debug} && $rok>=2009 && $vysledek->{pentamind}==2) ? ' (velký)' : ''; $html .= ""; $html .= ""; # sloupec 1 my $parametry = dancgi::sestavit_parametry_odkaz($konfig, "telo=vysledky.pl", "hra=$vysledek->{kod_hry}", "turnaj=$vysledek->{kod_akce}", "hymna"); $html .= ""; # sloupce 2 a 3 $html .= sprintf("", $vysledek->{body}+0.5); # sloupec 4 $html .= "\n"; } # Jestliže je zapnuté ladění, zobrazit také výsledky, které se do Pětimysli nezapočítaly. if($konfig->{debug}) { foreach my $vysledek (@{$osoba->{nezapocitane_vysledky}}) { my $viceblok = ($rok>=2004 && $rok<=2008 && $vysledek->{pocet_bloku}>=2) ? ' (víceblokový)' : ($rok>=2009 && $vysledek->{pentamind}==2) ? ' (velký)' : ''; $html .= ''; $html .= ''; # sloupec 1 my $odkaz = mso::odkaz($konfig, 'telo=vysledky.pl', "hra=$vysledek->{kod_hry}", "turnaj=$vysledek->{kod_akce}", 'hymna'); $html .= ""; # sloupce 2 a 3 $html .= sprintf("", $vysledek->{body}+0.5); # sloupec 4 $html .= ""; # sloupce 5, 6 a 7 $html .= "\n"; } } } $html .= "
 $osoba->{jmeno} $osoba->{prijmeni} Vyřazen, protože se mu nezapočítal žádný výsledek.
 $poradi. $osoba->{jmeno} $osoba->{prijmeni} $osoba->{zeme} $osoba->{obec} %d {zeme}").">$nota
 Vyřazen, protože se zúčastnil méně než 3 turnajů.
 Vyřazen, protože se nezúčastnil žádného víceblokového turnaje.
 Vyřazen, protože se nezúčastnil žádného velkého turnaje.
 $nazev_akce{$vysledek->{kod_hry}}{$vysledek->{kod_akce}}$viceblok %d
 $nazev_akce{$vysledek->{kod_hry}}{$vysledek->{kod_akce}}$viceblok %dNezapočítáno z důvodu: $vysledek->{duvod_nezapocitani}
"; } else { $html .= "

".jazyky::zjistit("pentamind_odpuzovac_zvedavcu")."

\n"; } return $html; } #------------------------------------------------------------------------------ # Spočítá každému hráči body do Pětimysli, označí výsledky a hráče, kteří se # mají vyřadit, a pro účely ladění navíc připíše důvod. Nevyrábí žádné HTML, # to budou mít za úkol až funkce, které budou zavolány následovně. #------------------------------------------------------------------------------ sub spocitat { my $rok = shift; my $konfig = shift; my $vysledky = shift; # Profiltrovat výsledky podle počtu účastníků turnajů. Vzhledem k tomu, že # některých turnajů se hráči účastnili po dvojicích či větších skupinách, # je jednodušší to udělat tady než v SQL. my @osobni_vysledky; foreach my $vysledek (@{$vysledky}) { # U soutěží, kterými prochází skupina pohromadě, místo aby hrál každý jen za sebe, # dělit počet účastníků velikostí skupin. $vysledek->{pocet_ucastniku} /= $vysledek->{pentaskup} if($vysledek->{pentaskup}>1); # Vynechat výsledky soutěží, kterých se zúčastnilo méně než 8 lidí. next unless($vysledek->{pocet_ucastniku}>=8); # Připsat si výsledek na osobní kartu hráče. push(@{$osobni_vysledky[$vysledek->{kod_osoby}]{vysledky}}, $vysledek); } # Projít hráče a každému spočítat body za každou soutěž (i za ty, které se # nebudou počítat). foreach my $osoba (@osobni_vysledky) { foreach my $vysledek (@{$osoba->{vysledky}}) { # Body vyjadřují relativní umístění hráče v turnaji v procentech. if($vysledek->{pocet_ucastniku}-1) { $vysledek->{body} = ($vysledek->{pocet_ucastniku}-$vysledek->{poradi})/($vysledek->{pocet_ucastniku}-1)*100; } # Zapamatovat si, zda se hráč zúčastnil alespoň jednoho víceblokového turnaje. # Tuto kontrolu provádět až od roku 2004, dříve se nedělala a ani jsme neměli evidováno, které turnaje mají kolik bloků. # Od roku 2009 se místo počtu bloků zjišťuje, jestli byl turnaj v propozicích uveden jako velký. if($rok<2004 || $rok<2009 && $vysledek->{pocet_bloku}>=2 || $vysledek->{pentamind}==2) { $osoba->{viceblok} = 1; } } # Seřadit turnaje podle úspěšnosti tohoto hráče v nich. @{$osoba->{vysledky}} = sort { $b->{body}<=>$a->{body} } (@{$osoba->{vysledky}}); # Od každé hry zachovat nejvýše dva nejlepší výsledky. # Celkově zachovat pouze pět nejlepších výsledků. my %registr_her; # hlídá, kolik akcí jsme započítali od jedné hry my $n = 0; # hlídá, kolik akcí jsme započítali celkem my $viceblok; # hlídá, že započítáme alespoň jednu víceblokovou akci for(my $i = 0; $i<=$#{$osoba->{vysledky}}; $i++) { my $vysledek = $osoba->{vysledky}[$i]; # Přeskakujeme 3. a další výsledek v jedné hře, 6. a další výsledek obecně a 5. výsledek, pokud ještě nemáme žádný velký turnaj. if($registr_her{$vysledek->{kod_hry}}>=2 || $n>=5 || ($rok>=2004 && $rok<=2008 && $n==4 && !$viceblok && $vysledek->{pocet_bloku}<2) || ($rok>=2009 && $n==4 && !$viceblok && $vysledek->{pentamind}<2)) { if($konfig->{debug}) { my @duvody; if($registr_her{$vysledek->{kod_hry}}>=2) { push(@duvody, "3. a další výsledek ve hře $vysledek->{kod_hry}"); } if($n>=5) { push(@duvody, "6. a další výsledek celkově"); } if($rok>=2004 && $rok<=2008 && $n==4 && !$viceblok && $vysledek->{pocet_bloku}<2) { push(@duvody, "alespoň jeden turnaj musí být víceblokový"); } if($rok>=2009 && $n==4 && !$viceblok && $vysledek->{pentamind}<2) { push(@duvody, "alespoň jeden turnaj musí být velký"); } $vysledek->{duvod_nezapocitani} = join(', ', @duvody); push(@{$osoba->{nezapocitane_vysledky}}, $vysledek); } # Vymazat výsledek, který se nemá počítat. splice(@{$osoba->{vysledky}}, $i, 1); $i--; } else { # Přičíst body za danou akci do Pětimysli. $osoba->{pentamind} += $vysledek->{body}; # Zapamatovat si, že v této hře už daná osoba bodovala. $registr_her{$vysledek->{kod_hry}}++; # Zapamatovat si, zda už jsme započítali alespoň jeden víceblokový turnaj. if(($rok>=2004 && $rok<=2008 && $vysledek->{pocet_bloku}>=2) || ($rok>=2009 && $vysledek->{pentamind}==2)) { $viceblok = 1; } # Zapamatovat si, kolik výsledků už jsme započítali. $n++; } } # Označit si hráče, kteří se vůbec nemají objevit ve výpisu. if(scalar(@{$osoba->{vysledky}})==0) { $osoba->{pentamind} = -1; } # Zkopírovat si z 1. výsledku údaje o osobě. else { $osoba->{jmeno} = $osoba->{vysledky}[0]{jmeno}; $osoba->{prijmeni} = $osoba->{vysledky}[0]{prijmeni}; $osoba->{obec} = $osoba->{vysledky}[0]{obec}; $osoba->{zeme} = $osoba->{vysledky}[0]{zeme}; } } # Seřadit hráče podle počtu bodů v Pětimysli. my @osoby_serazene = sort{$b->{pentamind}<=>$a->{pentamind}}(@osobni_vysledky); return \@osoby_serazene; }