package Lingua::PT::NamedEntity::JSpellFilters;

use warnings;
use strict;
use locale;

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw();
our @EXPORT_OK = qw(%filters);
our @EXPORT_TAGS = qw(:DEFAULT => []);

our $version = "0.01";

# FIXME verificar que filtros não preservam as propriedades que não lhes dizem respeito
# (pelo menos act_on_chunk [de filter_begin])

our %filters = (begin => {filter => \&filter_begin},
		al => {filter => \&filter_al},
		empty => {filter => \&filter_empty},
		np => {filter => \&filter_np},
		context => {filter => \&filter_context,
			 setup => \&filter_context_setup},
		nav => {filter => \&filter_nav,
			cleanup => \&filter_nav_cleanup},
		oneword => {filter => \&filter_oneword},
		names_gazetteer => {filter => \&filter_names_gazetteer,
				    setup => \&filter_names_gazetteer_setup},
		toxml => {filter => \&filter_toxml},
		toents => {filter => \&filter_toents},
		);

# XXX auxiliar de &filter1
# FIXME precisa de uma reestruturação (está demasiado complexa)
sub act_on_chunk {
    my $m = "\x01";

    my $jspell = shift;
    my $debug = shift;
    my $chunk = shift;

    my $text = $chunk->{text};

    # marca os 'boundaries' do whitespace
    $text =~ s/(\s+)/$m$1$m/sg;
    if (not $text =~ /^$m/) {
	$text = "$m$text";
    }
    if (not $text =~ /$m$/) {
	$text = "$text$m";
    }

    my ($inicio, $entidade) = ("", "");

    while ($text =~ /$m(.*?)$m/gs) {
	pos($text) = pos($text) - 1;
	if ($entidade) {
	    $entidade .= $1;
	    next;
	}

	my $match = $1;

	if ($match =~ /\s+/sg) {
	    $inicio .= $match;
	    next;
	}

	# encontra as categorias possíveis para a palavra
	my @fea = $jspell->fea($match);
	my %cats;
	for my $d (@fea) {
	    if (defined $d->{CAT}) {
		$cats{$d->{CAT}} = 1;
	    }
	}
	# se o jspell desconhece completamente o termo, este interessa-nos e é considerado um nome de entidade
	$cats{INTERESSANTE} = 1 if not scalar(@fea);
	# eliminar as categorias que não são interessantes
	my @delete_cats = qw/v adv cp con prep art card pind ppes prel nord pass pdem pint in/;
	map {delete $cats{$_}} @delete_cats;

	if (scalar(%cats)) {
	    # se encontrarmos uma categoria interessante
	    $entidade = $match;
	} else {
	    $inicio .= $match;
	}
    }

    # return
    my @ret;
    if ($inicio) {
	push @ret, {type=>"raw", text=>$inicio, defined $debug ? (debug=>$debug) : ()};
	if ($entidade) {
	    my $entchunk = {type=>"entity", text=>$entidade,
			    $chunk->{beginning} ? (beginning=> 1) : ()};
	    push @ret, $entchunk;
	}
    } else {
	push @ret, $chunk;
    }
    # preservar propriedade part ... FIXME preservar _todas_ (keys %{$chunk})
    if (defined $chunk->{part}) {
	for my $c (@ret) {
	    $c->{part} = $chunk->{part};
	}
    }
    @ret;
}

sub filter_begin {
    my %options = (debug => undef, @_);

    [map {($_->{type} ne "entity" or not defined $_->{beginning})?
	      $_ :
	      act_on_chunk($options{jspell}, $options{debug}, $_)}
     @{$options{chunks}}];
}

# elimina elementos "raw" vazios
sub filter_empty {
    my %options = @_;

    my $chunks = $options{chunks};

    my @ret;
    my $prev;

    for my $c (@{$chunks}) {
	if ($c->{type} eq "raw" and $c->{text} eq "") {
	    next;
	}

	$prev = $c;
	push @ret, $c;
    }

    \@ret
}

