File Coverage

blib/lib/Treex/PML/Backend/CSTS/Fs2csts.pm

Criterion	Covered	Total	%
statement	13	267	4.8
branch	0	198	0.0
condition	0	90	0.0
subroutine	5	12	41.6
pod	0	7	0.0
total	18	574	3.1

package Treex::PML::Backend::CSTS::Fs2csts;

use vars qw($VERSION);
BEGIN {
  $VERSION='2.24'; # version template
}

use Treex::PML;
no warnings;

our $export_dependency=1;
our $compatibility_mode=0;
our $preserve_err1=0;

our $gov = undef;

our @extra_attributes=();

our %TRt = (
        gender_ANIM => 'M',
        gender_INAN => 'I',
        gender_FEM => 'F',
        gender_NEUT => 'N',
        gender_NA => '-',
        number_SG => 'S',
        number_PL => 'P',
        number_NA => '-',
        degcmp_POS => '1',
        degcmp_COMP => '2',
        degcmp_SUP => '3',
        degcmp_NA => '-',
        tense_SIM => 'S',
        tense_POST => 'P',
        tense_ANT => 'A',
        tense_NA => '-',
        aspect_PROC => 'P',
        aspect_CPL => 'C',
        aspect_RES => 'R',
        aspect_NA => '-',
        iterativeness_IT1 => '1',
        iterativeness_IT0 => '0',
        iterativeness_NA => '-',
        verbmod_IND => 'I',
        verbmod_IMP => 'M',
        verbmod_CDN => 'C',
        verbmod_NA => '-',
        deontmod_DECL => 'D',
        deontmod_DEB => 'B',
        deontmod_HRT => 'H',
        deontmod_VOL => 'V',
        deontmod_POSS => 'S',
        deontmod_PERM => 'P',
        deontmod_FAC => 'F',
        deontmod_NA => '-',
        sentmod_ENUNC => '.',
        sentmod_EXCL => '!',
        sentmod_DESID => 'D',
        sentmod_IMPER => 'M',
        sentmod_INTER => '?',
        sentmod_NA => '-',
       );

sub setupSpec {
  $gov = $_[0];
}

sub make_TRt {
  my ($node,$machine)=@_;
  my $result="";
  foreach (qw(gender degcmp number tense aspect iterativeness verbmod deontmod sentmod)) {
    if (exists($TRt{$_."_".$node->{$_}})) {
       $result.=$TRt{$_."_".$node->{$_}};
     } else {
       $result.="X";
     }
  }
  return $result;
}

sub make_gap {
  my ($gap)=@_;
  $gap=~s/(.)\
  if ($gap ne "") {
    $gap.="\n";
  }
  return $gap;
}

sub print_split_attr {
  my ($fileref,$value,$tag)=@_;
  return if $value eq "";
  foreach (split(/\|/,$value)) {
    print $fileref "<$tag>",$_;
  }
}

sub print_split_attr_with_num_attr {
  my ($fileref,$node,$attr,$num,$tag,$at)=@_;
  return if $node->{$attr} eq "";

  my @t=split(/\|/,translate_to_entities($node->{$attr}));
  my @tw=split(/\|/,$node->{$num});
  for (my $i=0;$i<=$#t;$i++) {
    if ($tw[$i]=~/(\d+)/) {
      print $fileref "<$tag $at=$1>",$t[$i];
    } else {
      print $fileref "<$tag>",$t[$i];
    }
  }
}

sub translate_to_entities {
  my ($t)=@_;
  $t=~s/\
  $t=~s/\>/>/g;
  if (length($t)==1) {
    $t=~s/\[/[/g;
    $t=~s/\]/]/g;
    $t=~s/\\\|/|/g;
    $t=~s/\$/$/g;
  }
  return $t;
}

