# Say to emacs to use -*- cperl -*- mode.

%{
  use dpl;
  use Data::Dumper;
  use Storable;

  our $dict_processing_function = undef;
  our $meta_processing_function = undef;
  our %type_info = ('!name' => 'term','!ex' => 'string*'); # era (... ,'!ex'=>'string*');
  our %seqs = ();
%}

%token PLEX_STR PLEX_ID PLEX_BEGIN PLEX_END
%token PLEX_PERL_INIT PLEX_PERL PLEX_PERL_END
%token PLEX_DPL_INIT PLEX_DPL_END PLEX_COMPLEX_ID

%left '+'
%nonassoc '<'
%nonassoc '='
%left '|'

%%
file: file block          {  }
    | block               {  }
    ;

block: perl_block         { +{}}
     | dpl_block          { +{}}
     | meta_block         {
       $_[1] = remove_examples($_[1]);
       for (keys %{$_[1]}) {
         next if /types/;
         if (ref($_[1]->{$_}) and scalar keys %{$_[1]->{$_}} == 1) {
           if (exists($_[1]->{$_}{sem})) {
             $_[1]->{$_}=$_[1]->{$_}{sem};
           }
         }
       }
       if (defined $_[1]->{types}) {
         %type_info = (%type_info,%{$_[1]->{types}});
       }
       for (keys %type_info) {
         if ($type_info{$_} =~ /\*$/) {
           # print STDERR "#### Seqs += $_\n";
           $seqs{$_}++;
         }
       }
       if (defined $meta_processing_function) {
         &{$meta_processing_function}($_[1])
       }}
     ;

meta_block: PLEX_META_INIT meta_code PLEX_META_END  { $_[2] }
          ;

meta_code: meta_code code_line ';' { process_meta($_[1],$_[2]) }
         |                         { +{} }
         ;

perl_block: PLEX_PERL_INIT PLEX_PERL PLEX_PERL_END {
  eval $_[2];
  print STDERR "Error in perl block: ",$@ if $@;
}
  ;

dpl_block: PLEX_DPL_INIT dpl_code PLEX_DPL_END
  ;

dpl_code: dpl_code code_line ';'     {
  die ("Processing function not specified") unless (defined $dict_processing_function);
  &{$dict_processing_function}($_[2]) ;
}
  | dpl_code '>' PLEX_ID ';'   { print "Requiring $_[3]\n"; require($_[3]); }
  | error ';' dpl_code         { $_[0]->YYErrok }
  |                            { }
  ;

code_line: tfsl ':' tfs1                      {  [ (mkent($_[1],$_[3])) ] ; }
| function_call                               { $_[1]; }
| PLEX_BEGIN tfs2 ';' middle_begend PLEX_END  { tfplustfl($_[2],$_[4]);}
;

middle_begend: middle_begend code_line ';'       { [ @{$_[1]},@{$_[2]}];}
  |                                   { [];}
  ;

function_call: '+' PLEX_ID '(' sequence ')'     { no strict; &{$_[2]}(@{$_[4]}); }
  | '+' PLEX_ID                                 { no strict; &{$_[2]}; }
  ;

tfs : tfs0                     { $_[1];}
    | id                       { +{ '!name' => $_[1]} ; }
    | full_sequence            { +{ '!seq' => $_[1]} ;}
    ;

tfs0 : '{' atrib_list '}'         { $_[2]; }
     | '{' '}'                    { +{}; }
     | example                    { $_[1]; }
     | function_call              { $_[1]; }
     | tfs '<' id                 { fsjoin($_[1],{isa => $_[3]}); }
     | tfs '+' tfs                { fsjoin($_[1], $_[3]); }
     ;

example: PLEX_STR              { +{ '!ex' => tira_aspas($_[1])} ; }
       | PLEX_STR '=' id       { +{ '!ex' => {frase => tira_aspas($_[1]),
                                              equiv => $_[3]}};}
       ;

tfs1: tfs0                 { $_[1];}
    | id                   { $_[1];}
    | full_sequence        { $_[1];}
    |                      { +{};}
    ;

full_sequence: '[' sequence ']'        { $_[2];}
  ;

tfs2: tfs0                 { $_[1];}
    | id                   { $_[1];}
    | full_sequence        { $_[1];}
    ;

sequence: tfs2           { [$_[1] ] ;}
     | sequence ';' tfs2 { [ @{$_[1]},$_[3] ] ; }
     |                   { [] ; }
     ;

tfsl: tfs          {  [$_[1] ] ;}
    | tfsl '|' tfs {  [@{$_[1]},$_[3] ] ; }
    ;

atrib_list: PLEX_ID '=' tfs2                { +{$_[1] => $_[3]}; }
          | atrib_list ';' PLEX_ID '=' tfs2 { fsjoin($_[1],{$_[3] => $_[5]}); }
          ;