# classifica nomes pessoais com base na classificação do JSpell ao primeiro e (opcionalmente) ultimo nome
sub filter_np {
    my %options = @_;

    my $chunks = $options{chunks};
    my $jspell = $options{jspell};

    my @ret;

    for my $c (@{$chunks}) {
	if ($c->{type} eq "entity") {
	    my @words;
	    if ($options{ultimo}) {
		$c->{text} =~ /^(?:([\w-]+)?.*?\s+)?([\w-]+)$/s;
		push @words, $1 if defined $1;
		#die "Huh? ($c->{text})" if not defined $2;
		push @words, $2 if defined $2;
	    } else {
		$c->{text} =~ /^(\w+)/;
		die "Huh?" if not defined $1;
		push @words, $1;
	    }
	    
	    for my $word (@words) {
		my @fea = $jspell->fea($word);
		@fea = grep {$_->{CAT} eq "np" and defined $_->{SEM} and
				 ($_->{SEM} eq "p" or $_->{SEM} eq "p1")} @fea;

		if (@fea) {
		    $c->{np} = $fea[0]->{SEM};
		    last; # não testamos a outra palavra
		}
	    }

	}
	push @ret, $c;
    }

    \@ret
}

# Combinações entre elementos de um número arbitrário de listas
# ([1,2,3], [4,5,6], [7,8]) --> ([1,4,7], [1,4,8], [1,5,7], ..., [3,6,8])
sub arraycombo {
    return () if not @_;
    my @combos;
    for my $i (@{shift @_}) {
	push @combos, [$i, @{$_}] foreach (@_ ? arraycombo(@_) : ([]));
    }
    return @combos;
}

sub filter_context_setup {
    my %options = @_;

    my $from = $options{from};
    die "Specify file with left context mappings (option 'from').\n" if not defined $from;
    
    my $conf = do $options{from};
    die "Unable to parse context table: $@" if $@;
    die "Unable to read context table: $!" unless defined $conf;
    die "Unable to set context table" unless $conf;

    my %context = ();

    for my $entry (@{$conf}) {
	my ($left, $meaning) = @{$entry};
	my @lists = map {$_->{choice}} @$left;
	my @keys = map {join " ", @{$_}} arraycombo(@lists);
	for my $key (@keys) {
	    warn "context: entrada '$key' repetida na tabela de contextos.\n" if exists $context{lc $key};
	    $context{lc $key} = $meaning;
	}
    }
    
    $options{global}->{_context} = \%context;
}

