Permalink
Switch branches/tags
Nothing to show
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
executable file 92 lines (67 sloc) 2.42 KB
#!/usr/bin/perl
# Käyttö: perl kalevala-grep.pl < file.txt
# (c) Oona Räisänen 2014
# > elämä on hämmentävää
# > kuka mistäki hepuloi
# > tekis mieli leivoksia
# > emmä jaksa tilaa mistää
use strict;
use warnings;
use utf8;
use 5.010;
binmode(STDIN, ':encoding(utf8)');
binmode(STDOUT, ':encoding(utf8)');
my $VOK = '[aeiouyäöå]';
my $KON = '[bcdfghjklmnpqrstvwxz]';
# Lyhyitä ovat tavut, jotka päättyvät lyhyeen vokaaliin: esimerkiksi o, me, na
my $TI = $KON.'?'.$VOK;
# Pitkiä ovat tavut,
# 1) jotka päättyvät konsonanttiin (vir, kis, tys)
# 2) joissa on diftongi (ui, vei, vai)
# 3) joissa on pitkä vokaali (uu, kuu, vaa)
my $TAA = '[a-zåäö]*(?:'.$KON.'|'.$VOK.$VOK.')';
# Tavut jaetaan lyhyisiin ja pitkiin ylläolevasti
my $TAVU = '(?:'.$TI.'|'.$TAA.')';
while (<>) {
chomp;
my $tavut = tavuta(normalisoi($_));
# Yksinkertaistus: Säe hyväksytään, jos siinä on 8 tavua ...
if ($tavut =~ /^ $TAVU (?:[\- ]$TAVU){7} $/x &&
# ... viimeinen sana ei ole yksitavuinen
$tavut !~ /\s $TAVU $/x &&
# ... ja viimeisessä sanassa on pitkä ensitavu runojalan nousussa
# tai lyhyt ensitavu runojalan laskussa
$tavut =~ /\s (?: $TI | $TAA-$TAVU) (?: -$TAVU-$TAVU ){0,2} $/x) {
say;
}
}
# Kielitoimiston ohjepankki: Tavutus
sub tavuta {
my $tulos = shift;
# 1) Tavuraja on aina konsonantin ja vokaalin yhdistelmän edellä
$tulos =~ s/\B ($KON) ($VOK)/-$1$2/igx;
# 2) Tavuraja on sellaisten eri vokaalien välissä,
$tulos =~ s/($VOK) ( (?!\1) $VOK )/$1-$2/igx;
# jotka eivät muodosta diftongia
$tulos =~ s/( [aeouyäö]-i | [eäö]-y | [aeio]-u | u-o | y-ö
)/substr($1,0,1).substr($1,2,1)/egx;
# ie, uo ja yö esiintyvät diftongeina vain ensimmäisessä tavussa; kauempana
# sanassa ie katsotaan vokaaliyhtymäksi
# (jätetään uo ja yö kuitenkin diftongeiksi yhdyssanojen takia)
$tulos =~ s/( (?:^|\s) [^-]*) i-e /$1ie/igx;
# murteellisia poikkeuksia:
# kolmen peräkkäisen vokaalin väliin tulee tavuraja
$tulos =~ s/([aeouyäö]i | [eäö]y | [aeio]u | uo | yö | ie)($VOK)/$1-$2/igx;
$tulos =~ s/($VOK) \1 ($VOK)/$1$1-$2/igx;
# heittomerkki luo tavurajan
$tulos =~ s/($VOK) ' ($VOK)/$1-$2/gx;
$tulos =~ s/'//gx;
return $tulos;
}
sub normalisoi {
my $norm = lc shift;
$norm =~ s/[^a-zåäö']+/ /gx; # välimerkit pois
$norm =~ s/^\s+|\s+$//gx; # ltrim, rtrim
$norm =~ s/\s+/ /gx; # ylimääräiset whitespacet
return $norm;
}