#!/usr/bin/env perl

use utf8;
use 5.008;
use strict;
use warnings;
use autodie;
use List::MoreUtils qw( any all );
#use Readonly;

binmode(STDOUT, ":utf8");
# Vstup: adresář se soubory *.out.conll a *.vertbackup, popř. out.mcd a .vertbackup
my $INPUT_DIR;
my $input_file_type = 'conll'; # Can be changed to 'mcd' with option -C
my %recover_changed_afuns; # Set by options "U" (recover _Co and _Ap suffixes) and "V" (recover changed verbal afuns):
my $recover_chunking = 0; # Set by option "K"
my $output_file_type = 'vert';

while ($ARGV[0] =~ /^\-[MCUuVvKkcOo]+$/) {
    my $arg0 = shift @ARGV;
    my @args0 = split //, $arg0;
    foreach $arg0 (@args0) {
	if ($arg0 eq 'C') { $input_file_type = 'mcd'; }
	elsif ($arg0 eq 'M') { $input_file_type = 'conll'; }
	elsif ((uc($arg0) eq 'U')||(uc($arg0) eq 'V')) { $recover_changed_afuns{uc($arg0)}=1; }
	elsif ($arg0 eq 'c') { $recover_changed_afuns{'U'}=1; } # Pro kompatibilitu se Simplify.
	elsif (uc($arg0) eq 'K') { $recover_chunking = 1; }
	elsif (uc($arg0) eq 'O') { $output_file_type = 'vert-extended'; }
    }
}

$INPUT_DIR = $ARGV[0];
$INPUT_DIR =~ s/(.+)\/$/$1/;

# Vstup: dva soubory
# CONLL: ord	newform	newlemma	POS	POS	features	parent	afun	xxx	xxx
my $CONLL_FILE;
# NEBO
# MCD: slova oddělená tabulátory, tagy oddělené tabulátory, synt. funkce oddělené tabulátory, "heads" oddělené tabulátory.
my $MCD_FILE;
# VERTBACKUP: newform	newlemma	form	lemma	tag
my $VERTB_FILE;

# Výstup: vertikála: form	lemma	tag	afun	ord	parent
my $VERT_OUT_FILE;
# LZE NASTAVIT I JINAK!

my (@newforms,@newlemmas,@afuns,@parents);
my (@sent_parents,@sent_ids,@sent_afuns);
my (@frs,@lms,@tgs,@afs,@pars);

my $dirDH;