# FIXME separar a funcionalidade em duas funções
# (uma para contextos esquerdos, outra para primeiras palavras)
sub filter_context {
    my %options = @_;
    my $context = $options{global}->{_context};
    my $chunks = $options{chunks};

    my @ret;
    my $prev;
    
    for my $c (@{$chunks}) {
	if ($c->{type} eq "entity") {
	    # Testar contexto esquerdo
	    my ($key, $registo, $prevtext, $word1, $sep1, $word2, $sep2, $resto);
	    if ($prev and $prev->{text} =~ /^(.*?)([\w-]+)(\s+)([\w-]+)(\s+)$/s) {
		# Existe contexto esquerdo
		$prevtext = $1;
		$word1 = $2;
		$sep1 = $3;
		$word2 = $4;
		$sep2 = $5;

		# Procurar entrada no %context, primeiro com ambas as palavras depois pela segunda
		$key = lc "$word1 $word2";
		$registo = $context->{$key};
		$key = lc "$word2" if not defined $registo;
		$registo = $context->{$key} if not defined $registo;
		if (defined $registo) {
		    # Existe entrada no %context para o contexto
		    my $is = $registo->{is} eq '$_' ?  $key : $registo->{is};
		    push @{$c->{class}}, {is => $is, confidence => $registo->{confidence},
					  from => "context"};
		    if ($registo->{gobble}) {
			# A entrada é gobble, isto é, o texto do contexto passa a fazer parte do texto
			# da entidade
			$prev->{text} = $prevtext;
			foreach ($sep1, $word2, $sep2) {
			    $_ = "" if not defined $_;
			}
			if ($key eq lc $word2) {
			    $c->{text} = "$word2$sep2$c->{text}";
			    $prev->{text} .= "$word1$sep1";
			} else {
			    $c->{text} = "$word1$sep1$word2$sep2$c->{text}";
			}

			# Não vamos testar as primeiras palavras do texto da entidade se estas lá foram
			# parar a partir do contexto esquerdo
			if (defined $registo and $registo->{gobble}) {
			    # Acrescentamos texto anterior e entidade actual à lista de contextos
			    push @ret, ($prev, $c);
			    undef $prev; # FIXME repetição em baixo, analisar fluxo...
			    next;
			}


		    }
		}
	    }

	    # Testar primeiras palavras do texto da entidade
	    $c->{text} =~ /^(\S+)(?:(\s+)(\S+)(\s+)?(.*))?/s;
	    ($word1, $sep1, $word2, $sep2, $resto) = ($1, $2, $3, $4, $5);
	    die "Huh? ($c->{text})" if not defined $1;
	    # Procurar entrada no %context
	    undef $registo;
	    if (defined $word2 and $resto) {
		# Tentar encontrar registo pelas duas primeiras palavras (se houver mais)
		$key = lc "$word1 $word2";
		$registo = $context->{$key};
	    }
	    if (not defined $registo and ($word2 or $resto)) {
		# FIXME or supérfluo (basta $word2)
		# Tentar encontrar registo pela primeira palavra (se não for a única)
		$key = lc $word1;
		$registo = $context->{$key};
	    }
	    if (defined $registo and not $registo->{noentname}) {
		# Temos um registo para as primeiras palavras da entidade
		my $is = $registo->{is} eq '$_' ? $key : $registo->{is};
		# Classificar de acordo com entrada no %context
		push @{$c->{class}}, {is => $is, confidence => $registo->{confidence},
				      from => "context"};
		if (not $registo->{gobble}) {
		    # A parte inicial do texto da entidade vai ser retirada (acrescentada ao bloco de
		    # texto anterior ou a um novo bloco)
		    # FIXME preservar mais campos ?????????????????????????????????????????????
		    if (not $prev) {
			$prev = {type => "raw", text => "", part => $c->{part}};
		    }
		    my $delete;
		    if (defined $word2 and $key =~ / $word2$/) {
			$c->{text} =~ m!^(\S+(?:\s+\S+\s*)?)!s;
			$delete = $1;
			$c->{text} =~ s!^$delete!!;
		    } else {
			$c->{text} =~ m!^(\S+\s+)!s;
			$delete = $1;
			$c->{text} =~ s!^$delete!!;
		    }
		    $prev->{text} .= $delete;

		    # Se ainda temos texto na entidade então podemos voltar a classificá-lo
		    if ($c->{text} ne "") {
			my $t = $c;
			unshift @{$chunks}, $t;
		    } else {
			die "No text for entity!";
		    }
		}
	    }
	    
	    push @ret, $prev if $prev;
	    push @ret, $c if $c and $c->{text} ne ""
		and (not defined $registo or $registo->{noentname} or $registo->{gobble});

	    # Saímos de uma entidade, este texto não pode ser usado para análise de contexto esquerdo.
	    undef $prev;
	} else {
	    push @ret, $prev if $prev;
	    $prev = $c;
	}
    }
    
    push @ret, $prev if $prev;

    \@ret
}

sub filter_al {
    my %options = @_;

    my $chunks = $options{chunks};
    my $debug = $options{debug};

    my $prev_ent;
    my $prev_text_c;
    my $prev_text;
    my $prev_text_ws;
    my $prev_text_al;

    my @ret;

    for my $c (@{$chunks}) {
	if ($c->{type} eq "entity" and $prev_text_c) {
	    if ($prev_text) {
		push @ret, $prev_ent if $prev_ent;
		undef $prev_ent;
		$prev_text_c->{text} = $prev_text . $prev_text_ws;
		push @ret, $prev_text_c;
	    }
	    if ($prev_ent) {
		$prev_ent->{text} .= "$prev_text_ws$prev_text_al$c->{text}";
		$prev_ent->{debug} = $debug if defined $debug;
	    } else {
		$c->{text} = "$prev_text_al$c->{text}";
		$c->{debug} = $debug if defined $debug;
		$prev_ent = $c;
	    }
	    undef $prev_text_c;
	} elsif ($c->{type} eq "raw"
		 and $c->{text} =~ m/(.*?)(\s+)((?:al-)|(?:al\s+))$/s) {
	    $prev_text = $1;
	    $prev_text_ws = $2;
	    $prev_text_al = $3;
	    $prev_text_c = $c;
	} elsif ($c->{type} eq "entity") {
	    push @ret, $prev_ent if $prev_ent;
	    $prev_ent = $c;
	    push @ret, $prev_text_c if $prev_text_c;
	    undef $prev_text_c;
	} else {
	    push @ret, $prev_ent if $prev_ent;
	    push @ret, $prev_text_c if $prev_text_c;
	    undef $prev_ent;
	    undef $prev_text_c;
	    push @ret, $c;
	}
    }

    push @ret, $prev_ent if $prev_ent;
    push @ret, $prev_text_c if $prev_text_c;

    \@ret
}

