#!/usr/bin/perl

use strict;

my %morphType = (
		 'conj' => 'conj',
		 'adv' => 'adverb',
		 'prep' => 'prep',
		 );

$/ = '<entryFree';

while (<>) {
    s#^\s*key=[^>]+>\s*##s;
    s#<entryFree$##;

    while (s/^<orth[^>]*>([^<]+)<\/orth>[,\s]*<orth[^>]*>([^<]+)<\/orth>[,\s]*<orth[^>]*>([^<]+)<\/orth>[,\s]*<pos>s\.<\/pos>\s*<gen>([mf])\.<\/gen>/ /s)
    {
	my $lem1 = $1;
	my $lem2 = $2;
	my $lem3 = $3;
	my $gen = $4;
	donom($lem1, $gen);
	donom($lem2, $gen);
	donom($lem3, $gen);
    }

    while (s/^<orth[^>]*>([^<]+)<\/orth>[,\s]*<orth[^>]*>([^<]+)<\/orth>[,\s]*<pos>s\.<\/pos>\s*<gen>([mf])\.<\/gen>/ /s)
    {
	my $lem1 = $1;
	my $lem2 = $2;
	my $gen = $3;
	donom($lem1, $gen);
	donom($lem2, $gen);
    }

    while (s/<orth[^>]*>([^<]+)<\/orth>[,\s]*<orth[^>]*>([^<]+)<\/orth>[,\s]*<pos>v\.<\/pos>/ /s)
    {
	my $lem1 = $1;
	my $lem2 = $2;
	doverb($lem1);
	doverb($lem2);
    }

    while (s/<orth[^>]*>([^<]+)<\/orth>[,\s]*<orth[^>]*>([^<]+)<\/orth>[,\s]*<pos>(?:adj|pron)\.<\/pos>/ /s)
    {
	my $lem1 = $1;
	my $lem2 = $2;
	doadj($lem1);
	doadj($lem2);
    }

    while (s/^<orth[^>]*>([^<]+)<\/orth>[,\s]*<pos>s\.<\/pos>\s*<gen>([mf])\.<\/gen>/ /s) {
	my $lem = $1;
	my $gen = $2;

	donom($lem,$gen);
    }

    while (s/<gen>([mf])\.<\/gen>\s+<orth[^>]*>([^<]+)<\/orth>/ /s) {
	my $gen = $1;
	my $lem = $2;

	donom($lem,$gen);
    }

    while (s/<orth[^>]*>([^<]+)<\/orth>[,\s]*(?:<pos>s\.<\/pos>\s*)?<gen>([mf])\.<\/gen>/ /s) {
	my $lem = $1;
	my $gen = $2;

	donom($lem,$gen);
    }

    ## Baretti has entries for some regularly declined pronouns
    while (s/<orth[^>]*>([^<]+)<\/orth>[,\s]*<pos>pron\.<\/pos>\s*<gen>([mf])\.<\/gen>/ /s) {
	my $lem = $1;
	my $gen = $2;
	donom($lem,$gen);
    }

    while (s/<orth[^>]*>([^<]+)<\/orth>[,\s]*<pos>(?:adj|pron)\.<\/pos>/ /s
	   or s/<pos>adj\.<\/pos>\s*<orth[^>]*>([^<]+)<\/orth>/ /s) {
	my $lem = $1;

	doadj($lem);
    }

    while (s/^<orth[^>]*>([^<]+)<\/orth>[,\s]*<orth[^>]*>([^<]+)<\/orth>[,\s]*<orth[^>]*>([^<]+)<\/orth>[,\s]*<pos>(adv|conj|prep)\.<\/pos>/ /s)
    {
	my $lem1 = $1;
	my $lem2 = $2;
	my $lem3 = $3;
	my $type = $4;

	doindecl($lem1, $type);
	doindecl($lem2, $type);
	doindecl($lem3, $type);
    }

    while (s/^<orth[^>]*>([^<]+)<\/orth>[,\s]*<orth[^>]*>([^<]+)<\/orth>[,\s]*<pos>(adv|conj|prep)\.<\/pos>/ /s)
    {
	my $lem1 = $1;
	my $lem2 = $2;
	my $type = $3;

	doindecl($lem1, $type);
	doindecl($lem2, $type);
    }

    while (s/<orth[^>]*>([^<]+)<\/orth>[,\s]*<pos>(adv|conj|prep)\.<\/pos>/ /s
	   or s/<pos>(adv|conj|prep)\.<\/pos>\s*<orth[^>]*>([^<]+)<\/orth>/ /s) {
	my $lem = $1;
	my $type = $2;

	if ($morphType{$lem}) {
	    my $swap = $type;
	    $type = $lem;
	    $lem = $swap;
	}

	doindecl($lem,$type);
    }

    while (s/<orth[^>]*>([^<]+)<\/orth>[,\s]*<pos>v\.<\/pos>/ /s) {
	my $lem = $1;

	doverb($lem);
    }
}

