rendered paste body#!/usr/bin/perl
use locale;
use POSIX qw(locale_h);
setlocale('LC_ALL', 'sv_SE');
$url = 'http://g3.spraakdata.gu.se/cgi-bin/osa/indexsok.cgi?string=';
$fil = 'orda.txt';
$lexikon = 'lexikon.txt';
$tonfil = 'ton.txt';
print <<XXX;
Content-type: text/html
XXX
%ordlista = readlex($lexikon);
%tonlista = readton($tonfil);
open(IN, $fil);
while (<IN>) {
my($ord);
chomp;
$in = $_;
printf "%s<br>\n", dorad($in);
}
sub dorad($) {
$rad = $_;
$ut = "";
LOOP: {
if (/\G(\w+)(\b[,.;]?\s*)/gc) {
$a = $1;
$b = $2;
$ord = $1.$2;
($rot, $end) = normal($1);
if ($rot ne $end) {
if ($ord =~ /^[0-9t-]/i) {
$ut .= "$ord";
} else {
$ut .= "<a href=\"$url$rot\">$1</a>$2";
}
} else {
$ut .= "<font color=\"#ff0000\">$1</font>$2";
}
redo LOOP;
}
}
return $ut;
}
sub normal($) {
# returnerar stam + ndelse vid trff
# returnerar ord + "" vid grundform
# returnerar ord + ord vid olslig (t.ex. -og: dog, drog, slog)
# returnerar ord + ord om det brjar p t-
my ($ord) = @_;
$ord =~ s/[^\w]//g;
$ord = lc($ord);
if ($ordlista{$ord} ne "") {
return $ordlista{$ord};
}
return ($ord, $ord) if ($tonlista{$ord} ne "");
# verb
return ($1."a", $2) if ($ord =~ /(\w+)(ade)$/i);
return ($1."mma", $2) if ($ord =~ /(\w+)(mde)$/i);
return ($1."lla", $2) if ($ord =~ /(\w+)(llde)$/i);
return ($1."a", $2) if ($ord =~ /(\w+)(at)$/i);
return ($1."uta", $2) if ($ord =~ /(\w+)(uta)$/i);
return ($1."unna", $2) if ($ord =~ /(\w+)(unde)$/i);
return ($1."nna", $2) if ($ord =~ /(\w+)(nde)$/i);
return ($1."ka", $2) if ($ord =~ /(\w+)(kte)$/i);
return ($1."a", $2) if ($ord =~ /(\w+)(ades)$/i);
return ($1."e", $2) if ($ord =~ /(\w+)(edde)$/i);
return ($1."", $2) if ($ord =~ /(\w+)(od)$/i);
return ($ord, $ord) if ($ord =~ /(\w+)(og)$/i);
return ($1."da", $2) if ($ord =~ /(\w+)(dde)$/i);
return ($1."gga", $2) if ($ord =~ /(\w+)(gger)$/i);
return ($1."tta", $2) if ($ord =~ /(\w+)(atte)$/i);
return ($1."", $2) if ($ord =~ /(\w+)(tt)$/i);
# skrivit
return ($1."ippa", $2) if ($ord =~ /(\w+)(uppit)$/i);
return ($1."a", $2) if ($ord =~ /(\w+)(it)$/i);
# skrivit
return ($1."a", $2) if ($ord =~ /(\w+)(des)$/i);
# pluralis
return ($1."ara", $2) if ($ord =~ /(\w+)(oro)$/i);
return ($1."uda", $2) if ($ord =~ /(\w+)(do)$/i);
return ($1."e", $2) if ($ord =~ /(\w+)(go)$/i);
return ($1."lla", $2) if ($ord =~ /(\w+)(llo)$/i);
return ($1."aga", $2) if ($ord =~ /(\w+)(ogos)$/i);
return ($1."", $2) if ($ord =~ /(\w+)(ingo)$/i);
# bageri
return ($1."i", $2) if ($ord =~ /(\w+)(iet)$/i);
return ($1."i", $2) if ($ord =~ /(\w+)(ierna)$/i);
return ($1."i", $2) if ($ord =~ /(\w+)(iernas)$/i);
# verksamhet o.dyl.
return ($1.$2, "") if ($ord =~ /(\w+)(het)$/i);
# particip
# skrivet -> skriva
return ($1."a", $2) if ($ord =~ /(\w+)[^rs](et)$/i) && ($ord !~ /\w+het$/i);
# ppnat -> ppna
return ($1."a", $2) if ($ord =~ /(\w+)(at)$/i);
# grvda -> grva
return ($1."a", $2) if ($ord =~ /(\w+)(da)$/i);
# ppnad -> ppna
return ($1."na", $2) if ($ord =~ /(\w+)(nad)$/i);
# tvttad -> tvtta
return ($1."tta", $2) if ($ord =~ /(\w+)(ttad)$/i);
# strdd -> str
return ($1."", $2) if ($ord =~ /(\w+)(dd)$/i);
return ($1."", $2) if ($ord =~ /(\w+)(dd)$/i);
# substantiv
return ($1.$2, $2) if ($ord =~ /(\w+)(pp)ar$/i);
return ($1.$2, $2) if ($ord =~ /(\w+)(st)ar$/i);
return ($1.$2, $2) if ($ord =~ /(\w+)(nd)ar$/i);
return ($1.$2, $2) if ($ord =~ /(\w+)(ing)ar$/i);
return ($1."e", $2) if ($ord =~ /(\w+)(ar)$/i) && ($ord !~ /\w+ingar$/i);
return ($1."e", $2) if ($ord =~ /(\w+)(arna)$/i);
return ($1, $2) if ($ord =~ /(\w+rv)(arne)$/i);
return ($1, $2) if ($ord =~ /(\w+k)(arne)$/i);
return ($1."el", $2) if ($ord =~ /(\w+)(larne)$/i);
return ($1, $2) if ($ord =~ /(\w+[gt])(arne)$/i);
return ($1, $2) if ($ord =~ /(\w+n[dkpt])(arne)$/i);
return ($1, $2) if ($ord =~ /(\w+[]n[g])(arne)$/i);
return ($1."e", $2) if ($ord =~ /(\w+)(arne)$/i);
return ($1."a", $2) if ($ord =~ /(\w+)(or)$/i);
return ($1."a", $2) if ($ord =~ /(\w+)(orna)$/i);
return ($1, "") if ($ord =~ /(\w*bekymmer)$/i);
return ($1, $2) if ($ord =~ /(\w+)(er)$/i);
return ($1."ter", $2) if ($ord =~ /(\w+)(terna)$/i);
return ($1."ng", $2) if ($ord =~ /(\w+)(ngerna)$/i);
return ($1, $2) if ($ord =~ /(\w+)(erna)$/i);
return ($1."a", $2) if ($ord =~ /(\w+)(an)$/i);
# rkneord
return ($1."ton", $2) if ($ord =~ /(\w+)(ton)$/i);
return ($1."o", $2) if ($ord =~ /(\w+)(on)$/i);
return ($1."rr", $2) if ($ord =~ /(\w+)(rren)$/i);
return ($1."er", $2) if ($ord =~ /(\w+)(ren)$/i);
# bten
return ($1, $2) if ($ord =~ /(\w+)(en)$/i);
return ($1, $2) if ($ord =~ /(\w+)(et)$/i);
# njena
return ($1."e", $2) if ($ord =~ /(\w+)(ena)$/i);
return ($1, $2) if ($ord =~ /(\w+rre)(ns)$/i);
return ($1, $2) if ($ord =~ /(\w+)(ens)$/i);
return ($1."a", $2) if ($ord =~ /(\w+)(ans)$/i);
return ($1."er", $2) if ($ord =~ /(\w+)(erns)$/i);
return ($1."r", $2) if ($ord =~ /(\w+)(ren)$/i);
return ($1."r", $2) if ($ord =~ /(\w+)(ret)$/i);
return ($1, $2) if ($ord =~ /(\w+)(et)$/i) && ($ord !~ /\w+het$/i);
return ($1, $2) if ($ord =~ /(\w+)(ets)$/i);
return ($1, $2) if ($ord =~ /(\w+)(de)$/i);
# adjektiv
return ($1."l", $2) if ($ord =~ /(\w+)(la)$/i);
return ($1."el", $2) if ($ord =~ /(\w+)(lare)$/i);
return ($1, $2) if ($ord =~ /(\w+)(are)$/i);
return ($1."or", $2) if ($ord =~ /(\w+)(rre)$/i);
# bestmda former
return ($1."t", $2) if ($ord =~ /(\w+)(ta)$/i);
return ($1."r", $2) if ($ord =~ /(\w+)(ra)$/i);
# neutrum
return ($1.$2, $2) if ($ord =~ /(\w+)(m)t$/i);
return ($1.$2, $2) if ($ord =~ /(\w+)(l)t$/i);
return ($1.$2, $2) if ($ord =~ /(\w+)(ig)t$/i);
return ($1.$2, $2) if ($ord =~ /(\w+)(ng)t$/i);
# brustna -> brusten
return ($1."ten", $2) if ($ord =~ /(\w+)(tna)$/i);
return ($ord, "");
}
sub readlex($) {
%ord = {};
($lexfil) = @_;
open(LEX, "$lexfil");
while(<LEX>) {
chomp;
($k, $v) = split(/ /);
if ($v ne "") {
$ord{$k} = $v;
} else {
$ord{$k} = $k;
}
}
return %ord;
}
sub readton($) {
%ton = {};
($tonfil) = @_;
open(TON, "$tonfil");
while(<TON>) {
chomp;
$tonord = $_;
$ton{$tonord} = $tonord;
}
return %ton;
}