sub filter_nav {
    my %options = @_;

    my $chunks = $options{chunks};
    
    my $prev;
    my @ret;
    my $c;
    
    for $c (@$chunks) {
	$prev->{next} = $c if defined $prev;
	$c->{prev} = $prev;
	$prev = $c;
	push @ret, $c;
    }
    
    $c->{next} = undef if defined $c;

    \@ret
}

sub filter_nav_cleanup {
    my %options = @_;

    my $chunks = $options{chunks};

    for my $c (@{$chunks}) {
	delete $c->{prev};
	delete $c->{next};
    }
}


my %XML = ("ARRAY" => \&ARRAY2XML,
	   "HASH" => \&HASH2XML);

sub filter_toxml {
    my %options = (
		   header => 1,
		   style => "doc.css",
		   root => "text",
		   part => "part",
		   entity => "entity",

		   hash => "hash",
		   array => "array",
		   mapping => "mapping",
		   item => "item",
		   
		   @_
		   );

    my $chunks = $options{chunks};

    my $at_part = 0;

    if ($options{header}) {
	print qq!<?xml version="1.0" encoding="ISO-8859-1"?>\n!;
	print qq!<?xml-stylesheet type="text/css" href="$options{style}"?>\n!
	    if $options{style};
    }
    print "<$options{root}>\n" if $options{root};

    for my $c (@{$chunks}) {
	if ($c->{part} != $at_part) {
	    print "\n</$options{part}>\n" if $options{part} and $at_part > 0;
	    print "<$options{part}>\n" if $options{part};
	    $at_part = $c->{part};
	}
	my $part = delete $c->{part};
	chunk2XML(\%options, $c);
	$c->{part} = $part;
    }
    print "\n</$options{part}>\n" if $options{part} and @{$chunks} > 0;
    print "</$options{root}>" if $options{root};

    # return
    $chunks
}

sub HASH2XML {
    my ($self, $h) = @_;

    my $ret = "";

    $ret .= "<$self->{hash}>";
    for my $k (keys %{$h}) {
	$ret .= "<$self->{mapping} key=\"$k\"";
	my $value = $h->{$k};
	if (not ref($value)) {
	    $ret .= " value=\"$value\" />";
	} else {
	    $ret .= ">".$XML{ref($value)}->($self, $value)."</$self->{mapping}>";
	}
    }
    $ret .= "</$self->{hash}>";

    $ret
}

sub ARRAY2XML {
    my ($self, $a) = @_;
    
    my $ret = "<$self->{array}>";
    for my $e (@{$a}) {
	$ret .= "<$self->{item}";
	if (not ref($e)) {
	    $ret .= " value=\"$e\" />";
	} else {
	    $ret .= ">".$XML{ref($e)}->($self, $e)."</$self->{item}>";
	}

    }
    $ret .= "</$self->{array}>";
    
    $ret
}

sub chunk2XML {
    my $self = shift;
    my $chunk = shift;

    my %c = %{$chunk};

    my $type = delete $c{type};
    my $text = delete $c{text};

    if (scalar(keys %c) == 0) {
	print "<$type>$text</$type>";
    } else {
	print "<$type";
	for my $key (keys %c) {
	    if (not ref($c{$key})) {
		my $value = delete $c{$key} ;
		print qq! $key="$value"!;
	    }
	}
	print ">$text";
	for my $key (keys %c) {
	    my $value = delete $c{$key};
	    print $XML{ref($value)}->($self, $value);
	}
	print "</$type>";
    }
}

