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 # Make sure the reading sets are unique, but keep
37 my $lemma = shift @reading_sets;
39 map { $unique_sets{$_} = $_ } @reading_sets;
40 delete $unique_sets{$lemma};
41 my @sets = values %unique_sets;
42 unshift( @sets, $lemma );
44 # Two different ways to do this, depending on whether we want
45 # transposed reading nodes to be merged into one (producing a
46 # nonlinear, bidirectional graph) or not (producing a relatively
47 # linear, unidirectional graph.)
48 return $collation->linear ? _collate_linearly( $collation, @sets )
49 : _collate_nonlinearly( $collation, @sets );
52 sub _collate_linearly {
53 my( $collation, $lemma_set, @variant_sets ) = @_;
56 my $substitutions = {};
57 push( @unique, @$lemma_set );
58 while( @variant_sets ) {
59 my $variant_set = shift @variant_sets;
60 # Use diff to do this job
61 my $diff = Algorithm::Diff->new( \@unique, $variant_set,
62 {'keyGen' => \&_collation_hash} );
65 while( $diff->Next ) {
68 my @l = $diff->Items( 1 );
69 my @v = $diff->Items( 2 );
70 foreach my $i ( 0 .. $#l ) {
71 if( !$merged{$l[$i]->id} ) {
72 next if $v[$i] eq $l[$i];
73 # print STDERR sprintf( "Merging %s into %s\n",
76 $collation->merge_readings( $l[$i], $v[$i] );
77 $merged{$l[$i]->id} = 1;
78 $substitutions->{$v[$i]->id} = $l[$i];
80 print STDERR "Would have double merged " . $l[$i]->id . "\n";
83 # splice the lemma nodes into the variant set
84 my( $offset ) = $diff->Get( 'min2' );
85 splice( @$variant_set, $offset, scalar( @l ), @l );
86 push( @new_unique, @l );
88 # Keep the old unique readings
89 push( @new_unique, $diff->Items( 1 ) ) if $diff->Items( 1 );
90 # Add the new readings to the 'unique' list
91 push( @new_unique, $diff->Items( 2 ) ) if $diff->Items( 2 );
94 @unique = @new_unique;
96 return $substitutions;
99 sub _collate_nonlinearly {
100 my( $collation, $lemma_set, @variant_sets ) = @_;
103 my $substitutions = {};
104 push( @unique, @$lemma_set );
105 while( @variant_sets ) {
106 my $variant_set = shift @variant_sets;
107 # Simply match the first reading that carries the same word, so
108 # long as that reading has not yet been used to match another
109 # word in this variant. That way lies loopy madness.
112 foreach my $idx ( 0 .. $#{$variant_set} ) {
113 my $vw = $variant_set->[$idx];
114 my @same = grep { cmp_str( $_ ) eq $vw->text } @unique;
117 foreach my $i ( 0 .. $#same ) {
118 unless( $merged{$same[$i]->id} ) {
119 #print STDERR sprintf( "Merging %s into %s\n",
122 $collation->merge_readings( $same[$i], $vw );
123 $merged{$same[$i]->id} = 1;
125 $variant_set->[$idx] = $same[$i];
126 $substitutions->{$vw->id} = $same[$i];
130 unless( @same && defined($matched) ) {
131 push( @distinct, $vw );
134 push( @unique, @distinct );
136 return $substitutions;
139 sub _collation_hash {
141 return cmp_str( $node );
146 Don't use this. Really.
152 my $word = $reading->text();
153 return $word unless $reading->collation->tradition->name =~ /158/;
159 $word =~ s/quatuor/quattuor/g;
160 $word =~ s/ioannes/iohannes/g;
164 =head2 B<check_for_repeated>( @readings )
166 Given an array of items, returns any items that appear in the array more
171 sub check_for_repeated {
176 if( exists $unique{$_->id} ) {
177 push( @repeated, $_->id );
185 =head2 B<add_hash_entry>( $hash, $key, $entry )
187 Very simple utility for adding $entry to the list at $hash->{$key}.
192 my( $hash, $key, $entry ) = @_;
193 if( exists $hash->{$key} ) {
194 push( @{$hash->{$key}}, $entry );
196 $hash->{$key} = [ $entry ];
206 =item * Get rid of abomination that is cmp_str.
212 This package is free software and is provided "as is" without express
213 or implied warranty. You can redistribute it and/or modify it under
214 the same terms as Perl itself.
218 Tara L Andrews E<lt>aurum@cpan.orgE<gt>