sub donom {
    my($lem,$gen) = @_;

    $lem = fixlem($lem);

    return unless defined($lem);

    $gen = $gen eq 'f' ? 'fem' : 'masc';
    
    my $class = 'irreg_nom';
    my $stem = $lem;

    if ($stem =~ s/io$//) {
	$class = 'io_i';
    }
    elsif ($stem =~ s/o$//) {
	$class = 'o_i';
    }
    elsif ($stem =~ s/a$//) {
	$class = 'a_e';
    }
    elsif ($stem =~ s/e$//) {
	$class = 'e_i';
    }
    elsif ($stem =~ s/a\\$//) {
	$class = 'a_acc';
    }
    elsif ($stem =~ s/u\\$//) {
	$class = 'u_acc';
    }

    my $label = 'no';
    $label = 'wd' if $class eq 'irreg_nom';

    print "\n:le:$lem\n";
    print ":$label:$stem\t$class $gen\n";
}

sub doadj {
    my($lem) = @_;

    return unless $lem = fixlem($lem);

    my $stem = $lem;
    my $class = '';

    if ($lem =~ /nta$/)
    {
	print "\n:le:$lem\n";
	print ":wd:$lem\tnumeral\n";
	return;
    }
    
    $stem =~ s/a$/o/;	# some adj only appear in the feminine in this dictionary
    
    if ($stem =~ s/co$//) {
	$class = 'co_ca';
    }
    elsif ($stem =~ s/go$//) {
	$class = 'go_ga';
    }
    elsif ($stem =~ s/[o]$//) {
	$class = 'o_a';
    }
    elsif ($stem =~ s/[e]$//) {
	$class = 'e_i';
    }

    if ($class eq '')
    {
	print "\n:le:$lem\n";
	print ":wd:$lem\tirreg_nom\n";
	return;
    }

    print "\n:le:$lem\n";
    print ":aj:$stem\t$class\n";

}
sub doverb {
    my($lem) = @_;

    $lem = fixlem($lem);

    return unless defined($lem);

    my $class = '';
    my $stem = $lem;

    if ($stem =~ s/(care|gare|ciare|giare|are|ere|ire|urre|arre|orre)$//) {
	$class = $1 . "_vb";
    }
    elsif ($stem =~ s/(carsi|garsi|ciarsi|giarsi|arsi|ersi|irsi)$//)
    {
	$class = $1 . "_vb";
    }
    else
    {
	$class = "irreg_vb";
	print STDERR "vb $lem\n";
    }

    return if $class eq '';
    
    print "\n:le:$lem\n";
    print ":de:$stem $class\n";
}

sub doindecl {
    my($lem, $type) = @_;

    $lem = fixlem($lem);
    $type = $morphType{$type};

    return unless defined($lem);
    return unless $type;

    print "\n:le:$lem\n";
    print ":wd:$lem\t$type\n";
}

sub fixlem {
    my($lem) = @_;

    return undef if ($lem =~ /\s/);

    $lem =~ tr/Jj\-/Ii/d;
    $lem =~ s/\&([A-Za-z])(uml|acute);/$1/g;
    $lem =~ s/\&([A-Za-z])grave;/$1\\/g;

    lc($lem);
}