sub filter_toents {
    my %options = @_;

    my $chunks = $options{chunks};
    for my $c (@{$chunks}) {
	if ($c->{type} eq "entity") {
	    my $s = $c->{text};
	    $s =~ s/\s+/ /sg;
	    print "$s\n";
	    foreach (@{$c->{class}}) {
		print "\tis $_->{is}";
		print "/$_->{confidence}" if defined $_->{confidence};
		print " ($_->{from})" if defined $_->{from};
		print "\n";
	    }
	}
    }
}

sub filter_oneword {
    my %options = @_;

    my @ents = grep {$_->{type} eq "entity"} @{$options{chunks}};
    my %entdata;
    my %beginnings;
    my %endings;
    for my $ent (@ents) {
	$entdata{$ent->{text}}->{count}++;
	$entdata{$ent->{text}}->{class} = [] if not defined $entdata{$ent->{text}}->{class};
	push @{$entdata{$ent->{text}}->{class}}, @{$ent->{class}} if defined $ent->{class};

	if ($ent->{text} =~ /^(\S+)\s+.*\s+(\S+)$/s) {
	    $beginnings{$1} = 1;
	    $endings{$2} = 1;
	}
    }

    # Elimina entidades com uma só palavra que não tenha sido classificada em nenhuma
    # ocorrência, que não seja a primeira ou última palavra de outra entidade com
    # mais do que uma palavra e que, se for conhecido pelo jspell, não esteja classificado
    # como nome próprio.
    for my $ent (@ents) {
	if ($ent->{text} =~ /^([\w\-\']+)$/s) {
	    next if exists $beginnings{$1} or exists $endings{$1};
	    next if uc $1 eq $1 or @{$entdata{$ent->{text}}->{class}} != 0;
	    my @fea = $options{jspell}->fea($1);
	    next if @fea == 0;
	    @fea = grep {$_->{CAT} eq "np"} @fea;
	    if (@fea == 0 and $ent->{beginning}) {
		# FIXME preservar mais propriedades
		my $s = $ent->{text}; my $p = $ent->{part};
		delete @$ent{keys %{$ent}};
		$ent->{type} = "raw";
		$ent->{text} = $s;
		$ent->{part} = $p;
	    }
	    $ent->{debug} = $options{debug} if $options{debug} and @fea == 0;
	}
    }
    
    $options{chunks};
}

sub filter_names_gazetteer_setup {
    my %options = @_;

    local $/ = "\n"; # FIXME pq é que isto é necessário ????? (o local no rem.pl afecta isto ?)
    my $f;
    open $f, "<", $options{from} or die "Unable to open names gazetteer source ($options{from}).\n";

    my %names = ();
    while (my $line = <$f>) { # FIXME se usar $_ aqui afecto um map cujo bloco chama isto ???????????
	                      # ver JSpellFilter.pm (BUG1)
	if ($line =~ /^(\S+)\s+:(.*?):/) {
	    die "Repeated name in $options{from}: $1.\n" if exists $names{$1};
	    $names{$1} = $2;
	} else {
	    die "Huh?";
	}
    }

    close $f;

    $options{global}->{_names_gazetteer} = \%names;
}

sub filter_names_gazetteer {
    my %options = @_;

    my $names = $options{global}->{_names_gazetteer} or die "Huh?";
    my $chunks = $options{chunks};

    for my $c (@{$chunks}) {
	if ($c->{type} eq "entity") {
	    my $confidence = 0;
	    my @part = grep /^[[:upper:]]/, split(' ', $c->{text});
	    my $namecount = 0;
	    foreach (@part) {
		$namecount++ if exists $names->{$_};
	    }
	    if ($namecount > 0) {
		# bónus se houver mais do que uma parte no nome e a primeira não fôr exclusivamente apelido
		if (@part > 1 and exists $names->{$part[0]} and $names->{$part[0]} ne "apelido") {
		    $namecount++ if $namecount < @part;
		}
		$confidence = $namecount / @part * 100;
		$confidence *= .5 if @part == 1;
		$confidence *= .75 if @part == 2;
		$c->{class} = [] if not exists $c->{class};
		push @{$c->{class}},  {is => "pessoa", confidence => $confidence, from =>"name_gazetteer"};
	    }
	}
    }

    $chunks
}

1;

__END__