id: PLEX_ID              { $_[1] }
  | PLEX_COMPLEX_ID      { tira_aspas($_[1]) }
  | '(' csl ')'          { "($_[2])" }
  | id '(' csl ')'       { "$_[1] ($_[3]) " }
  | id PLEX_ID           { "$_[1] $_[2]" }
  ;

csl :              { "";}
    | id           { $_[1] ;}
    | csl '|' csl  { "$_[1]|$_[3]"; }
    ;
%%
sub setDictProcessFunction {
  $dict_processing_function = shift;
}
sub setMetaProcessFunction {
  $meta_processing_function = shift;
}


sub mkent {
  my ($idl, $tf) = @_;
  my $tf1;
  if (ref($tf) eq 'HASH') {
    $tf1 = $tf;
    if(exists($tf1->{"!name"}))  { $tf1->{"sem"} = $tf1->{"!name"}}
    elsif(exists($tf1->{"!seq"})){ $tf1->{"sem"} = $tf1->{"!seq"};
                                   delete $tf1->{"!seq"} }
  } else {
    $tf1 = +{sem => $tf};
  }
#  my $sin = mksynlist($idl) ;
  if( scalar @{$idl} > 1) {
    map { +{%{$tf1}, %{$_},  syn =>(mksynlist($idl,$_->{"!name"})) }} @{$idl}
  } else {
    fsjoin($tf1,$idl->[0])
  }
}

sub mksynlist {
  my ($terml,$n) = @_;
  [ map { ( $_->{'!name'} eq $n)? (): $_->{"!name"} } @{$terml} ]
}

sub setofele{
  my ($lista , $fs) = @_;
  die "invalid array element in $lista" unless (ref($lista) eq 'ARRAY') ;
  die "invalid hash element in $fs" unless (ref($fs) eq 'HASH') ;
  [ map { if (ref($_) eq 'HASH' ) {+{ %{$_} , %{$fs} }}
          else                    {+{'!name' => $_, %{$fs} } }} @{$lista} ]
}

sub tfplustfl {
  my ($tf,$tfl)=@_;
  [ map{ fsjoin($tf,$_) } @{$tfl}  ];
}

=head2 fsjoin - joins two or more features structures

Given n feature structures references, C<fsjoin> returns
a new one with elements in a list. If the key starts with
an underscore, the elements will be replaced.

If there is a sub-feature structure with the same key, it
will be merged as well.

    $fs = fsjoin ( $fs1, $fs2, $fs3, ..., $fsn);

=cut

sub fsjoin {
  my $res = {};

  for my $fs (@_) {
    for (keys %{$fs}) {
      if (defined($seqs{$_})) {
        if (ref($fs->{$_}) eq "HASH") {
          #$res->{$_}=+{};
          #$res->{$_} = fsjoin( {%{$res->{$_}}}, $fs->{$_});
          push @{$res->{$_}}, $fs->{$_};
        } elsif (ref($fs->{$_}) eq "ARRAY") {
          push @{$res->{$_}}, @{$fs->{$_}};
#jj        } elsif (ref($res->{$_}) eq "ARRAY") {
#jj          push @{$res->{$_}}, $fs->{$_};
        } else {
#jj             print STDERR "Erro? '$fs->{$_}/$_'/" , $res,"(",join(",",keys(%$res)) ,")$res->{'!name'}\n";
          push @{$res->{$_}}, $fs->{$_};
        }
      } else {
        $res->{$_} = $fs->{$_};
      }
    }
  }

  return $res;
}

sub tira_aspas {
  my $a = shift;
  return $1 if $a =~ m/^"(.*)"$/;
  return $1 if $a =~ m(^[/!]\{(.*)\}$)s;
  return $a;
}

sub process_meta {
  my ($data,$new) = @_;

  for (@$new) {
    my $name = $_->{'!name'};
    delete $_->{'!name'};
    if (exists $data->{$name}) {
      my $tmp = [@{$data->{$name}}, $_];
      $data->{$name} = $tmp;
    } else {
      $data->{$name} = $_;
    }
  }
  return $data;
}

sub remove_examples {
  my $ref = shift;
  my $type;
  if ($type = ref($ref)) {
    if ($type eq "ARRAY") {
      my @a = map {remove_examples($_)} @$ref;
      return \@a;
    } elsif ($type eq "HASH") {
      if (scalar keys %$ref == 1 and exists $ref->{'!ex'}) {
        return $ref->{'!ex'};
      } else {
        my $r = {};
        for (keys %$ref) {
          $r->{$_} = remove_examples($ref->{$_});
        }
        return $r;
      }
    } else {
      return $ref;
    }
  } else {
    return $ref;
  }
}