1 package Text::Tradition::Parser::Util;
7 use vars qw/ @EXPORT_OK /;
8 @EXPORT_OK = qw/ add_hash_entry check_for_repeated cmp_str collate_variants is_monotonic /;
12 Text::Tradition::Parser::Util
16 A collection of utilities used by multiple Text::Tradition parsers.
17 Probably not of external interest.
21 =head2 B<collate_variants>( $collation, @reading_ranges )
23 Given a set of readings in the form
24 ( lemma_start, lemma_end, rdg1_start, rdg1_end, ... )
25 walks through each to identify those readings that are identical. The
26 collation is a Text::Tradition::Collation object; the elements of
27 @readings are Text::Tradition::Collation::Reading objects that appear
28 on the collation graph.
32 sub collate_variants {
33 my( $collation, @reading_sets ) = @_;
35 # Two different ways to do this, depending on whether we want
36 # transposed reading nodes to be merged into one (producing a
37 # nonlinear, bidirectional graph) or not (producing a relatively
38 # linear, unidirectional graph.)
39 return $collation->linear ? collate_linearly( @_ )
40 : collate_nonlinearly( @_ );
43 sub collate_linearly {
44 my( $collation, $lemma_set, @variant_sets ) = @_;
47 my $substitutions = {};
48 push( @unique, @$lemma_set );
49 while( @variant_sets ) {
50 my $variant_set = shift @variant_sets;
51 # Use diff to do this job
52 my $diff = Algorithm::Diff->new( \@unique, $variant_set,
53 {'keyGen' => \&_collation_hash} );
56 while( $diff->Next ) {
59 my @l = $diff->Items( 1 );
60 my @v = $diff->Items( 2 );
61 foreach my $i ( 0 .. $#l ) {
62 if( !$merged{$l[$i]->id} ) {
63 next if $v[$i] eq $l[$i];
64 print STDERR sprintf( "Merging %s into %s\n",
67 $collation->merge_readings( $l[$i], $v[$i] );
68 $merged{$l[$i]->id} = 1;
69 $substitutions->{$v[$i]->id} = $l[$i];
71 print STDERR "Would have double merged " . $l[$i]->id . "\n";
74 # splice the lemma nodes into the variant set
75 my( $offset ) = $diff->Get( 'min2' );
76 splice( @$variant_set, $offset, scalar( @l ), @l );
77 push( @new_unique, @l );
79 # Keep the old unique readings
80 push( @new_unique, $diff->Items( 1 ) ) if $diff->Items( 1 );
81 # Add the new readings to the 'unique' list
82 push( @new_unique, $diff->Items( 2 ) ) if $diff->Items( 2 );
85 @unique = @new_unique;
87 return $substitutions;
90 sub collate_nonlinearly {
91 my( $collation, $lemma_set, @variant_sets ) = @_;
94 my $substitutions = {};
95 push( @unique, @$lemma_set );
96 while( @variant_sets ) {
97 my $variant_set = shift @variant_sets;
98 # Simply match the first reading that carries the same word, so
99 # long as that reading has not yet been used to match another
100 # word in this variant. That way lies loopy madness.
103 foreach my $idx ( 0 .. $#{$variant_set} ) {
104 my $vw = $variant_set->[$idx];
105 my @same = grep { cmp_str( $_ ) eq $vw->text } @unique;
108 foreach my $i ( 0 .. $#same ) {
109 unless( $merged{$same[$i]->id} ) {
110 #print STDERR sprintf( "Merging %s into %s\n",
113 $collation->merge_readings( $same[$i], $vw );
114 $merged{$same[$i]->id} = 1;
116 $variant_set->[$idx] = $same[$i];
117 $substitutions->{$vw->id} = $same[$i];
121 unless( @same && defined($matched) ) {
122 push( @distinct, $vw );
125 push( @unique, @distinct );
127 return $substitutions;
130 sub _collation_hash {
132 return cmp_str( $node );
137 my $word = $reading->text();
143 $word =~ s/quatuor/quattuor/g;
144 $word =~ s/ioannes/iohannes/g;
148 =head2 B<check_for_repeated>( @readings )
150 Given an array of items, returns any items that appear in the array more
155 sub check_for_repeated {
160 if( exists $unique{$_->id} ) {
161 push( @repeated, $_->id );
170 my( $hash, $key, $entry ) = @_;
171 if( exists $hash->{$key} ) {
172 push( @{$hash->{$key}}, $entry );
174 $hash->{$key} = [ $entry ];
179 my( @readings ) = @_;
180 my( $common, $min, $max ) = ( -1, -1, -1 );
181 foreach my $rdg ( @readings ) {
182 # print STDERR "Checking reading " . $rdg->id . "/" . $rdg->text . " - "
183 # . $rdg->position->reference ."\n";
184 return 0 if $rdg->position->common < $common;
185 if( $rdg->position->common == $common ) {
186 return 0 if $rdg->position->min <= $min;
187 return 0 if $rdg->position->max <= $max;
189 $common = $rdg->position->common;
190 $min = $rdg->position->min;
191 $max = $rdg->position->max;
202 =item * Get rid of abomination that is cmp_str.
208 This package is free software and is provided "as is" without express
209 or implied warranty. You can redistribute it and/or modify it under
210 the same terms as Perl itself.
214 Tara L Andrews E<lt>aurum@cpan.orgE<gt>