sub write {
  my ($fileref,$fsfile) = @_;
  return unless ref($fsfile);

  my @nodes;
  my $node;

  # print the file information from the root node
  my $root = $fsfile->treeList->[0];
  if ($root) {
    my $lang = $root->{cstslang} ? $root->{cstslang} : "cs";
    print $fileref "\n";
    if ($root->{cstssource} ne "" or $root->{cstsmarkup} ne "") {
      print $fileref "\n";
      print $fileref "";
      print $fileref $root->{cstssource};
      print $fileref "\n";
      print $fileref "";
      my $markup=$root->{cstsmarkup};
      $markup=~s/(.)\\\
      $markup=~s/\
      print $fileref $markup;
      print $fileref "\n\n";
      print $fileref "\n";
    }
  }
  my $treeNo=0;
  foreach $root ($fsfile->trees) {
    $treeNo++;
    @nodes=();
    $node=$root->following;
    while ($node) {
      push @nodes,$node;
      $node=$node->following;
    }
    my $sentord=$fsfile->FS->sentord;
    @nodes = sort { $a->{$sentord} <=> $b->{$sentord} } @nodes;
    # print sentence information from root node
    if (ref($root)) {
      if ($treeNo==1 or $root->{doc}.$root->{docid} ne "") {
        if ($treeNo>1) {
          print $fileref "\n";
          print $fileref "\n";
        }
        print $fileref "{doc},"\" id=\"",
          ($root->{docid}=~/^\d+$/ ? $root->{docid} : "0"),"\">\n";
        print $fileref "\n";
        if ($root->{docmarkup} =~ /\
            print $fileref "\n";
            print $fileref $root->{docmarkup};
            print $fileref "\n";
        }
        my ($genre,$id,$authname)=("mix",$root->{docid},"y");
        my ($mod,$txtype,$med,$temp,$opus)=
          $root->{doc}=~m!([^/]*)/([^/]*)/([^/]*)/([^/]*)/([^/]*)!;
        print $fileref "";
        print $fileref $root->{docprolog} =~ /\([^\<*]*)/ ?
          $1 : $mod,"\n";
        print $fileref "";
        print $fileref $root->{docprolog} =~ /\([^\<*]*)/ ?
                        $1 : $txtype,"\n";
        print $fileref "";
        print $fileref $root->{docprolog} =~ /\([^\<*]*)/ ?
                        $1 : $genre,"\n";
        print $fileref "$1\n" if $root->{docprolog} =~ /\([^\<*]*)/;
        print $fileref "";
        print $fileref $root->{docprolog} =~ /\([^\<*]*)/ ?
                        $1 : $med,"\n";
        print $fileref "$1\n" if $root->{docprolog} =~ /\([^\<*]*)/;
        print $fileref "$1\n" if $root->{docprolog} =~ /\([^\<*]*)/;
        print $fileref "$1\n" if $root->{docprolog} =~ /\([^\<*]*)/;
        print $fileref "$1\n" if $root->{docprolog} =~ /\([^\<*]*)/;
        print $fileref "";
        print $fileref $root->{docprolog} =~ /\([^\<*]*)/ ?
                        $1 : $temp,"\n";
        print $fileref "$1\n" if $root->{docprolog} =~ /\([^\<*]*)/;
        print $fileref "";
        print $fileref $root->{docprolog} =~ /\([^\<*]*)/ ?
                        $1 : $authname,"\n";
        print $fileref "$1\n" if $root->{docprolog} =~ /\([^\<*]*)/;
        print $fileref "";
        print $fileref $root->{docprolog} =~ /\([^\<*]*)/ ?
                        $1 : $opus,"\n";
        print $fileref "";
        print $fileref $root->{docprolog} =~ /\([^\<*]*)/ ?
                        "$1\n" : "$id\n";
        print $fileref "\n";
      }
      if ($treeNo==1 or $root->{chap}) {
        print $fileref "\n" unless ($treeNo==1 or $root->{doc}.$root->{docid} ne "");
        print $fileref "\n";
      }
      if ($root->{para} or $treeNo==1) {
        my $n = $root->{para}=~/(\d+)/ ? $1 : 0;
        print $fileref "\n";
      }
#      print $fileref make_gap($root->{gappre});
      my $id;
      if ($compatibility_mode) {
        $id=$root->{ID1}.$root->{lemid}.$root->{commentTR};
      } else {
        $id=$root->{ID1};
      }

      if ($root->{form}=~/alt/) {
        print $fileref "\n";
      } else {
        print $fileref "\n";
      }
      print $fileref make_gap($root->{gappost});
    }
    # print node information
    foreach $node (@nodes) {
      print $fileref make_gap($node->{gappre});
      if ($node->{origf} ne $node->{form} or $node->{origfkind} and $node->{origfkind} ne 'same') {
        my @w=split(/\|/,translate_to_entities($node->{origf}));
        my @k=split(/\|/,$node->{origfkind});
        my $count=$#w > $#k ? $#w : $#k;
        for (my $i=0; $i<=$count; $i++ ) {
          if ($k[$i] and $k[$i] ne 'same' ) {
            print $fileref "";
          } else {
            print $fileref "";
          }
          print $fileref $w[$i],"\n";
        }
      }

      # choosing between f d and fadd
      if (index($node->{ord},'.')>=$[) {
        my $del=$node->{del}=~/^(?:ELID|ELEX|EXPN|TRANSF)/i ? " ".lc($node->{del}) : "";
        my $TID = $node->{TID} ne '' ? " id=\"$node->{TID}\"" : "";
        print $fileref "";
      } else {
        if ($compatibility_mode) {
          if ($node->{gap1}) {
            my $tags=$node->{gap1};
            $tags=~s/\&nl;/\n/g;
            $tags.="\n" unless $tags=~/\
            print $fileref $tags;
            print $fileref translate_to_entities($node->{form});
          } else {
            print $fileref "",translate_to_entities($node->{form});
          }
        } elsif ($node->{form}=~/^([][!"'()+,-.\/:;=\?`]|&(?:amp|ast|bsol|circ|commat|dollar|gt|lcub|lowbar|lsqb|lt|macron|num|percnt|rcub|rsqb|verbar);)$/) {
          my $case = $node->{formtype} eq 'gen' ? " ".$node->{formtype} : "";
          my $AID = $node->{AID} ne '' ? " id=\"$node->{AID}\"" : "";
          print $fileref "",translate_to_entities($node->{form});
        } else {
          my $case = ($node->{formtype} ne "" and $node->{formtype} ne "lower") ? " ".$node->{formtype} : "";
          my $AID = $node->{AID} ne '' ? " id=\"$node->{AID}\"" : "";
          print $fileref "",$node->{form};
        }
        print_split_attr($fileref,$node->{punct},'P');
        print $fileref "",$node->{alltags} if ($node->{alltags} ne "");
        if (($node->{lemma} ne '' || $node->{tag} ne '')
            && !($node->{lemma} eq '-' && $node->{tag} eq '-')
            || $node->{root} ne '' || $node->{ending} ne ''
           ) {
          print_split_attr($fileref,translate_to_entities($node->{lemma}),'l');
          print $fileref "",$node->{root} if ($node->{root} ne "");
          print $fileref "",$node->{ending} if ($node->{root} ne ""); # this is not a mistake

          print_split_attr_with_num_attr($fileref,$node,'tag','wt','t','w');
        }
        foreach (grep(/^lemmaMM_/,$fsfile->FS->attributes)) {
          /lemmaMM_(.*)$/;
          my $suf=$1;
          print_split_attr($fileref,$node->{$_},"MMl src=\"$suf\"");
          print $fileref "",$node->{"rootMM_$suf"} if ($node->{"rootMM_$suf"} ne "");
          # this is not a mistake
          print $fileref "",$node->{"endingMM_$suf"} if ($node->{"rootMM_$suf"} ne "");
          print_split_attr($fileref,$node->{"tagMM_$suf"},"MMt src=\"$suf\"");
        }
        foreach (grep(/^lemmaMD_/,$fsfile->FS->attributes)) {
          /lemmaMD_(.*)$/;
          my $suf=$1;
          print_split_attr_with_num_attr($fileref,$node,"lemmaMD_$suf","wMDl_$suf","MDl src=\"$suf\"",'w');
          print $fileref "",$node->{"rootMD_$suf"} if ($node->{"rootMD_$suf"} ne "");
          # this is not a mistake
          print $fileref "",$node->{"endingMD_$suf"} if ($node->{"rootMD_$suf"} ne "");
          print_split_attr_with_num_attr($fileref,$node,"tagMD_$suf","wMDt_$suf","MDt src=\"$suf\"",'w');
        }
        if ($node->{afun} and $node->{afun} ne "???") {
          my $afun_atrs="";
          foreach my $afun (split(/\|/,$node->{afun})) {
            print $fileref "
            $afun_atrs=join " ", grep { /./ && !/^no-/ } map { $node->{$_} }
              qw(parallel paren arabfa arabspec arabclaus);
            print $fileref (($afun_atrs ne "") ? " $afun_atrs>" : ">"),$afun;
          }
        }
        foreach (grep(/^afunMD_/,$fsfile->FS->attributes)) {
          /afunMD_(.*)$/;
          print_split_attr_with_num_attr($fileref,$node,"afunMD_$1","wMDA_$1","MDA src=\"$1\"",'w');
        }
        # TODO: PDAT-specific attributes for MDA not yet supported
      }
      my $quot="";
      if ($node->{dsp}=~/(DSPP|DSPI|DSP)/) {
        $quot=" ".lc($1);
      }
      if ($node->{quoted} eq 'QUOT') {
        $quot.= $quot ? ".quot" : " quot";
      }

      #
      # TODO: we need a mechanism to find out when TR information
      # is to be stored and when not
      #
      # we print  if there is a trlemma or dord orders nodes or
      # there is a non-empty govTR and it is different from
      unless ($node->{del} eq 'TRANSF') {
        if (($fsfile->FS->exists('trlemma') and exists($node->{trlemma}) and $node->{trlemma} ne "") or
            $fsfile->FS->order eq 'dord'
            #  or
            #  ($fsfile->FS->exists('govTR') and
            #   exists($node->{govTR}) and
            #   $node->{govTR} ne "" and
            #   $node->{govTR} != $node->parent->{ord})
           ) {

          print $fileref "
          print $fileref " hidden" if ($node->{"TR"} eq "hide");
          print $fileref " origin=\"".join(" ",split /\|/,$node->{"AIDREFS"}).
            "\"" if $node->{"AIDREFS"} ne "";
          print $fileref ">",translate_to_entities($node->{trlemma});

          if ($node->{func} ne "" or $node->{gram} ne "") {
            print $fileref "",$node->{func};
            print $fileref "",$node->{gram} if ($node->{gram} !~ /^(?:---|\?\?\?)?$/);
          }
          print $fileref "",$node->{memberof} if ($node->{memberof} ne "" and
                                                       $node->{memberof} ne "???");
          print $fileref "",$node->{parenthesis} if ($node->{parenthesis} ne "" and
                                                       $node->{parenthesis} ne "???");
          print $fileref "",$node->{operand} if ($node->{operand} ne "" and
                                                       $node->{operand} ne "???");
          my $TRt=make_TRt($node,0);
          print $fileref "",$TRt unless ($TRt=~/^X*$/);
          print $fileref "",$node->{tfa}  if ($node->{tfa} !~ /^(?:---|\?\?\?)?$/);
          print $fileref "",$node->{dord} if ($node->{dord} ne "");
          print $fileref "",$node->{fw} if ($node->{fw} ne "");
          print $fileref "",$node->{phraseme} if ($node->{phraseme} ne "");
          print $fileref "",$node->{frameid} if ($node->{frameid} ne "");
          print $fileref "",translate_to_entities($node->{framere})
            if ($node->{framere} ne "");
          if($gov eq 'govTR' or
             !defined($gov) and $fsfile->FS->order eq 'dord') {
            print $fileref "",$node->parent->{ord};
          } else {
            print $fileref "",$node->{govTR} if ($node->{govTR} ne "");
          }
          do {
            my @corefs=split /\|/,$node->{coref};
            my @cortypes=split /\|/,$node->{cortype};
            foreach (@corefs) {
              print $fileref "";
            }
            foreach (split /\|/,$node->{corlemma}) {
              print $fileref "$_";
            }
          }
        }
      }
      foreach (grep(/^trlemmaM_/,$fsfile->FS->attributes)) {
        /^trlemmaM_(.*)$/;
        print $fileref "
        print $fileref " hidden" if ($node->{"MTR_$1"} eq "hide");
        print $fileref " src=\"$1\"";
        print $fileref " origin=\"".join(" ",split /\|/,$node->{"MAIDREFS_$1"})."\"" if $node->{"MAIDREFS_$1"} ne "";;
        print $fileref ">",$node->{$_};
        # actually, all the set of MTRl subelements should be
        # treated the same (plus hide
        #
        # TODO: IMPLEMENTATION MISSING
        #
      }
      print $fileref "",$node->{ord} if ($node->{ord} ne "");
      if ($node->{TID} eq '') {
        if (defined($gov) and $gov ne 'ordorig'
            or
            !defined($gov) and $fsfile->FS->order eq 'dord') {
          print $fileref "",$node->{ordorig} if $node->{ordorig} ne "";
        } else {
          print $fileref "",int($node->parent->{ord}) if (($export_dependency || $node->parent->{ord} ne "0") and $node->parent->{ord} ne "");
        }
      }
      unless (index($node->{ord},'.')>=$[) {
        #not allowed in DTD for some reason
        foreach (grep(/^govMD_/,$fsfile->FS->attributes)) {
          if ($gov ne $_) {
            /govMD_(.*)$/;
            print_split_attr_with_num_attr($fileref,$node,"govMD_$1","wMDg_$1","MDg src=\"$1\"",'w');
          }
        }
        if ($gov=~/^govMD_(.*)$/) {
          print $fileref "
            ($node->{"wMDg_$1"} ne "" ? "w=".$node->{"wMDg_$1"} : ""),
              ">",$node->parent->{ord};
        }
      }
      if (join("",map { $node->{"wsd$_"} } qw(s ewn ili iliOffset)) ne "") {
        print $fileref "
          join ("",map { " $_='".$node->{"wsd$_"}."'" } grep { $node->{"wsd$_"} ne "" }
            qw(s ewn ili iliOffset)),">";
      }
      # get a list of  unique attributes
      my %xtra;
      @xtra{
        @extra_attributes,
        grep(/^x_/,$fsfile->FS->attributes())
      }=();
      foreach (sort {$a cmp $b} keys %xtra) {
        my $name=$_; $name=~s/^x_//;
        if ($gov ne "x_".$name) {
          print $fileref "",
            translate_to_entities($node->{$_}) if $node->{$_} ne "";
        }
      }
      if ($gov =~ /^x_(.*)$/) {
        print $fileref "",$node->parent->{ord};
      }
      if ($preserve_err1 and $node->{err1} ne "") {
        print $fileref "",$node->{err1};
      }
      print $fileref "\n";
      print $fileref "\n" if ($node->{nospace});
      print $fileref make_gap($node->{gappost});
    }
    # print file ending
  }
  print $fileref "\n";
  print $fileref "\n";
  print $fileref "\n";

  return 1;
}

1;