#!/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;
}