use strict;

initialise(); # initialise porter stemmer

if ( @ARGV != 4 ) { 
  print "\nusage:\n\t<min occurrences of features>\n\t<min occurrences of terms>\n\t<min members for a class to be considered>\n\t<corpus_file.xml>\n\n";
  exit
}

my $min_feats = $ARGV[0];
my $min_inst = $ARGV[1];
my $min_members_class = $ARGV[2];
my $corpus_file = $ARGV[3];

my (%terms, %features);
my (%occurrences_terms, %occurrences_classes);
my (%classes_terms);

open F, $corpus_file;
while (<F>) {
  chomp;
  if ( $_ =~ /^<sentence>(.+)<\/sentence>$/ ) {

    my @words = ();
    my @cats = ();
    my @open = ();
    my %t = ();

    my @elems = split ("[<>]",$1);
    foreach my $e (@elems) {
      if ( $e =~ /^w c=\"([^"]+)\"/ ) { push @cats, $1 }
      elsif ( $e =~ /cons lex=\"([^"]+)\" sem=\"([^"]+)\"/ ) {
	push @open, $1;
	$occurrences_terms{$1}++;
	my @classes = split "[ \(\)]",$2;
	my $class;
	foreach my $c (@classes) { if ( $c =~ /G\#/ ) { $class = $c } }
	$occurrences_classes{$class}++;
	$classes_terms{$1} = $class;
      }
      elsif ( $e =~ /cons lex=\"([^"]+)\"/ ) {
	push @open, $1;
	$occurrences_terms{$1}++;
      }
      elsif ( $e =~ /\/w/ ) {}
      elsif ( $e =~ /\/cons/ ) { pop @open }
      elsif ( $e !~ /\w/ ) {}
      else { 
	$e =~ s/,/COMMA/g;
	$e =~ s/\'/COMMA/g;
	$e =~ s/ /_/g;
	push @words, stem($e);
	foreach my $o (@open) {
	  $t{$o} .= "," . scalar @words-1;
	}
      }
    }
    foreach my $t (keys %t) {
      my @w = split ",", $t{$t};
      my $f = scalar @w-1;
      my $ini = $w[1]; # the first position is empty as string begins with a comma
      my $fin = $w[$f];
      my $k = $fin+1;
      if ( scalar @words >= ($k+1) ) { 
	$terms{$t}{right1}{$words[$k]}++;
	$features{"right1-$words[$k]"}++;
      }
      else { $terms{$t}{right1}{"\#"}++; $features{"right1-#"}++ }
      my $k = $fin+2;
      if ( scalar @words >= ($k+1) ) { 
	$terms{$t}{right2}{$words[$k]}++;
	$features{"right2-$words[$k]"}++;
      }
      else { $terms{$t}{right2}{"\#"}++; $features{"right2-#"}++ }
      my $k = $ini-1;
      if ( $k >= 1 ) { 
	$terms{$t}{left1}{$words[$k]}++;
	$features{"left1-$words[$k]"}++;
      }
      else { $terms{$t}{left1}{"\#"}++; $features{"left1-#"}++ }
      my $k = $ini-2;
      if ( $k >= 1 ) { 
	$terms{$t}{left2}{$words[$k]}++;
	$features{"left2-$words[$k]"}++;
      }
      else { $terms{$t}{left2}{"\#"}++; $features{"left2-#"}++ }
    }
  }
}
close F;

open A, ">out.arff";

print A "\@RELATION terms\n\n";

# keep only a subset of features

my %subset_features;
foreach my $f (keys %features) {
  if ( $features{$f} > $min_feats ) { 
    print A "\@ATTRIBUTE $f REAL\n";
    $subset_features{$f} = 1;
  }
}

my %occs_classes_subset;
foreach my $t (keys %terms) { 
  if ( $occurrences_terms{$t} > $min_inst && $classes_terms{$t} =~ /\w/ ) {
    $occs_classes_subset{$classes_terms{$t}}++
  }
}

my %subset_classes;
foreach my $c (keys %occs_classes_subset) {
  if ( $occs_classes_subset{$c} >= $min_members_class ) { $subset_classes{$c} = 1 }
}

my $classes;
foreach my $c (keys %subset_classes) { $classes .= "$c," }
print A "\@ATTRIBUTE class {$classes"."NoClass}\n";

print A "\n\@DATA\n\n";

my ($noclass, $subset);
foreach my $t (keys %terms) {
  if ( $occurrences_terms{$t} > $min_inst ) {
    $subset++;
    foreach my $f (sort keys %subset_features) { 
      my ($fp,$fw) = split "-", $f;
      if ( $terms{$t}{$fp}{$fw} > 0 ) {
	my $prop = $terms{$t}{$fp}{$fw} / $occurrences_terms{$t};
	print A "$prop,";
      }
      else { print A "0," }
    }
    if ( exists $subset_classes{$classes_terms{$t}} ) {
      print A "$classes_terms{$t}\n"
    }
    else { print A "NoClass\n" }
  }
  elsif ( $occurrences_terms{$t} <= 10 ) {}
  else { $noclass++ }
}

