Lingua::Treebank - Perl extension for manipulating the Penn Treebank format

  use Lingua::Treebank;

  my @utterances = Lingua::Treebank->from_penn_file($filename);

  foreach (@utterances) {
    # $_ is a Lingua::Treebank::Const now

    foreach ($_->get_all_terminals) {
      # $_ is a Lingua::Treebank::Const that is a terminal (word)

      print $_->word(), ' ' $_->tag(), "\n";
    }

    print "\n\n";

  }

  Modules for abstracting out the "natural" objects in the Penn
  Treebank format.

    (S
        (NP
            (N I))
        (VP
            (V spoke)))
            Penn

    (S
        (NP
            I_N)
        (VP
            spoke_V))
     Chomsky Normal Form

package Lingua::Treebank;

use 5.008;
use strict;
use warnings;

##################################################################
use Carp;

require Exporter;

our @ISA = qw ( Exporter ) ;
our @EXPORT_OK = qw();
our @EXPORT = qw();
our $VERSION = '0.16';

our $MAX_WARN_TEXT = 100;
our $VERBOSE = 1;
##################################################################
use Lingua::Treebank::Const;
our $CONST_CLASS = 'Lingua::Treebank::Const';
##################################################################
sub from_penn_file {
    my ($class, $file) = @_;

    open (my $fh, "<$file") or die "couldn't open $file: $!\n";
    my @results = $class->from_penn_fh($fh);
    close $fh or die "couldn't close $file: $!\n";

    return @results;
}
##################################################################
sub from_penn_fh {
    my ($class, $fh) = @_;

    my $rawTrees;

    if (not UNIVERSAL::isa($CONST_CLASS, 'Lingua::Treebank::Const')) {
	carp "CONST_CLASS value $CONST_CLASS",
	  " doesn't seem to be a subclass of Lingua::Treebank::Const\n";
    }

  LINE:
    while (<$fh>) {

        chomp;              # remove newlines

        if (   substr( $_, 0, 3 ) eq '*x*'
            or substr( $_, 0, 10 ) eq '=' x 10 )
        {
            # skip header copyright comments, bar of ====
            next LINE;
        }

	next if /^\s*$/; # skip entirely blank lines

	# slurp in the rest of the merge file all at once
	local $/;
	undef $/;
	$rawTrees = $_ . (<$fh>);
    }


    my (@utterances);
    while ($rawTrees) {
	$rawTrees =~ s/^\s+//;
	my $token = Lingua::Treebank::Const->find_brackets($rawTrees);

	if (defined $token) {
	    substr ($rawTrees, 0, length $token) = '';

	    $rawTrees =~ s/^\s+//;

	    my $utt = $CONST_CLASS->new->from_penn_string($token);
	    if (defined $utt) {
		push @utterances, $utt;
	    }
	    else {
		carp "couldn't parse '", cite_warning($token),
		  "' remaining data '", cite_warning($rawTrees),
		    "' in filehandle ignored";
		last;
	    }
	}
	else {
	    # no token extractable
	    carp "unrecognized data '", cite_warning($rawTrees),
	      "' remaining in filehandle ignored";
	    last;
	}
	$rawTrees =~ s/^\s*//;
    }

    return @utterances;
}


sub from_cnf_file {
    my ($class, $file) = @_;

    open (my $fh, "<$file") or die "couldn't open $file: $!\n";
    my @root_nodes = $class->from_cnf_fh($fh);
    close $fh or die "couldn't close $file: $!\n";

    return @root_nodes;
}

# BUGBUG Should share code with from_penn_fh
sub from_cnf_fh {
    my ($class, $fh) = @_;

    my @root_nodes;
  LINE:
    while (<$fh>) {
	chomp;
	s/#.*$//; # Remove comments
	next LINE if (/^\s*$/); # Skip empty lines.
	next LINE if (/^<s.*>$/); # Skip sentence annotation used by
                                  # the Structured Language Model.

      NODE:
	while (length $_) {
	    my $text = Lingua::Treebank::Const->find_brackets($_);

	    if (length $text) {

		# Remove the matched constituent from the remaining
		# text.
		substr ($_, 0, length $text) = '';
		s/^\s+//;

		# The bracketed text is a CNF treebank constituent.
		my Lingua::Treebank::Const $node =
		  Lingua::Treebank::Const->new->from_cnf_string($text);

		if (not defined $node) {
		    warn "couldn't parse '$text', remaining data '$_; in line $.filehandle ignored";
		    last NODE;
		}

		push @root_nodes, $node;
	    }
	    else {
		# No token extractable.
		warn "unrecognized data '$_', remaining in line $. ignored\n";
		last NODE;
	    }
	}
    }

    return @root_nodes;
}




##################################################################
sub cite_warning {
    my $text = shift;
    my $warning;
    if (length $text > $MAX_WARN_TEXT) {
	$warning =
	  substr($text, 0, $MAX_WARN_TEXT / 2);
	$warning .= ' [ ... OMITTED ... ] ';
	$warning .=
	  substr($text, -($MAX_WARN_TEXT / 2) );
    }
    else {
	$warning = $text;
    }
    return $warning;
}
##################################################################
1;

__END__