#!/usr/bin/perl -w
#
# This script extracts stardict tab-format deconjugations
# from the verbiste program.
# 
# J.J.Green 2009
# $Id: vsd.pl,v 1.9 2012/07/31 13:40:42 jjg Exp $

use strict;  

use encoding "utf8";

use POSIX;
use IPC::Open2;
use IO::Handle;

autoflush STDOUT 1;

# 0.90 - 20/09/2009 - initial release
# 0.91 - 22/09/2009 - fixed some encoding issues 
# 0.92 - 30/09/2009 - merging of definitions
# 0.93 - 05/10/2009 - now uses --all-infinitives
# 0.93 - 31/07/2012 - updated to use verbiste 0.34, removed

my $version = "0.94";

print "This is vsd (version $version)\n";

# data for writing out the definitions, split into
# a dictionary of abbreviations and a subroutine which 
# uses that dictionary

# English abbreviations, taken from the Shorter Oxford 
# English Dictionary 1983

my $abbren = {
    mood => {
	'indicative'   => 'indic.',
	'conditional'  => 'cond.',
	'subjunctive'  => 'subj.',
	'imperative'   => 'imper.',
	'participle'   => 'pple.',
    },
    tense => {
	'present'   => 'pres.',
	'imperfect' => 'impf.',
	'past'      => 'pa.',
	'future'    => 'fut.',
    },
    person => {
	'1' => "1st",
	'2' => "2nd",
	'3' => "3rd",
	'4' => "masc.",
	'5' => "fem.",
    },
    number => {
	'singular' => 'sing.',
	'plural'   => 'pl.',
    },
};

sub makedef_en
{
    my ($inf,$moods,$tenses,$persons,$numbers) = @_;
	    
    my $mood  = join('/',map { $abbren->{mood}->{$_} } @$moods);
    my $tense = join('/',map { $abbren->{tense}->{$_} } @$tenses);

    my $def = sprintf "%s: %s %s",$inf,$tense,$mood;

    unless 
	(
	 ($tense eq $abbren->{tense}->{'present'}) 
	 and 
	 ($mood eq $abbren->{mood}->{'participle'})
	)
    {
	my $person = join('/',map { $abbren->{person}->{$_} } @$persons);
	my $number = join('/',map { $abbren->{number}->{$_} } @$numbers);

	$def = sprintf "%s %s pers. %s",$def,$person,$number;
    }

    return $def;
};

# French, these taken from Le Petit Robert 2009
# except LPR uses p. for past, we use passé
# likewise LPR uses imp. for imperfect, we
# use imparf.

my $abbrfr = {
    mood => {
	'indicative'   => 'indic.',
	'conditional'  => 'condit.',
	'subjunctive'  => 'subj.',
	'imperative'   => 'impér.',
	'participle'   => 'p.',
    },
    tense => {
	'present'   => 'prés.',
	'imperfect' => 'imparf.',
	'past'      => 'passé',
	'future'    => 'fut.',
    },
    person => {
	'1' => "1re",
	'2' => "2e",
	'3' => "3e",
	'4' => "masc.",
	'5' => "fém.",
    },
    number => {
	'singular' => 'sing.',
	'plural'   => 'pl.',
    },
};

sub makedef_fr
{
    my ($inf,$moods,$tenses,$persons,$numbers) = @_;
	    
    my $mood  = join('/',map { $abbrfr->{mood}->{$_} } @$moods);
    my $tense = join('/',map { $abbrfr->{tense}->{$_} } @$tenses);

    my $def = sprintf "%s : %s %s",$inf,$mood,$tense;

    if ($mood eq $abbrfr->{mood}->{'participle'})
    {
	# past participle has no person nor number

	unless ($tense eq $abbrfr->{tense}->{'present'})
	{	    
	    # for present participle the person is the 
	    # gender, so we get "masc. sing" "fem. pl." 
	    # etc. no need for du

	    my $person = join('/',map { $abbrfr->{person}->{$_} } @$persons);
	    my $number = join('/',map { $abbrfr->{number}->{$_} } @$numbers);

	    $def = sprintf "%s, %s %s",$def,$person,$number;
	}
    }
    else
    {
	# non-participle moods have person & number,
	# usually seen as "2e per. du sing." etc

	my $person = join('/',map { $abbrfr->{person}->{$_} } @$persons);
	my $number = join('/',map { $abbrfr->{number}->{$_} } @$numbers);

	$def = sprintf "%s, %s pers. du %s",$def,$person,$number;
    }

    return $def;
};

if (scalar @ARGV > 1)
{
    warn("usage: perl verbiste-stardict.pl [path]\n");
    warn("where [path] is the optional location of verbiste's\n");
    warn("verb database verbs-fr.xml\n");

    exit EXIT_FAILURE;
}

my ($verbfile) = @ARGV;

my @infins = ();

print "reading infinitives ..";

if ($verbfile)
{
    use XML::Simple;

    # read the list of infinitives from the verbiste
    # xml file given on the command line

    if (-e $verbfile)
    {
	# read xml data
	
	my $verb = XMLin($verbfile);

	foreach my $word (@{$verb->{v}})
	{
	    my $infin = $word->{i};
	    push @infins,$infin;
	}
    }
    else
    {
	warn("verb file $verbfile not found\n");
	exit EXIT_FAILURE;
    }
}
else
{
    # otherwise (and easier) is to use the --all-infinitives
    # output of the french-deconjugator (note this requires
    # verbiste 0.1.27 or later)

    my $cmd = "french-conjugator --all-infinitives"; 

    open INF,"$cmd |" or die "falied opening $cmd\n";
    binmode INF,':encoding(utf8)';

    while (my $infin = <INF>)
    {
	chomp $infin;
	push @infins,$infin;
    }

    close INF;
}

