#!/usr/local/bin/perl5 -w

## ============================================================================
## preprocess.pl
##
## Script to preprocess reuters news corpus file for 20-760.
##
## L. Hiyakumoto
## 18 June 1999
##
## ============================================================================

$Usage = "$0 <total> <outputfile>\n";




## MAIN PROCESSING
## ---------------

unless (@ARGV==2) { print STDERR $Usage and exit(1); }

# setup counts
$total = $ARGV[0];
$doccnt = 0;
$filecnt = 0;

# set up the output file
open(OUT, ">$ARGV[1]") or die "Unable to write file $ARGV[1]: $!";

while ($doccnt < $total) {

    # read the next reuters file
    @input = Read_Input($filecnt);
    $filecnt++;
    
    # split into individual articles after skipping first line
    shift @input;
    $input = join("", @input);
    @articles = split("</REUTERS>", $input);

    # clean up each article and write out results

    foreach $a (@articles) {
	last if ($doccnt >= $total);
	next if ($a =~ /^[^\w]+$/);        # skip if only whitespace
	$a = Remove_Headers($a);           # EXECUTION ORDER MATTERS FOR THESE!
	$a = Remove_Misc_Chars($a);
	$a = Remove_Punctuation($a);

    #    optional routines to remove numbers and separate contractions 
    #    $a = Separate_Contractions($a);
    #    $a = Remove_Numbers($a);

	$a =~ tr/\n//s;                    # remove extra newlines
	@blah = ($a =~ /blah/gi);
	@num = ($a =~ m/\d+/g);            # number of numeric terms
	@word = ($a =~ m/\w+/g);           # total terms
	unless ((scalar(@blah) >= 3) ||    # skip if body is "Blah blah blah"
		(scalar(@word) < 3) ||     #  or if empty or > 30% numeric
		((scalar(@num) / scalar(@word)) > 0.30)) { 
	    print OUT $a;
	    $doccnt++;
	}
    }
}
close(OUT);



## SUBROUTINES
## -----------

sub Read_Input {
    my @input;
    my $file = "reut2-00" . shift(@_) . ".sgm";
    $file =~ s/00(\d\d)/0$1/;
    print STDERR "Reading $file\n";
    open(IN, "<$file") or die "Unable to read file $file: $!";
    @input = <IN>;
    close(IN);
    return @input;
}


sub Remove_Headers {
    my $text = shift @_;
    my $tags = "DATE|EXCHANGES|COMPANIES|TOPICS|PLACES|PEOPLE|ORGS|UNKNOWN|MKNOTE";
    $text =~ s/<($tags).*?>.*<\/\1>//sgo;             # remove tags and content
    $text =~ s/<\/?(TEXT|TITLE|DATELINE|BODY|AUTHOR).*?>//g; # remove tags only
    $text =~ s/(<REUTERS ).*?NEW(ID.*)/$1$2/;         # simplify boundary tag
    return $text;
}


sub Remove_Punctuation {
    my $text = shift @_;
    my $idtag;
    $text =~ s/(<REUTERS ID=.*?>)//;            # save boundary tag
    $idtag = $1;
    $text =~ s/[~\`\"|\\=+\-_()*\^!?:;%\$<>{}\[\]]/ /g;   # always remove
    $text =~ s/,(\W)/$1/g;                      # remove "," at word end
    $text =~ s/(\W),/$1/g;                      # remove "," at word begin
    $text =~ s/([^\.]\w)\.(\W)/$1$2/sg;         # remove "." at word end
                                                #   but keep abbrevs
    $text =~ s/([^\.]\w)\.\.+/$1 /sg;           # remove ellipses
    $text =~ s/(\d)\.\.+/$1 /g;                 # remove ellipses after number
    $text =~ s/(\s)\.\.+/$1/g;                  # remove leading ellipses
    $text =~ s/(\s)(\.|,)+(\s)/$1$3/g;          # remove "." or "," by itself
    $text =~ s/(\s)\'/$1/g;                     # remove leading and trailing
    $text =~ s/\'(\s)/$1/g;                     #   apostrophes
    $text =~ s/([^\d])\/(\w)/$1 $2/g;           # remove "/" between words
    $text =~ s/(\w)\/([^\d])/$1 $2/g;
    return ($idtag . $text);                      
}


sub Remove_Misc_Chars {
    my $text = shift @_;
    $text =~ s/\&lt\;(\S*?)\>/$1/g;             # remove "&lt;" and ">"
    $text =~ s/\&\S*?\;//g;                     # remove "&{stuff};"
    return $text;
}


sub Remove_Numbers {
    my $text = shift @_;
    $text =~ s/(\s)[\,\.\d\/]+(\s)/$1$2/gs;     # remove numbers, fractions
    $text =~ s/(\s)[\,\.\d\/]+(\s)/$1$2/gs;     # again, to catch ## ## case.
    $text =~ s/(\w) +/$1 /g;                    # remove extra spaces
    return $text;
}


sub Separate_Contractions {
    my $text = shift @_;    
    $text =~ s/\'(s|re|ll|d|ve|m)(\s)/ \'$1$2/gi;
    $text =~ s/n\'t/ n\'t/gi;
    return $text;
}

