File Coverage

blib/lib/Lingua/FeatureMatrix.pm

Criterion	Covered	Total	%
statement	15	18	83.3
branch			n/a
condition			n/a
subroutine	5	6	83.3
pod			n/a
total	20	24	83.3

package Lingua::FeatureMatrix;

use 5.006;
use strict;
use warnings;
use Graph::Directed;
use Carp;
##################################################################
# package globals
our $VERSION = '0.05';
##################################################################
# data methods install using Class::MM
use Class::MethodMaker
  new_with_init => 'new',
  new_hash_init => 'hash_init',
  get_set => [ qw [ _emeType _featureClassType ],
	       qw [_eme_new_opts _fclass_new_opts ] ],

  get_set => [ 'report', 'graph' ],

  get_set => 'Name',
  object => [ Graph::Directed => 'implicature_graph',],
  get_set => 'fh',
#  object_list => [ Lingua::FeatureMatrix::Implicature => 'implicatures' ],

  # Lingua::FeatureMatrix::FeatureClass (or subclass) objs
  hash => 'featureClasses',
  # Lingua::FeatureMatrix::Eme subclass objs
  hash => 'emes';

use Lingua::FeatureMatrix::Implicature;
use Lingua::FeatureMatrix::FeatureClass;
##################################################################
sub init {
  my $self = shift;
  my ($class) = ref($self);

  my (%args) = @_;

  my $file = $args{file};
  if (not defined $file) {
    croak "$class must be initialized with a 'file' => name",
      " or 'file' => filehandle key/value pair";
  }
  if (ref($file))  {
      $self->Name('');
      if (UNIVERSAL::isa($file, 'IO::Handle') or UNIVERSAL::isa($file, 'GLOB')) {
	  $self->fh($file);
      }
      else {
	  croak "file handed in is a ", ref($file),
	    " and apparently not a descendant of IO::Handle!";
      }
  }
  else {
      $self->Name( $file );
      require IO::File;
      # open the filehandle
      my $fh = IO::File->new($file) or croak "couldn't open $file: $!\n";
      $self->fh($fh);
  }



  if ($args{report}) {
    $self->report($args{report});
  }
  else {
    $self->report('');
  }

  if ($args{graph}) {
    $self->graph($args{graph});
  }
  else {
    $self->graph('down');
  }

  $self->implicature_graph( Graph::Directed->new() );
  if ($self->graph eq 'down') {
    $self->implicature_graph->set_attribute(label =>
					    'Feeding and Bleeding ' .
					    'relationships');
  }
  elsif ($self->graph eq 'up') {
    $self->implicature_graph->set_attribute(label =>
					    'Possible but ignored feeding ' .
					    'and bleeding relationships');
  }
  else {
    warn "don't know what the 'graph' parameter " .
      $self->graph() . " means\n";
  }
  $self->implicature_graph->set_attribute(ratio => 1);

  # set up to know which subclasses to use:

  # we had better find out what Eme class this is
  $self->_setEmeType($args{eme}, $args{eme_opts});

  # we might also have been instructed on a subtype of featureclass to use
  $self->_setFeatureClass($args{featureclass}, $args{featureclass_opts});

  # so far, no requirement to be able to subclass the
  # implicature. Leave it that way for now.

  # TO DO: add other more direct ways to initialize dynamically if
  # needed
  $self->_loadFile(); #$file);

  # fill out any features based on implicatures
  $self->_completeSpecifications();
}
##################################################################
sub _setEmeType {
  my $self = shift;
  my $class = ref($self);
  my $emeType = shift;
  my $eme_new_opts = shift;
  if (not defined $emeType) {
    croak "$class must be initialized with an ( " .
      "'eme' => Lingua::FeatureMatrix::Eme-subclass-name ) key-value pair";
  }

  # make sure that the class specified is loadable
#   eval "require $emeType";
#   if ($@) {
#     croak "trouble loading $emeType: $@; exiting";
#   }
  if (not $emeType->isa('Lingua::FeatureMatrix::Eme')) {
      croak "$emeType (provided as 'eme' parameter to $class)" .
	  " is not a Lingua::FeatureMatrix::Eme!\n";
  }
  if ($emeType eq 'Lingua::FeatureMatrix::Eme') {
    croak "eme parameter to Lingua::FeatureMatrix must be a *derived* " .
      "subclass, since L::FM::Eme has abstract functions\n";
  }
  if (my $error =$emeType->failsContract()) {
    croak "$emeType fails to meet Lingua::FeatureMatrix::Eme contract: ",
      $error, "\n";
  }

  $self->_emeType( $emeType );

  # TO DO: undocumented feature allows more powerful subclassing of
  # Eme objects, by passing more parameters to the Eme-building
  # routines from this class
  if (not defined $eme_new_opts) {
    $self->_eme_new_opts( [] );
  }
  elsif (ref($eme_new_opts) eq 'ARRAY') {
    # it's an arrayref. that's what we want.
    $self->_eme_new_opts( $eme_new_opts );
  }
  elsif ( not ref($eme_new_opts) ) {
    # it's a scalar. Package it up to be an arrayref anyway.
    $self->_eme_new_opts( [ $eme_new_opts ] )
  }
  else {
    croak "eme_opts parameter to ", ref($self),
      " requires arrayref or scalar, not ", ref($eme_new_opts);
  }
} # end _setEmeType
##################################################################
sub _setFeatureClass {
  # TO DO: user-document this undocumented feature, which allows
  # subclassing of the FeatureClass object. Defaults to the base class
  # if user ignores it, though.
  my $self = shift;
  my $featureclass = shift;
  my $fClass_opts = shift;
  if (not defined $featureclass) {
    $featureclass = 'Lingua::FeatureMatrix::FeatureClass';
  }

  if (not $featureclass->isa('Lingua::FeatureMatrix::FeatureClass')){
    croak "featureclass parameter '$featureclass' to ",
      ref($self), " not a Lingua::FeatureMatrix::FeatureClass " ,
	"subclass!";
  }
  $self->_featureClassType( $featureclass );

  if (not defined $fClass_opts) {
    $self->_fclass_new_opts( [] );
  }
  elsif (ref($fClass_opts) eq 'ARRAY') {
    $self->_fclass_new_opts( $fClass_opts );
  }
  elsif ( not ref($fClass_opts) ) {
    $self->_fclass_new_opts( [ $fClass_opts ] )
  }
  else {
    croak "featureclass_opts parameter to ", ref($self),
      " requires arrayref or scalar, not ", ref($fClass_opts);
  }
}
##################################################################
sub _loadFile {
  # grabs all lines from config file, strips comments and spaces
  my $self = shift;
  my $file = $self->Name();

#   open(IN,$file) or die "cannot open $file $!\n";

  my $fh = $self->fh();
  # sort data into maps, eme-specifications, and class-specifications

  while (<$fh>) {
    # clean up lines
    chomp;
    $_ = set_utf($_);
    tr/\x{FEFF}//d;
    next if /^#/; # drop comments
    s/\s//g;      # and spaces
    next if not length($_);  # and skip blank lines

    # TO DO: eval the following block, and trap errors. Report them
    # with line numbers for the user

    if (/^ \( (.+) \=\> (.+) \) $/x) {
      #  ( +vow => +son )
      #  ( +cons => *tense )
      $self->_readImplicature($1, $2);
    }
    elsif (/^class (\S+) \=\> (.+) $/x) {
      #  class AFF => [ +stop +fric ]
      $self->_readClass($1, $2);
    }
    elsif (/^ (\S+) (\[.*) $/x) {
      #  A [ +vow +low -tense ]
      $self->_readEme($1, $2);
    }
    else {
      # TO DO: document proper .dat file format
      die "datafile $file has bad format in line $., '$_'\n";
    }
  }
  close $fh or croak "couldn't close file ", $self->Name();
#  close (IN) or die "can't close file $file $!\n";
}
##################################################################
sub _readImplicature {
  my $self = shift;
  my $class = ref($self);

  my ($implier, $implicant) = @_;

  my %implier = $class->_getFeatureSet($implier);
  my %implicant = $class->_getFeatureSet($implicant);

  # TO DO: check the featureset used here against whether it's legal.

  my $implicature =
    Lingua::FeatureMatrix::Implicature->new(\%implier, \%implicant);

  $self->add_implicature($implicature);
}
##################################################################
sub _readClass {
  my $self = shift;
  my $class = ref($self);

  my ($fClassName, $req_features) = @_;

  my %required = $class->_getFeatureSet($req_features);

  my $fClassType = $self->_featureClassType();

  my $featureClass =
    $fClassType->new(name => $fClassName, features => \%required);
  $self->featureClasses( $fClassName => $featureClass );
}
##################################################################
sub _readEme {
  my $self = shift;
  my ($symbol, $features) = @_;

  if (defined $self->emes($symbol)) {
    my $eme = $self->emes($symbol);
    carp "at line $.: but $symbol previously defined as ",
      $eme->dumpFeaturesToText($eme->listUserSpecified());
  }

  my $class = ref($self);

  my (%features) = $class->_getFeatureSet($features);
  my $eme =
    $self->_emeType()->new(name => $symbol,
			   options => $self->_eme_new_opts(),
			   %features,
			  );

  $self->emes($symbol => $eme);
}
##################################################################
sub add_implicature {
  my $self = shift;
  my Lingua::FeatureMatrix::Implicature $impl = shift;
#   $self->implicature_graph(
  my (@otherIndices) =
#    map {$self->implicature_graph->get_attribute('object', $_)}
      $self->implicature_graph->vertices();
  my $insert_index = scalar (@otherIndices);

  $self->implicature_graph->add_vertex($insert_index);
  # add a bunch of details about this object:

  # machine-readable 'object'
  $self->implicature_graph->set_attribute(object => $insert_index,
					  $impl);
  # human-readable 'label'
  $self->implicature_graph->set_attribute(label => $insert_index,
					  $impl->dumpToText);

  # see how this new implicature fits into the dependency (ordering).
  foreach my $otherIdx (@otherIndices) {
    # yes, we have an n-squared scaling here. Tens of thousands of
    # rules will have problems, but hundreds should still only take
    # seconds, maximum. I hope. Don't really know how to build this
    # graph any other way... :-/

    my $other =
      $self->implicature_graph->get_attribute(object => $otherIdx);

    my (@inDeps) = $impl->dependsOn($other);
    my (@outDeps) = $other->dependsOn($impl);

    if (@inDeps) {
      if ($self->graph =~ /down/) {
	$self->implicature_graph->add_edge($otherIdx, $insert_index);
	$self->implicature_graph->set_attribute( label =>
						 $otherIdx, $insert_index,
						 (join " ", @inDeps));
      }
    }
    if (@outDeps) {
      # these are dependencies that suggest that it *could* have
      # bled/fed rules higher up in the ordering.
      if ($self->graph =~ /up/) {
	$self->implicature_graph->add_edge($insert_index, $otherIdx);
	$self->implicature_graph->set_attribute( label =>
						 $insert_index, $otherIdx,
						 (join " ", @outDeps));
      }
      if ($self->report() eq 'back-dependencies') {
	carp $impl->dumpToText(), "(implicature number $insert_index)",
	  " could have been applied before ", $other->dumpToText(),
	    " (implicature number $otherIdx)",
	      " despite their input in the other order.";
      }
    }
  } #end foreach otheridx


}
##################################################################
sub _completeSpecifications {

  my $self = shift;

#   my $ordered_impls =
#     Lingua::FeatureMatrix::Implicature->order

#    {
#     my @ordered =
#       Lingua::FeatureMatrix::Implicature->sortByRuleOrder($self->implicatures());
#     $self->implicatures_clear();
#     $self->implicatures_push(@ordered);
#   }

  my (@orderedImpls) = $self->orderImplicatures();

  foreach my $emeName (sort $self->emes_keys) {

    my $eme = $self->emes($emeName);
    # future might consider a toposort here...
    foreach my $implicature (@orderedImpls) {
      if ( $implicature->matches( $eme ) ) {
	$implicature->apply( $eme );
      }
    }

    my (@missing) = $self->emes($emeName)->listUnspecified();
    if (@missing) {
      warn $self->_emeType . " '$emeName' " .
	"(a Lingua::FeatureMatrix::Eme subclass) " .
	  "was not fully specified after application of implicatures " .
	    "(missing feature(s) [ @missing ]).\n";
    }

  }
}
#################################################################
sub _getFeatureSet {
    # returns a hash of ( feature1 => 1, feature2 => 0, feature3 => undef )
    # style data, given "[+feature1 -feature2 *feature3]" style string
    my $class = shift;
    my $featureset = shift;

    if (not defined $featureset) {
      confess;
    }

    $featureset =~ s/^\[//; # remove leading & trailing brackets
    $featureset =~ s/\]$//;

    # assumes no features use + or - within their names.
    my (@featureData) = split( /([+*-])/, $featureset);

    @featureData = grep {$_ ne ''} @featureData;

    if ( not (@featureData % 2) ) {
	# odd
    }

    @featureData = map { $_ eq '-' ? 0 : $_ } @featureData;
    @featureData = map { $_ eq '+' ? 1 : $_ } @featureData;
    @featureData = map { $_ eq '*' ? (undef $_) : $_ }  @featureData;

    # reversing the @featureData list puts keys before values, instead
    # of the linguistic standard of value/key
    # (e.g. +vow becomes vow => 1)
    # note earlier listings override later
    return reverse @featureData;
}
##################################################################
# main public access method.
sub matchesFeatureClass {
  my $self = shift;
  my ($class) = ref($self);
  my $symbol = shift;
  my $className = shift;

  my $eme = $self->emes($symbol);
  croak "unrecognized $class symbol $symbol" unless defined $eme;

  my $featureClass = $self->featureClasses($className);
  croak "unrecognized class $className" unless defined $featureClass;

  return $featureClass->matches($eme);
}
##################################################################
# public (probably debugging) method
sub listFeatureClassMembers {
    my $self = shift;
    my $className = shift;

    my $featureClass = $self->featureClasses($className);
    croak "unrecognized class $className" unless defined $featureClass;

    my @symbols;

    foreach my $symbol (sort $self->emes_keys()) {
      if ( $featureClass->matches( $self->emes($symbol) ) ) {
	push @symbols, $symbol;
      }
    }
    return @symbols;
}
##################################################################
sub orderImplicatures {
  # return "ordered" list of implicatures.
  my $self = shift;

  # "By Any Means Necessary" --Malcolm X


  return
    map {$self->implicature_graph->get_attribute('object',$_)}
      sort { $a <=> $b } $self->implicature_graph->vertices();

  # Schwartzian Transform is a good means.
#     map {$_->[0]}                  # (3) strip sort index
#       sort { $a->[1] <=> $b->[1] } # (2) sort items by the sort index
# 	map { [$_ =>               # (1) get a sort index for each
# 	       $self->implicature_graph->get_attribute('insert_index', $_)] }
# 	  $self->implicature_graph->vertices();


  # future improvements will include a toposort call.


}
##################################################################
sub findEquivalentEmes {
  my $self = shift;
  my (@symbols) = $self->emes_keys();

  # wantarray returns undef in void context
  if (not defined wantarray()) {
      carp "useless call to findEquivalentEmes() in void context";
      return; # don't bother doing any work
  }

  my %problems;
  while (@symbols) {
    my $thisSymbol = shift @symbols;
    my $thisEme = $self->emes($thisSymbol);
    foreach my $otherSymbol (@symbols) {
      if ($thisEme->isEquivalent($self->emes($otherSymbol))) {
        $problems{$thisSymbol} = $otherSymbol;
      }
      # else this eme not equivalent to any remaining eme
    } # end foreach othersymbol
  } # end while @symbols remaining

  if (wantarray()) {
    return %problems;
  }
  else {
    return (scalar(keys %problems));
  }
} #end findEquivalentEmes
##################################################################
# debugging public method
sub dumpToText {
  # debugging function
  my $self = shift;
  my $lineLength = shift;

  local $Text::Wrap::columns = (defined $lineLength ?
				  $lineLength : $Text::Wrap::columns);
  my (@text);
  # loop over emes, dumping each one into filename
  use Text::Wrap;
  foreach my $symbol (sort $self->emes_keys) {
    my $emeText = $self->emes($symbol)->dumpToText();

    my $line = $symbol . "\t" . $emeText;

    push @text, ($Text::Wrap::columns ?
		   wrap ('', "\t  ", $line) : $line);
  }

  return join ("\n", @text);
}
##################################################################
sub set_utf {
    # thanks to perlmonks' grantm
    # (http://www.perlmonks.org/index.pl?node=grantm) for saving me
    return pack "U0a*", join '', @_;
}
##################################################################
1;

__END__