close A;

my $f = scalar keys %features;
print "original number of features: $f\n";
my $f = scalar keys %subset_features;
print "reduced number of features (occurring more than $min_feats times): $f\n";
my $t = scalar keys %terms;
print "original number of instances: $t\n";
print "reduced number of instances (occurring more than $min_inst times): $subset\n";
print "instances discarded because they belong to no class: $noclass\n";
my $c = scalar keys %occurrences_classes;
print "original number of classes: $c\n";
my $c = scalar keys %subset_classes;
print "reduced number of classes: $c\n";

##################
# PORTER STEMMER #
##################

my %step2list;
my %step3list;
my ($c, $v, $C, $V, $mgr0, $meq1, $mgr1, $_v);


sub stem
{  my ($stem, $suffix, $firstch);
   my $w = shift;
   if (length($w) < 3) { return $w; } # length at least 3
   # now map initial y to Y so that the patterns never treat it as vowel:
   $w =~ /^./; $firstch = $&;
   if ($firstch =~ /^y/) { $w = ucfirst $w; }

   # Step 1a
   if ($w =~ /(ss|i)es$/) { $w=$`.$1; }
   elsif ($w =~ /([^s])s$/) { $w=$`.$1; }
   # Step 1b
   if ($w =~ /eed$/) { if ($` =~ /$mgr0/o) { chop($w); } }
   elsif ($w =~ /(ed|ing)$/)
   {  $stem = $`;
      if ($stem =~ /$_v/o)
      {  $w = $stem;
         if ($w =~ /(at|bl|iz)$/) { $w .= "e"; }
         elsif ($w =~ /([^aeiouylsz])\1$/) { chop($w); }
         elsif ($w =~ /^${C}${v}[^aeiouwxy]$/o) { $w .= "e"; }
      }
   }
   # Step 1c
   if ($w =~ /y$/) { $stem = $`; if ($stem =~ /$_v/o) { $w = $stem."i"; } }

   # Step 2
   if ($w =~ /(ational|tional|enci|anci|izer|bli|alli|entli|eli|ousli|ization|ation|ator|alism|iveness|fulness|ousness|aliti|iviti|biliti|logi)$/)
   { $stem = $`; $suffix = $1;
     if ($stem =~ /$mgr0/o) { $w = $stem . $step2list{$suffix}; }
   }

   # Step 3

   if ($w =~ /(icate|ative|alize|iciti|ical|ful|ness)$/)
   { $stem = $`; $suffix = $1;
     if ($stem =~ /$mgr0/o) { $w = $stem . $step3list{$suffix}; }
   }

   # Step 4

   if ($w =~ /(al|ance|ence|er|ic|able|ible|ant|ement|ment|ent|ou|ism|ate|iti|ous|ive|ize)$/)
   { $stem = $`; if ($stem =~ /$mgr1/o) { $w = $stem; } }
   elsif ($w =~ /(s|t)(ion)$/)
   { $stem = $` . $1; if ($stem =~ /$mgr1/o) { $w = $stem; } }


   #  Step 5

   if ($w =~ /e$/)
   { $stem = $`;
     if ($stem =~ /$mgr1/o or
         ($stem =~ /$meq1/o and not $stem =~ /^${C}${v}[^aeiouwxy]$/o))
        { $w = $stem; }
   }
   if ($w =~ /ll$/ and $w =~ /$mgr1/o) { chop($w); }

   # and turn initial Y back to y
   if ($firstch =~ /^y/) { $w = lcfirst $w; }
   return $w;
}

sub initialise {

   %step2list =
   ( 'ational'=>'ate', 'tional'=>'tion', 'enci'=>'ence', 'anci'=>'ance', 'izer'=>'ize', 'bli'=>'ble',
     'alli'=>'al', 'entli'=>'ent', 'eli'=>'e', 'ousli'=>'ous', 'ization'=>'ize', 'ation'=>'ate',
     'ator'=>'ate', 'alism'=>'al', 'iveness'=>'ive', 'fulness'=>'ful', 'ousness'=>'ous', 'aliti'=>'al',
     'iviti'=>'ive', 'biliti'=>'ble', 'logi'=>'log');

   %step3list =
   ('icate'=>'ic', 'ative'=>'', 'alize'=>'al', 'iciti'=>'ic', 'ical'=>'ic', 'ful'=>'', 'ness'=>'');


   $c =    "[^aeiou]";          # consonant
   $v =    "[aeiouy]";          # vowel
   $C =    "${c}[^aeiouy]*";    # consonant sequence
   $V =    "${v}[aeiou]*";      # vowel sequence

   $mgr0 = "^(${C})?${V}${C}";               # [C]VC... is m>0
   $meq1 = "^(${C})?${V}${C}(${V})?" . '$';  # [C]VC[V] is m=1
   $mgr1 = "^(${C})?${V}${C}${V}${C}";       # [C]VCVC... is m>1
   $_v   = "^(${C})?${v}";                   # vowel in stem

}