printf ". done (%i)\n",scalar @infins;

my @jobs = (
    {
	makedef => \&makedef_en,
	tabfile => "vsd-en.tab",
    },
    {
	makedef => \&makedef_fr,
	tabfile => "vsd-fr.tab",
    },
    );

# open conjugator/deconjugator processes

my ($fci, $fco);
my $fcpid = open2($fco,$fci,'french-conjugator');

binmode $fco,':encoding(utf8)';
binmode $fci,':encoding(utf8)';

my ($fdi, $fdo);
my $fdpid = open2($fdo,$fdi,'french-deconjugator');

binmode $fdi,':encoding(utf8)';
binmode $fdo,':encoding(utf8)';

# cycle over infinitives

print "reading conjugates ..";

my %forms = ();

foreach my $infin (@infins)
{
    # read output from french conjugator and so harvest all
    # forms of the verb

    print $fci "$infin\n";

    my $n = 0;

    while (my $line = <$fco>)
    {
	last if $line =~ /^-$/o;
	next if $line =~ /^-/o;
	next if $line =~ /^ *$/o;
	chomp $line;

	foreach my $subform (split(/, /o,$line))
	{
	    $forms{$subform} = 1;
	    $n++;
	}
    }

    unless ($n)
    {
	printf "%s has no forms\n",$infin;
    }
}

printf ". done (%i)\n",scalar(keys %forms);

foreach my $job (@jobs)
{
    my $tabfile = $job->{tabfile};
    my $makedef = $job->{makedef};

    # open output

    open TAB, "> $tabfile" or die "opening tabfile\n";
    binmode TAB,':encoding(utf8)';    

    print "writing $tabfile ..";

    foreach my $form (sort keys %forms)
    {
	# write this form to the french deconjugator

	print $fdi "$form\n";

	# read the output from the french deconjugator for the form
	# creating a hash of mood-tense-preson-number quads indexed
	# by the infinitives
	
	my %quads = ();
	
	while (my $line = <$fdo>)
	{
	    last if $line =~ /^ *$/; 
   
	    chomp $line;

	    if (my ($inf,$mood,$tense,$person,$number) = 
		split(/, */,$line))
	    {
		next if $mood eq 'infinitive';
		
		if ($person == 0)
		{
		    warn "untrapped infinitive\n";
		    exit 1;
		}
		
		my $quad = [[$mood],[$tense],[$person],[$number]];
		
		push @{$quads{$inf}},$quad;
	    }
	}

	# not an error -- this happens if the form is infinitive
	# since those are not in the dictionary and so not in 
	# the %quads hash

	next unless scalar keys %quads  > 0;

	foreach my $inf (keys %quads)
	{
	    my @quads = @{$quads{$inf}};
	    my @defs = ();

	    # print "$inf -> $form\n";

	    merge(\@quads);

	    foreach my $quad (@quads)
	    {
		my ($moods,$tenses,$persons,$numbers) = @$quad;

		my $def = $makedef->($inf,$moods,$tenses,$persons,$numbers);
		push @defs, $def;
	    }
	    
	    if (@defs)
	    {	
		print TAB $form,"\t",join('\n',@defs),"\n"; 
	    }
	}
    }   
    close TAB;

    print ". done\n";
}

print "completed.\n";

sub printseq
{
    my $seq = shift;
    my @words = ();

    foreach my $e (@$seq)
    {
        push @words,join('/',@$e);
    }

    print join("\t",@words),"\n";
}

sub merge
{
    my $dat = shift;
    while (merge_changed($dat) > 0) {} ;
}
    
sub merge_changed
{
    my $dat = shift;

    if (my $head = shift @$dat)
    {
	my $n = merge_head($head,$dat) + merge_changed($dat);	
	push @$dat,$head;

	return $n;
    }

    return 0;
}

sub merge_head
{
    my ($head,$dat) = @_;
    my @d = ();
    my $changed = 0;

    while (my $e = shift @$dat)
    {
	my $n = compare_wordseq($head,$e);

	if ($n == 0)
	{
	    # too verbose for verbiste 0.1.26
	    # which contains duplicates for -éser
	    # verbs

	    # print "found duplicates for\n";
	    # printseq($head);

	    print "d";

	    $changed++;
	}
	elsif ($n == 1)
	{
	    merge_seq($head,$e);
	    $changed++;
	}
	else
	{
	    push @d,$e;
	}
    }

    @$dat = @d;

    return $changed;
}

sub merge_seq
{
    my ($a,$b) = @_;

    for (my $i=0 ; $i<4 ; $i++)
    {
	merge_word($a->[$i],$b->[$i]);
    }
}

sub merge_word
{
    my ($a,$b) = @_;
    my %h = ();

    foreach my $e (@$a,@$b)
    {
	$h{$e} = 1;
    }

    @$a = sort keys %h;
}

sub compare_wordseq
{
    my ($a,$b) = @_;

    my $diff = 0;

    for (my $i=0 ; $i<4 ; $i++)
    {
	$diff += (wordalt_equal($a->[$i],$b->[$i]) ? 0 : 1);
    }

    return $diff;
};

sub wordalt_equal
{
    my ($a,$b) = @_;

    my $na = scalar @$a;
    my $nb = scalar @$b;

    if ($na != $nb){ return 0; }

    for (my $i=0 ; $i<$na ; $i++)
    {
	if ($a->[$i] ne $b->[$i])
	{
	    return 0;
	}
    }

    return 1;
};