opendir($dirDH, $INPUT_DIR) or die "Error opening directory $INPUT_DIR !\n";
my $INPUT_FILE;
foreach $INPUT_FILE (sort(readdir($dirDH))) {
    next if ($INPUT_FILE =~ /^\.{1,2}$/);
    next if (($input_file_type eq 'conll') && ($INPUT_FILE !~ /.+\.out\.conll$/));
    next if (($input_file_type eq 'mcd') && ($INPUT_FILE !~ /.+\.out\.mcd$/));

    if ($input_file_type eq 'conll') {
	$CONLL_FILE = $INPUT_DIR . '/' . $INPUT_FILE;
	$VERTB_FILE = substr($CONLL_FILE,0,length($CONLL_FILE)-10) . '.vertbackup';
	$VERT_OUT_FILE = substr($CONLL_FILE,0,length($CONLL_FILE)-6) . '.vert';
	if (not (-e $VERTB_FILE)) {
	$VERTB_FILE = substr($CONLL_FILE,0,length($CONLL_FILE)-6) . '.vertbackup'; }
	if (not ((-e $CONLL_FILE) && (-e $VERTB_FILE))) {
	    print "One of the files does not exist: conll:\"$CONLL_FILE\" \tvertb\"$VERTB_FILE\"\n"; }
	if ($output_file_type eq 'vert-extended') {
	    $VERT_OUT_FILE .= '-extended'; }
    }
    elsif  ($input_file_type eq 'mcd') {
	$MCD_FILE = $INPUT_DIR . '/' . $INPUT_FILE;
	$VERTB_FILE = substr($MCD_FILE,0,length($MCD_FILE)-8) . '.vertbackup';
	$VERT_OUT_FILE = substr($MCD_FILE,0,length($MCD_FILE)-4) . '.vert';
	if ($output_file_type eq 'vert-extended') {
	    $VERT_OUT_FILE .= '-extended'; }
	if (not (-e $VERTB_FILE)) {
	$VERTB_FILE = substr($MCD_FILE,0,length($MCD_FILE)-4) . '.vertbackup'; }
	if (not ((-e $MCD_FILE) && (-e $VERTB_FILE))) {
	    print "One of the files does not exist: mcd:\"$MCD_FILE\" \tvertb\"$VERTB_FILE\"\n"; }

    }

    next unless ((($input_file_type eq 'conll')&&(-e $CONLL_FILE) && (-e $VERTB_FILE))||
    (($input_file_type eq 'mcd')&&(-e $MCD_FILE) && (-e $VERTB_FILE)));

    @newforms=(); @newlemmas=(); @afuns=(); @parents=();
    @sent_parents=(0); @sent_ids=(0); @sent_afuns=('');


    if ($input_file_type eq 'conll') {
	open my $CONLL, '<:utf8', $CONLL_FILE or die;

	while (<$CONLL>) {
	    chomp;
	    my $process_line = $_;
	    if ($process_line ne '') {
		my (@atts) = split /\t/, $process_line;
		push (@newforms, $atts[1]);
		push (@newlemmas, $atts[2]);
		push (@parents, $atts[6]);
		my $af = $atts[7];
		if (($af =~ /^Pred_.+/) && ($af !~ /^Pred_(Ap)|(Co)$/)&& (($recover_changed_afuns{'V'}||0)==1)) {
		    $af =~ s/^Pred_//;
		}
		push (@afuns, $af);
		push (@sent_parents,$atts[6]);
		push (@sent_afuns,$atts[7]);
		push (@sent_ids,$#afuns);
	    }
	    else {
		push (@newforms, '');
		push (@newlemmas, '');
		push (@parents, '');
		push (@afuns, '');

		if (($recover_changed_afuns{'U'}||0)) {
		    recover_co_ap_suffixes() ; }
	        @sent_parents=(0); @sent_ids=(0); @sent_afuns=('');
	    }
	}
	close $CONLL;
    }
    elsif ($input_file_type eq 'mcd') {
	open my $MCD, '<:utf8', $MCD_FILE or die;
	while (<$MCD>) {
	    chomp;
	    my $process_line = $_;
	    my $lineno = $.;
	    $lineno = $lineno % 5;
	    if ($lineno == 0) {
		if ($process_line ne '') {
		    die "Wrong format of data, $MCD_FILE, line $.\n"; }
		push (@newforms, '');
		push (@newlemmas, '');
		push (@parents, '');
		push (@afuns, '');
		if ($recover_changed_afuns{'U'}) {
		    recover_co_ap_suffixes() ; }
	        @sent_parents=(0); @sent_ids=(0); @sent_afuns=('');
	    }
	    elsif ($lineno == 1) {
		if ($process_line eq '') {
		    die "Wrong format of data, $MCD_FILE, line $.\n"; }
		my (@atts) = split /\t/, $process_line;
		push (@newforms, @atts);
		push (@newlemmas, @atts); # MCD formát nemá samostatně lemmata!
	    }
	    elsif ($lineno == 3) {
		if ($process_line eq '') {
		    die "Wrong format of data, $MCD_FILE, line $.\n"; }
		my (@atts) = split /\t/, $process_line;
		if ($recover_changed_afuns{'V'}) {
		    foreach my $a0 (0 .. $#atts) {
			my $af = $atts[$a0];
			if (($af =~ /^Pred_.+/) && ($af !~ /^Pred_(Ap)|(Co)$/)) {
			    $af =~ s/^Pred_//;
			    $atts[$a0] = $af;
			}
		    }
		}
		push (@sent_afuns, @atts);
		push (@afuns, @atts);
	    }
	    elsif ($lineno == 4) {
		if ($process_line eq '') {
		    die "Wrong format of data, $MCD_FILE, line $.\n"; }
		my (@atts) = split /\t/, $process_line;
		push (@parents, @atts);
		push (@sent_parents, @atts);
		my $ix = $#afuns-$#atts; my $iy = $#afuns;
		push (@sent_ids, ($ix .. $iy));
	    }
	}
	close $MCD;
    }
    open my $VERTB, '<:utf8', $VERTB_FILE or die;
    open my $OUTVERT, '>:utf8', $VERT_OUT_FILE or die;
    my $sh_ord = 0;
    my $ord = 0;
    my (%removed, @oldforms, @oldlemmas, @oldtags, %chunking, @corr_ords,@shifted_ords,@addit);
    @shifted_ords = (0); @addit = ('-');
    while (<$VERTB>) {
	chomp;
	my $process_line = $_;
	if ($process_line ne '') {
	    $ord++;
#	    print "LINE $.: \"$process_line\"\n";
	    my (@atts) = split /\t/, $process_line;
#	    foreach my $ax (0 .. $#atts) {
#		print "\tAT $ax:\"$atts[$ax]\""; }
#	    print "\n";
	    if ($atts[0] ne '"REMOVED"') {
		$sh_ord++;
		if (($recover_chunking)&&(defined $atts[5])&&($atts[5] ne '')&&
		($atts[5] ne 'CHUNKING:REG')) {
		    my ($ff,$rhr) = split /\:/, $atts[5];
		    $rhr =~ s/^\+([0-9]+)$/$1/;
		    $rhr=$ord+$rhr;
		    push (@shifted_ords,$rhr);
		}
		else { push (@shifted_ords,$ord); }
	    }
	    else {
		$removed{$ord}=1;
		if ($recover_chunking == 0) {
		    die "Option \"-K\" necessary to recover data with chunking!\n"; }
	    }
	    push(@corr_ords,$ord);
	    push(@oldforms,$atts[2]);
	    push(@oldlemmas,$atts[3]);
	    push(@oldtags,$atts[4]);
	    if ((defined $atts[5])&&($recover_chunking)&&($atts[5] !~ /^AD\:/)&&($atts[5] ne '')) {
		$chunking{$ord}=$atts[5];
		if ((defined $atts[6])&&($atts[6] =~ /^AD\:/)) {
		    my $adit = $atts[6]; $adit =~ s/^AD\:(.*)$/$1/;
		    push (@addit,$adit);
#		    print "AD+r+\t$atts[2]"; if (defined $adit) { print "\"$adit\"\n"; } else { print "UND\n"; }
		}
	    }
	    elsif ((defined $atts[6])&&($atts[6] =~ /^AD\:/)) {
		    my $adit = $atts[6]; $adit =~ s/^AD\:(.*)$/$1/;
		    push (@addit,$adit);
#		    print "AD+r-\t$atts[2]"; if (defined $adit) { print "\"$adit\"\n"; } else { print "UND\n"; }
	    }
#	    else { print "AD?\t$atts[2]"; if (defined $atts[6]) { print "\"$atts[6]\"\n"; } else { print "UND\n"; } }
	}
	else {
	    next if (not defined $oldforms[0]);
#	    print "NEW_sentence starting with $oldforms[0]\n";
	    my ($ch_af,$ch_hd);
	    @frs=('-'); @lms=('-'); @tgs=('-'); @afs=('-'); @pars=('-');

	    if ($recover_chunking) { # Kvůli chunkingu se vše provede ve dvou cyklech!
		foreach my $ii (0 .. $#oldforms) {
		    my $fr=$oldforms[$ii];
		    my $lm=$oldlemmas[$ii];
		    my $tg=$oldtags[$ii];
		    my $ord0=$corr_ords[$ii];
		    my ($af,$hd);
		    if (($recover_chunking)&&(defined $chunking{$ord0})) {
			if (($removed{$ord0}||0)==1) {
			    if ($chunking{$ord0} eq 'CHUNKING:REG') {
				if (defined $ch_af) {
				    $af=$ch_af; $hd = $ch_hd; undef $ch_af; undef $ch_hd; }
				else { die "Chyba v převodu chunking dat!\n"; }
			    }
			    else {
				my $relhd; ($af,$relhd)=split /\:/, $chunking{$ord0}; $relhd =~ s/^\+([0-9]+)$/$1/;
				$hd = $relhd+$ord0; }
			}
			elsif ($chunking{$ord0} =~ /.+\:.+/) {
			    if ($chunking{$ord0} eq 'CHUNKING:REG') {
				$af = shift(@afuns); $hd = shift(@parents);
				if ((not defined $hd) || ($hd !~ /^[0-9]+$/)) {
				    die "Chybný nebo neparalelní vstup na řádce $., soubor $VERTB_FILE, \"hd\" není numerické!\n"; }
			        $hd = $shifted_ords[$hd];
			    }
			    else {
				$ch_af = shift(@afuns); $ch_hd = shift(@parents);
				$ch_hd = $shifted_ords[$ch_hd];
				my $relhd; ($af,$relhd)=split /\:/, $chunking{$ord0}; $relhd =~ s/^\+([0-9]+)$/$1/;
				$hd = $relhd+$ord0; 
			    }
			}
			else {
			    print "Jiná chyba v převodu dat s chunkingem!\n"; 
			    print "SOUBOR : $INPUT_FILE řádek $.\n";
			    foreach my $ix (1 .. $#oldforms) {
				print "\t$oldforms[$ix]"; }
			    if (defined $chunking{$ord}) { print "\tCHUNK:$ord:$chunking{$ord}\n"; }
			    else { print "\tCHUNK:UNDEF\n"; }
			}
		    }
		    else {
			$af = shift(@afuns); $hd = shift(@parents);
			if ((not defined $hd) || ($hd !~ /^[0-9]+$/)) {
				die "Chybný nebo neparalelní vstup na řádce $., soubor $VERTB_FILE, \"hd\" není numerické (2)!\n"; }

		        $hd = $shifted_ords[$hd];
		    }
		    if ((not defined $fr)||(not defined $af)||(not defined $hd)) {
			die "Data pravděpodobně nejsou paralelní: soubor $VERTB_FILE, řádka $.!\n"; }
		    push (@frs,$fr); push (@lms,$lm); push (@tgs,$tg); push (@afs,$af); push (@pars,$hd);
#		    print "$fr\t$lm\t$tg\t$af\n";
		}
	    }
	    else {
		foreach my $ii (0 .. $#oldforms) {
		    push (@frs,$oldforms[$ii]);
		    push (@lms,$oldlemmas[$ii]);
		    push (@tgs,$oldtags[$ii]);
		    my $af = shift(@afuns); push (@afs,$af);
		    my $hd = shift(@parents); push (@pars,$hd);
		}
	    }
	    
	    # debUG
#	    foreach my $zz (0 .. $#oldforms) {
#		print "DEBUG";
#		print "\t$oldforms[$zz]"; if (defined $afs[$zz+1]) { print "/$afs[$zz+1]"; } else { print "/UnD"; }
#		print "\n";
#	    }
	    foreach my $j (1 .. $#frs) {
		# Zásahy (rule-based) do struktury / synt. značek
		if (($afs[$j] eq 'Adv')&&($pars[$j]>0)&&($lms[$pars[$j]] eq 'být')) {
		    $afs[$j]=recover_byt_obj($j,$pars[$j],$afs[$j]); }
		elsif (($afs[$j] eq 'Adv_Co')&&($pars[$j]>0)&&($afs[$pars[$j]] eq 'Coord')&&
		($pars[$pars[$j]]>0)&&($lms[$pars[$pars[$j]]] eq 'být')) {
		    $afs[$j]=recover_byt_obj($j,$pars[$pars[$j]],$afs[$j]); }
		
		# Improvizovaná oprava funkce slovesa v určitém tvaru závislého na kořeni: má být vždy Pred
		if (($tgs[$j] =~ /^V[Bpi]/)&&($afs[$j] !~ /^Pred/)&&($afs[$j] ne 'AuxV')&&
		(($pars[$j]==0)||
		(($afs[$pars[$j]]=~/^(Coord)|(Apos)$/)&&($pars[$pars[$j]]==0)))) {
		
		}
		if ($output_file_type eq 'vert') {
		    printf $OUTVERT "%s\t%s\t%s\t%s\t%d\t%d\n", $frs[$j], $lms[$j], $tgs[$j], $afs[$j], $j, $pars[$j]; }
		elsif ($output_file_type eq 'vert-extended') {
		    my $parent = $pars[$j];
		    my $eparent = $pars[$j];
		    my $prep = ''; my ($co_ep, $coep_tg, $coep_af, $coep_lm)=('','','','');
		    if (($tgs[$parent] =~ /^R...[1234567]/)&&($afs[$parent] eq 'AuxP')&&($tgs[$j] =~ /^[NAPCD]/)) {
			$prep = $lms[$parent]; }
		    if (($eparent > 0)&&
		    ((($afs[$eparent] =~ /^Coord/)&&($afs[$j] =~ /Co$/))||
		    (($afs[$eparent] =~ /^Apos/)&&($afs[$j] =~ /Ap$/))||
		    ($afs[$eparent] =~ /^AuxC/)||($afs[$eparent] eq 'AuxP'))) {
			$eparent = $pars[$eparent];
			while (($eparent > 0)&&($afs[$eparent] =~ /^((AuxP)|(AuxC)|(Coord)|(Apos))/)) {
			    if (($prep eq '')&&($tgs[$eparent] =~ /^R...[1234567]/)&&($afs[$eparent] eq 'AuxP')&&($tgs[$j] =~ /^[NAPCD]/)) {
				$prep = $lms[$eparent]; }
			    $eparent = $pars[$eparent];
			}
		    }
		    elsif (($eparent > 0)&&
		    ((($afs[$eparent] =~ /^Coord/)&&($afs[$j] !~ /Co$/))||
		    (($afs[$eparent] =~ /^Apos/)&&($afs[$j] !~ /Ap$/)))&&
		    ($tgs[$j] =~ /^[NAPCVD]/)) {
			foreach my $t (1 .. $#frs) {
			    next if ($t == $j);
			    if (($pars[$t] == $eparent)&&($tgs[$t] =~ /^[NAPCVD]/)&&
			    ((($afs[$t] =~ /.+Co$/)&&($afs[$eparent] =~ /^Coord/))||
			    (($afs[$t] =~ /.+Ap$/)&&($afs[$eparent] =~ /^Apos/)))) {
				if ((not defined $co_ep)||($co_ep eq '')) { $co_ep = sprintf("%+d", $t-$j); }
				else { $co_ep .= '|' . sprintf("%+d", $t-$j); }
				if ($coep_af eq '') { $coep_af = $afs[$t]; }
				elsif ($coep_af ne $afs[$t]) { $coep_af .= '|' . $afs[$t]; }
				if ($coep_tg eq '') { $coep_tg = $tgs[$t]; }
				elsif ($coep_tg ne $tgs[$t]) { $coep_tg .= '|' . $tgs[$t]; }
				if ($coep_lm eq '') { $coep_lm = $lms[$t]; }
				elsif ($coep_lm ne $lms[$t]) { $coep_lm .= '|' . $lms[$t]; }
			    }
			}
		    }
		    if (not defined $afs[$eparent]) {
			print "Chyba v souboru $INPUT_FILE, řádek $. - undef afun\n";
			print "X:$j\tPARENT:$parent\tEPARENT:$eparent\n";
			foreach my $zz (1 .. $#frs) {
			    print "\t$zz:\"$frs[$zz]\""; if (defined $afs[$zz]) { print "/$afs[$zz]"; } else { print "/UnD"; } }
			print "\n"; die;
		    }
		    if (($eparent > 0)&&($afs[$eparent] =~ /^((AuxP)|(AuxC)|(Coord)|(Apos))/)) {
		        $eparent = 0; }
		    my ($p, $pt, $pl, $pa, $ep, $et, $el, $ea) = (0,'','','',0,'','','');
		    if ($parent > 0) {
		        $p = sprintf("%+d",$parent - $j); $pt = $tgs[$parent]; $pl = $lms[$parent]; $pa = $afs[$parent]; }
		    if (($eparent > 0)&&($tgs[$j] =~ /^[NAPCVD]/)) {
		        $ep = sprintf("%+d",$eparent - $j); $et = $tgs[$eparent]; $el = $lms[$eparent]; $ea = $afs[$eparent]; }
		    if ((defined $co_ep) && ($co_ep ne '') && ($tgs[$j] =~ /^[NAPCVD]/)) {
			$ep = $co_ep; $et = $coep_tg; $el = $coep_lm; $ea = $coep_af; }
		    if ($tgs[$j] !~ /^[NAPCVD]/) { $ep = ''};
		    my $ad = ''; if (defined $addit[$j]) { $ad = $addit[$j]; } #else { die "AD undef! $frs[$j]\n"; }
		    printf $OUTVERT "%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\n", $frs[$j], $lms[$j], $tgs[$j], $ad, $afs[$j], $p, $ep, $prep, $pt, $pl, $pa, $et, $el, $ea; 
		}
	    }
	    print $OUTVERT "\n";
	    %removed=(); @oldforms=(); @oldlemmas=(); @oldtags=(); %chunking=(); @corr_ords=(); @shifted_ords=( 0 ); @addit = ('-');
	    $ord=0; $sh_ord=0;
	    shift(@afuns); shift(@parents); shift(@newforms); shift(@newlemmas);
	}
    }
    close $VERTB;
    print "*";
}
print "\n";

sub recover_co_ap_suffixes {
#    print "SUB recover engaged\n";
    foreach my $y (1 .. $#sent_afuns) {
	if ($sent_afuns[$y] =~ /_CA$/) {
	    my $new_sfx = 'Co';
	    my $no_coap_parent = 1;
	    my $ap = $sent_parents[$y];
	    while ((defined $sent_afuns[$ap])&&($sent_afuns[$ap] !~ /^(Coord)|(Apos)/)&&
	    (defined $sent_parents[$ap])&&($sent_parents[$ap]>0)) {
		$ap = $sent_parents[$ap];
		if ($sent_afuns[$ap] =~ /^(Coord)|(Apos)/) {
		    $no_coap_parent = 0; }
	    }
	    if ($sent_afuns[$ap] =~ /^(Coord)|(Apos)/) {
		    $no_coap_parent = 0; }
	    if ($sent_afuns[$ap] =~ /^Apos/) {
		$new_sfx = 'Ap'; }
	    my $new_af = $sent_afuns[$y];
	    $new_af =~ s/\_CA$//;
	    if ($no_coap_parent == 0) {
		$new_af .= '_' . $new_sfx; }
	    my $s_id = $sent_ids[$y];
	    $afuns[$s_id] = $new_af;
#	    print "new_af: $new_af\n";
	}
    }
}

sub recover_byt_obj {
    my ($ob,$byt,$af)=@_;
    my $tag = $tgs[$ob];
    if ($tag !~ /^[NAP]...3/) { return $af; }
    if ($tgs[$byt] =~ /^V(..P)|(.[MIFQY])/) { return $af; }
    foreach my $x (1 .. $#frs) {
	next if ($pars[$x] != $byt);
	if (lc($frs[$x]) eq 'líto') { $af =~ s/^Adv/Obj/; } # je mi líto
	elsif (($tgs[$x] =~ /^P[QWZ]..1/)&&($afs[$x] eq 'Sb')) { $af =~ s/^Adv/Obj/; } # co mu je, nic mu není
	elsif (($tgs[$x] =~ /^NN..[14]/)&&($lms[$x] eq 'rok')&&($x>1)&&($tgs[$x-1] =~ /^Cl..[14]/)) {
	    $af =~ s/^Adv/Obj/; } # jsou mu dva roky
	elsif ($tgs[$x] =~ /^C[\=n]..[\-14X]/) {
	    my $wrong_atr = 0; my ($y0,$y1) = ($x-3,$x+3); if ($y0<1) {$y0=1;} if ($y1>$#frs) {$y1=$#frs;}
	    foreach my $y ($y0 .. $y1) {
		if (($pars[$y] eq $x) && ($tgs[$y] =~ /^N..[XP]2/) && (lc($frs[$y]) !~ /^(let)|(roků)|(jar)$/)) {
		    $wrong_atr = 1; last; } }
	    if ($wrong_atr == 0) { $af =~ s/^Adv/Obj/; } # bylo mu pět, popř. bylo mu pět let / roků
	}
    }
    return $af;
}

