Commit | Line | Data |
d047cd52 |
1 | package Text::Tradition::Collation::Relationship; |
2 | |
3 | use Moose; |
4 | use Moose::Util::TypeConstraints; |
3265b0ce |
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; |
d047cd52 |
10 | |
3265b0ce |
11 | extends 'Graph::Easy::Edge'; |
d047cd52 |
12 | |
3265b0ce |
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 | |
d047cd52 |
30 | has 'sort' => ( |
31 | is => 'rw', |
32 | isa => 'RelationshipType', |
33 | required => 1, |
34 | ); |
35 | |
3265b0ce |
36 | has 'orig_relation' => ( |
d047cd52 |
37 | is => 'rw', |
3265b0ce |
38 | isa => 'RelationshipVector', |
d047cd52 |
39 | required => 1, |
40 | ); |
41 | |
3265b0ce |
42 | has 'related_readings' => ( |
43 | is => 'rw', |
44 | isa => 'RelationshipTokenVector', |
45 | ); |
46 | |
d047cd52 |
47 | has 'global' => ( |
48 | is => 'rw', |
49 | isa => 'Bool', |
3265b0ce |
50 | default => 0, |
d047cd52 |
51 | ); |
52 | |
3265b0ce |
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; |