Ola
tak dam nejaku snad zaujimavu programatorsku challenge aj ja. Rad by som napisal program, ktory z neomezenej gramatiky dokaze v rozumnom case vypluvat slova, ktore gramatika generuje.
Zbastlil som si nejaky blud v Perli. Algoritmus je z toho snad celkom dobre vidiet, mam frontu (na zaciatku je v nej pociatocny neterminal), vyberiem z nej slovo, prejdem v cykle vsetky pravidla tvaru A -> α, nahradim v onom slove po jednom vsetky vyskyty A za α a nove slova narvem zase do fronty.
Pridal som k tomu nejaku kontrolu, nech sa do fronty necpu vetne formy, ktore tam uz boli, ale stale to bezi sakra pomaly. Mam tam gramatiku pre slova { a.b.a^2.b.a^3.b...a^n.b | n >= 1 } (pravidla su v hashmape %p), do par sekund mi to napocita slova po n=4, dalsiu minutu uz nic.
Moc sa v takychto veciach neorientujem, takze nemam sajnu, ci su nejake rozumne postupy na to, ako toto zrychlit. Co mam skusit? Teraz mi napada, ze by mozno pomohlo hadzat prioritne do fronty slova, ktore obsahuju uz iba malo neterminalov/lavych stran (co z toho?) pravidiel. Nejake dalsie napady?
Co gramatiky nizsie v Chomskeho hierarchii? Ide pisat efektivne skripty aspon pre nejake omezenejsie typy gramatik (-> pomahaju nejake normalne formy)?
Diky.
(Akceptujem rozumne riesenia v akomkolvek jazyku/pseudokode)
Kód:
#!/usr/bin/perl
use strict;
# pravidla gramatiky, vlavo lava strana, vpravo arrayref pravych stran
my %p = (
S => [ qw(ab ZSA) ],
bA => [ 'Aab' ],
aA => [ 'Aa' ],
ZA => [ 'ab' ],
);
# pociatocny neterminal
my @queue = qw(S);
my %dupls = ();
while (@queue) {
my $word = shift @queue;
if ($dupls{$word}) {
next;
}
$dupls{$word} = 1;
# neterminaly a terminaly su odlisene velkostou pismen
if ($word eq lc $word) {
print "$word\n";
}
else {
while (my ($left, $right) = each %p) {
push @queue, map { replace_seq($word, $left, $_) } @$right;
}
}
}
# pomocna subrutina, vrati vsetky nahradenia $_[1] za $_[2] v $_[0]
# pr.: replace_seq('ababa', 'a', 'x') ~> ('xbaba', 'abxba', 'ababx')
sub replace_seq {
my ($haystack, $needle, $replacement) = @_;
my @matches = $haystack =~ /$needle/g;
my $needleqr = qr/$needle/;
my @result = ();
for my $i (0 .. $#matches) {
my $before = join '.*?', map { $needleqr } (0 .. $i - 1);
my $subst = $haystack;
$subst =~ s/(.*?$before.*?)$needle(.*)/$1$replacement$2/;
push @result, $subst;
}
return @result;
}
