use strict;

initialise(); # initialise porter stemmer

if ( @ARGV != 3 ) { 
  print "\nusage:\n\t<min occurrences of features>\n\t<min occurrences of terms>\n\t<corpus_file.xml>\n\n";
  exit
}

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

my (%words, %pos, %features, %occurrences_words);

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

    my @words = ();
    my $pos = "";

    my @elems = split ("[<>]",$1);
    foreach my $e (@elems) {
      if ( $e =~ /^w c=\"([^"]+)\"/ ) { 
	$pos = $1;
      }
      elsif ( $e =~ /cons lex=\"([^"]+)\"/ ) {}
      elsif ( $e =~ /\/w/ ) {}
      elsif ( $e =~ /\/cons/ ) {}
      elsif ( $e !~ /\w/ ) {}
      else { 
	$e =~ s/,/COMMA/g;
	$e =~ s/\'/COMMA/g;
	$e =~ s/ /_/g;
	my $w = stem($e);
	push @words, $w;
	if ( $pos =~ /\*/ ) { }
	elsif ( $pos =~ /^(([^|])[^|]*)|(([^|])[^|]*$)/ ) {
	  $pos{$w}{$2}++;
	  $pos{$w}{$4}++
	}
	elsif ( $pos =~ /^(.).+$/ ) { $pos{$w}{$1}++ }
	elsif ( $pos !~ /\w/ ) { $pos{$w}{0}++ }
	$occurrences_words{$w}++;
      }
    }
    for (my $i=0; $i<@words; $i++) {
      my $w = stem($words[$i]);
      if ( $i == 0 ) {
	$words{$w}{left1}{"\#"}++;
	$words{$w}{left2}{"\#"}++;
	$features{"left1-\#"}++;
	$features{"left2-\#"}++;
      }
      elsif ( $i == 1 ) {
	my $w1 = stem($words[$i-1]);
	$words{$w}{left1}{$w1}++;
	$words{$w}{left2}{"\#"}++;
	$features{"right1-$w1"}++;
	$features{"right2-\#"}++;
      }
      else {
	my $w1 = stem($words[$i-1]);
	my $w2 = stem($words[$i-2]);
	$words{$w}{left1}{$w1}++;
	$words{$w}{left2}{$w2}++;
	$features{"right1-$w1"}++;
	$features{"right2-$w2"}++;
      }

      if ( $i == scalar @words-1 ) {
	$words{$w}{right1}{"\#"}++;
	$words{$w}{right2}{"\#"}++;
	$features{"right1-\#"}++;
	$features{"right2-\#"}++;
      }
      elsif ( $i == scalar @words-2 ) {
	my $w1 = stem($words[$i+1]);
	$words{$w}{right1}{$w1}++;
	$words{$w}{right2}{"\#"}++;
	$features{"right1-$w1"}++;
	$features{"right2-\#"}++;
      }
      else {
	my $w1 = stem($words[$i+1]);
	my $w2 = stem($words[$i+2]);
	$words{$w}{right1}{$w1}++;
	$words{$w}{right2}{$w2}++;
	$features{"right1-$w1"}++;
	$features{"right2-$w2"}++;
      }
    }
  }
}
close F;

open A, ">out.arff";

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

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

my (%classes, %classes_words);
foreach my $w (keys %words) { 
  my $total;
  foreach my $p (keys %{$pos{$w}}) { $total = $total + $pos{$w}{$p} }
  my $class = "";
  foreach my $p (keys %{$pos{$w}}) { 
    if ( $pos{$w}{$p} / $total > 0.2 ) { $class .= "-" . $p }
  }
  if ( $class =~ /^\-(.+)$/ ) { $class = $1 }
  $classes{$class} = 1;
  $classes_words{$w} = $class;
}
 
print A "\@ATTRIBUTE class {";
foreach my $c (keys %classes) { print A "$c," }
print A "}\n";

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

my $subset;
foreach my $w (keys %words) {
  if ( $occurrences_words{$w} > $min_inst ) {
    $subset++;
    foreach my $f (sort keys %subset_features) { 
      my ($fp,$fw) = split "-", $f;
      if ( $words{$w}{$fp}{$fw} > 0 ) {
	my $prop = $words{$w}{$fp}{$fw} / $occurrences_words{$w};
	print A "$prop,";
      }
      else { print A "0," }
    }
    print A "$classes_words{$w}\n"
  }
}

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 100 times): $f\n";
my $t = scalar keys %words;
print "original number of instances: $t\n";
print "reduced number of instances (occurring more than 100 times): $subset\n";
my $c = scalar keys %classes;
print "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

}
