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 );
  14
  15 subtype 'RelationshipVector',
  16     => as 'ArrayRef',
  17     => where { @$_ == 2
  18                && $_->[0]->isa( 'Text::Tradition::Collation::Reading' )
  19                && $_->[1]->isa( 'Text::Tradition::Collation::Reading' )
  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 'sort' => (
  31     is => 'rw',
  32     isa => 'RelationshipType',
  33     required => 1,
  34 );
  35
  36 has 'orig_relation' => (
  37     is => 'rw',
  38     isa => 'RelationshipVector',
  39     required => 1,
  40 );
  41
  42 has 'related_readings' => (
  43     is => 'rw',
  44     isa => 'RelationshipTokenVector',
  45 );
  46
  47 has 'global' => (
  48     is => 'rw',
  49     isa => 'Bool',
  50     default => 0,
  51 );
  52
  53 sub FOREIGNBUILDARGS {
  54     my $class = shift;
  55     my %args = @_;
  56
  57     # Make the label match our 'sort' attribute.
  58     my @superclass_args;
  59     if( exists $args{'sort'} ) {
  60         push( @superclass_args, 'label', $args{'sort'} );
  61     }
  62     return @superclass_args;
  63 }
  64
  65 sub BUILD {
  66     my( $self, $args ) = @_;
  67
  68     $self->set_attribute( 'class', 'relationship' );
  69
  70     my( $source, $target ) = @{$self->orig_relation};
  71     if( $source->has_position && $target->has_position
  72         && $source->position ne $target->position ) {
  73         die "Cannot set relationship between readings in different positions";
  74     }
  75     unless( $self->related_readings ) {
  76         $self->related_readings( [ $self->orig_relation->[0]->label,
  77                                    $self->orig_relation->[1]->label ] );
  78     }
  79 }
  80
  81 no Moose;
  82 __PACKAGE__->meta->make_immutable;