lib/Text/Tradition/Collation/Relationship.pm

   1 package Text::Tradition::Collation::Relationship;
   2
   3 use Moose;
   4 use Moose::Util::TypeConstraints;
   5 ## CAREFUL in our use of Moose::Util::TypeConstraints.  That 'from'
   6 ## clashes with Graph::Easy::Edge 'from', so we'll need to unimport
   7 ## TypeConstraints after defining the types.  Or else we would have to
   8 ## finally split out our types into another module.
   9 use MooseX::NonMoose;
  10
  11 extends 'Graph::Easy::Edge';
  12
  13 enum 'RelationshipType' => qw( spelling orthographic grammatical repetition lexical );
  14
  15 subtype 'RelationshipVector',
  16     => as 'ArrayRef',
  17     => where { @$_ == 2
  18                && $_->[0]->isa( 'Graph::Easy::Node' )
  19                && $_->[1]->isa( 'Graph::Easy::Node' )
  20              },
  21     message { 'Argument should be [ SourceReading, TargetReading ]' };
  22
  23 subtype 'RelationshipTokenVector',
  24     => as 'ArrayRef',
  25     => where { @$_ == 2 },
  26     message { 'Argument should be [ \'source\', \'target\' ]' };
  27
  28 no Moose::Util::TypeConstraints;  ## see comment above
  29
  30 has 'type' => (
  31     is => 'rw',
  32     isa => 'RelationshipType',
  33     required => 1,
  34 );
  35
  36 has 'this_relation' => (
  37     is => 'rw',
  38     isa => 'RelationshipVector',
  39     required => 1,
  40 );
  41
  42 has 'primary_relation' => (
  43     is => 'rw',
  44     isa => 'RelationshipTokenVector',
  45 );
  46
  47 has 'global' => (
  48     is => 'rw',
  49     isa => 'Bool',
  50     default => 0,
  51 );
  52
  53 has 'non_correctable' => (
  54     is => 'rw',
  55     isa => 'Bool',
  56     );
  57
  58 has 'non_independent' => (
  59     is => 'rw',
  60     isa => 'Bool',
  61     );
  62
  63 has 'equal_rank' => (
  64     is => 'rw',
  65     isa => 'Bool',
  66     );
  67
  68 sub FOREIGNBUILDARGS {
  69     my $class = shift;
  70     my %args = @_;
  71
  72     # Make the label match our 'type' attribute.
  73     my @superclass_args;
  74     if( exists $args{'type'} ) {
  75         push( @superclass_args, 'label', $args{'type'} );
  76     }
  77     return @superclass_args;
  78 }
  79
  80 sub BUILD {
  81     my( $self, $args ) = @_;
  82
  83     $self->set_attribute( 'class', 'relationship' );
  84
  85     my( $source, $target ) = @{$self->this_relation};
  86     if( $source->has_position && $target->has_position ) {
  87         # Harmonize the positions.
  88         $source->match_position( $target );
  89     }
  90     unless( $self->primary_relation ) {
  91         $self->primary_relation( [ $self->this_relation->[0]->label,
  92                                    $self->this_relation->[1]->label ] );
  93     }
  94 }
  95
  96 no Moose;
  97 __PACKAGE__->meta->make_immutable;