Zagadka brzmi tak:
Mamy jakiś stan początkowy populacji – ludzi o pewnych nazwiskach. Jak wiadomo, kiedy brak męskich nosicieli danego nazwiska, najczęściej ono ginie. Wspólnie ze Szczudełkiem postanowiliśmy zbadać, jak szybko giną nazwiska.
Skrypcik po doszlifowaniu wygląda następująco (Tu uwaga: jeśli widzisz w moim poście kod programu i nic Ci on nie mówi, śmiało omiń i czytaj dalej – w życiu nie trzeba być informatykiem)
#!/usr/bin/perl
use utf8;
use diagnostics -trace;
use strict;
use warnings FATAL => 'all';
use Data::Dumper;
use List::MoreUtils qw(uniq);
use feature qw(say);
use Math::CDF qw(qpois);
use constant PERCENTAGE_FATHERLESS => 5;
use constant FERTILITY_RATE => 2.0;
use constant MALE => 0;
use constant FEMALE => 1;
# liczba unikatowych nazwisk w populacji
sub names($) {
my ($population) = @_;
return scalar uniq map { $_->{surname} } @$population;
}
# losuj liczbę dzieci dla osobnika
# - wg rozkładu Poissona z wartością oczekiwaną
# równą podanej dzietności
sub get_children_number() {
my $r = rand(1);
my $res = qpois($r, FERTILITY_RATE);
return $res ? int($res + 1) : 0;
}
# tworzy listę nowych dzieci o danym nazwisku,
# z losową płcią
sub get_new_children($) {
my ($surname) = @_;
my $res = [];
my $children = get_children_number();
for (1..$children) {
push @$res, {
surname => $surname,
gender => int(rand(1) + 0.5)
};
}
return $res;
}
# tworzy kolejne pokolenie na podstawie starego
sub evolve($) {
my ($old_generation) = @_;
my $new_generation = [];
foreach my $person (@$old_generation) {
my $fatherless = rand(100) < PERCENTAGE_FATHERLESS;
next if $person->{gender} eq FEMALE && !$fatherless
|| $person->{gender} eq MALE && $fatherless;
push @$new_generation, @{get_new_children($person->{surname})};
}
return $new_generation;
}
# drukowanie listy 10 najczęstszych nazwisk w populacji
sub charts_string($) {
my ($population) = @_;
my %surnames = ();
foreach (@$population) {
if (defined $surnames{$_->{surname}}) {
$surnames{$_->{surname}}->{count}++;
} else {
$surnames{$_->{surname}} = {
count => 1,
surname => $_->{surname}
};
}
}
my @sorted = sort { $b->{count} <=> $a->{count} } values %surnames;
return join '', map { "$_->{count} $_->{surname}\n" } @sorted[0..9];
}
srand();
binmode(STDOUT, ":utf8");
my $population = init_population();
print "Najczęstsze nazwiska przed:\n" . charts_string($population);
# 20 pokoleń lub do wymarcia prawie wszystkich
my $i = 0;
while (1) {
my ($individuals, $names) = (scalar @$population, names($population));
say "Pokolenie $i >> Osób: $individuals, nazwisk: $names";
my $new_population = evolve($population);
last if $i++ == 20 || scalar @$new_population <= 10;
$population = $new_population;
}
print "Najczęstsze nazwiska po:\n" . charts_string($population);
Przyjęliśmy dzietność 2,0 (czyli dwa bachory na jedną panią – sporo więcej niż aktualnie w Polsce) i założenie, że ok. 5% ludzi ma nazwisko po matce. Jak się okazało, wyniki są bardzo, bardzo, bardzo zależne od początkowego stanu populacji, czyli funkcji init_population. Przed nami wyniki dla kolejnych możliwości.
Opcja 1
Populacja początkowa: 100 000 par, każde o innym nazwiskuWynik:
Pokolenie 0 >> Osób: 200000, nazwisk: 100000 Pokolenie 1 >> Osób: 199004, nazwisk: 82665 Pokolenie 2 >> Osób: 198498, nazwisk: 55965 Pokolenie 3 >> Osób: 198805, nazwisk: 42820 Pokolenie 4 >> Osób: 199402, nazwisk: 34816 Pokolenie 5 >> Osób: 199798, nazwisk: 29327 Pokolenie 6 >> Osób: 199597, nazwisk: 25431 Pokolenie 7 >> Osób: 199586, nazwisk: 22518 Pokolenie 8 >> Osób: 199853, nazwisk: 20197 Pokolenie 9 >> Osób: 198873, nazwisk: 18243 Pokolenie 10 >> Osób: 199519, nazwisk: 16605 Pokolenie 11 >> Osób: 199869, nazwisk: 15298 Pokolenie 12 >> Osób: 200376, nazwisk: 14191 Pokolenie 13 >> Osób: 199882, nazwisk: 13299 Pokolenie 14 >> Osób: 199578, nazwisk: 12391 Pokolenie 15 >> Osób: 198772, nazwisk: 11642 Pokolenie 16 >> Osób: 199250, nazwisk: 11009 Pokolenie 17 >> Osób: 198838, nazwisk: 10397 Pokolenie 18 >> Osób: 198793, nazwisk: 9886 Pokolenie 19 >> Osób: 198159, nazwisk: 9420 Pokolenie 20 >> Osób: 198052, nazwisk: 8972 Najczęstsze nazwiska po: 226 Nazwisko90665 221 Nazwisko86549 200 Nazwisko77204 186 Nazwisko26968 181 Nazwisko49432 175 Nazwisko83747 169 Nazwisko34857 167 Nazwisko44717 163 Nazwisko85779 159 Nazwisko71347Czyli: po 20 pokoleniach (ok. 450 latach) wyginęło 90% nazwisk, a największe rodziny rozrosły się do ponad 200 osób.
Opcja 2
Powyższe wyniki są ciekawe, ale mają mało wspólnego z rzeczywistością – trudno się dziwić, że nazwiska giną, jeśli na początku mamy tylko po jednym męskim przedstawicielu każdego z nich. Baza moikrewni.pl zawiera ponad 300 000 nazwisk. Skoro Polaków jest prawie 40 000 000, to można w dużym uproszczeniu przyjąć, że przypada średnio 120 osób na jedno nazwisko. Zatem nowe warunki początkowe to: nadal 200 000 osób, ale tylko 1667 nazwisk – każde noszone przez 120 osób (zaokrągleniami proszę się nie przejmować). Co się okazuje?Pokolenie 0 >> Osób: 200000, nazwisk: 1667 Pokolenie 1 >> Osób: 200305, nazwisk: 1667 Pokolenie 2 >> Osób: 199561, nazwisk: 1667 Pokolenie 3 >> Osób: 199523, nazwisk: 1667 Pokolenie 4 >> Osób: 198580, nazwisk: 1667 Pokolenie 5 >> Osób: 199792, nazwisk: 1667 Pokolenie 6 >> Osób: 199599, nazwisk: 1667 Pokolenie 7 >> Osób: 199167, nazwisk: 1667 Pokolenie 8 >> Osób: 199406, nazwisk: 1667 Pokolenie 9 >> Osób: 198579, nazwisk: 1667 Pokolenie 10 >> Osób: 197933, nazwisk: 1667 Pokolenie 11 >> Osób: 197333, nazwisk: 1667 Pokolenie 12 >> Osób: 196019, nazwisk: 1667 Pokolenie 13 >> Osób: 195087, nazwisk: 1667 Pokolenie 14 >> Osób: 194913, nazwisk: 1667 Pokolenie 15 >> Osób: 194587, nazwisk: 1665 Pokolenie 16 >> Osób: 194146, nazwisk: 1665 Pokolenie 17 >> Osób: 193966, nazwisk: 1665 Pokolenie 18 >> Osób: 193047, nazwisk: 1664 Pokolenie 19 >> Osób: 193629, nazwisk: 1664 Pokolenie 20 >> Osób: 192437, nazwisk: 1660 Najczęstsze nazwiska po: 411 Nazwisko584 410 Nazwisko318 379 Nazwisko947 376 Nazwisko290 370 Nazwisko1209 354 Nazwisko1325 343 Nazwisko1086 327 Nazwisko99 323 Nazwisko296 316 Nazwisko1408Okazuje się, że nazwiska w ogóle, ale to w ogóle nie giną! Pierwsze straty mamy dopiero po 15 pokoleniach. Przyczyna jest prosta – skoro każdy klan ma aż 120 osób, to musi minąć dużo czasu, żeby z 60 facetów zrobiło się 0.
Opcja 3
Trzeba trochę uprawdopodobnić obliczenia, żeby miały jakikolwiek sens. W internecie można znaleźć listę polskich nazwisk wraz z ich częstością. I teraz robi się to bardziej związane z rzeczywistością. Tworzymy nową funkcję do wczytywania populacji początkowej:sub read_population($) {
my ($file) = @_;
my $population = [];
open (FILE, "<:encoding(UTF-8)", $file);
while (my ($number, $surname) = split(' ', <FILE>)) {
$number /= 100;
for (1..int($number + 0.5)) {
push @$population, {
surname => $surname,
gender => int(rand(1) + 0.5)
};
}
}
close FILE;
return $population;
}
Czyli: bierzemy każde nazwisko z listy, zmniejszamy jego liczbę wystąpień stukrotnie (żeby komputer się nie udławił) i wrzucamy do populacji początkowej. Oto wyniki:Najczęstsze nazwiska przed: 2202 Nowak 1319 Kowalski 1044 Wiśniewski 929 Dąbrowski 894 Lewandowski 889 Wójcik 879 Kamiński 877 Kowalczyk 860 Zieliński 845 Szymański Pokolenie 0 >> Osób: 345574, nazwisk: 63646 Pokolenie 1 >> Osób: 344980, nazwisk: 40700 Pokolenie 2 >> Osób: 345816, nazwisk: 32101 Pokolenie 3 >> Osób: 344508, nazwisk: 27010 Pokolenie 4 >> Osób: 345314, nazwisk: 23533 Pokolenie 5 >> Osób: 343806, nazwisk: 21005 Pokolenie 6 >> Osób: 343487, nazwisk: 19072 Pokolenie 7 >> Osób: 344805, nazwisk: 17547 Pokolenie 8 >> Osób: 344399, nazwisk: 16203 Pokolenie 9 >> Osób: 344761, nazwisk: 15127 Pokolenie 10 >> Osób: 344749, nazwisk: 14172 Pokolenie 11 >> Osób: 344073, nazwisk: 13367 Pokolenie 12 >> Osób: 343932, nazwisk: 12614 Pokolenie 13 >> Osób: 343487, nazwisk: 11976 Pokolenie 14 >> Osób: 343945, nazwisk: 11446 Pokolenie 15 >> Osób: 345201, nazwisk: 10925 Pokolenie 16 >> Osób: 345240, nazwisk: 10461 Pokolenie 17 >> Osób: 344585, nazwisk: 10029 Pokolenie 18 >> Osób: 345600, nazwisk: 9616 Pokolenie 19 >> Osób: 345595, nazwisk: 9255 Pokolenie 20 >> Osób: 344289, nazwisk: 8933 Najczęstsze nazwiska po: 2957 Nowak 1366 Kowalski 1144 Lewandowski 1039 Wiśniewski 1004 Kaczmarek 958 Kozłowski 958 Dąbrowski 957 Woźniak 935 Piotrowski 839 WójcikPopulacja zrobiła się większa (345 000, czyli baza nazwisk wygląda na niezłą – stukrotnie więcej to prawie rzeczywista liczba ludności Polski, błędy mogą wynikać z zaokrągleń). I nazwiska giną! Giną w tempie strasznym, za 450 lat będzie ich tylko 9000, a Nowaków i Kowalskich zrobi się jeszcze więcej...
Ciekawy post. Mógłbyś dodać opcję ukrywania kodu (albo jego zwijania)? Przyznam, że akurat kod Perla mało mnie interesuje (w ogóle jakikolwiek kod mało mnie interesuje - mam go na codzień aż za dużo :) ), natomiast przewijanie kilkudziesięciu linijek tekstu jest uciążliwe i nieco utrudnia czytanie.
OdpowiedzUsuń