1 package Text::Tradition::Analysis;
6 use Encode qw/ encode_utf8 /;
9 use JSON qw/ encode_json decode_json /;
12 use Text::Tradition::Stemma;
14 use vars qw/ @EXPORT_OK /;
15 @EXPORT_OK = qw/ run_analysis group_variants analyze_variant_location wit_stringify /;
19 Text::Tradition::Analysis - functions for stemma analysis of a tradition
24 use Text::Tradition::Analysis qw/ run_analysis analyze_variant_location /;
25 my $t = Text::Tradition->new(
26 'name' => 'this is a text',
28 'file' => '/path/to/tei_parallel_seg_file.xml' );
29 $t->add_stemma( 'dotfile' => $stemmafile );
31 my $variant_data = run_analysis( $tradition );
32 # Recalculate rank $n treating all orthographic variants as equivalent
33 my $reanalyze = analyze_variant_location( $tradition, $n, 0, 'orthographic' );
37 Text::Tradition is a library for representation and analysis of collated
38 texts, particularly medieval ones. The Collation is the central feature of
39 a Tradition, where the text, its sequence of readings, and its relationships
40 between readings are actually kept.
44 =head2 run_analysis( $tradition, %opts )
46 Runs the analysis described in analyze_variant_location on every location in the
47 collation of the given tradition, with the given options. These include:
51 =item * stemma_id - Specify which of the tradition's stemmata to use. Default
52 is 0 (i.e. the first).
54 =item * ranks - Specify a list of location ranks to analyze; exclude the rest.
56 =item * merge_types - Specify a list of relationship types, where related readings
57 should be treated as identical for the purposes of analysis.
64 use Text::Tradition::Analysis qw/ run_analysis analyze_variant_location /;
66 my $datafile = 't/data/florilegium_tei_ps.xml';
67 my $tradition = Text::Tradition->new( 'input' => 'TEI',
69 'file' => $datafile );
70 my $s = $tradition->add_stemma( 'dotfile' => 't/data/florilegium.dot' );
71 is( ref( $s ), 'Text::Tradition::Stemma', "Added stemma to tradition" );
73 my %expected_genealogical = (
104 my $data = run_analysis( $tradition );
105 foreach my $row ( @{$data->{'variants'}} ) {
106 # Account for rows that used to be "not useful"
107 unless( exists $expected_genealogical{$row->{'id'}} ) {
108 $expected_genealogical{$row->{'id'}} = 1;
110 is( $row->{'genealogical'}, $expected_genealogical{$row->{'id'}},
111 "Got correct genealogical flag for row " . $row->{'id'} );
113 is( $data->{'variant_count'}, 58, "Got right total variant number" );
114 # TODO Make something meaningful of conflict count, maybe test other bits
121 my( $tradition, %opts ) = @_;
122 my $c = $tradition->collation;
124 my $stemma_id = $opts{'stemma_id'} || 0;
125 my @ranks = ref( $opts{'ranks'} ) eq 'ARRAY' ? @{$opts{'ranks'}} : ();
126 my @collapse = ref( $opts{'merge_types'} ) eq 'ARRAY' ? @{$opts{'merge_types'}} : ();
129 my $stemma = $tradition->stemma( $stemma_id );
131 # Figure out which witnesses we are working with
132 my @lacunose = $stemma->hypotheticals;
133 my @tradition_wits = map { $_->sigil } $tradition->witnesses;
134 map { push( @tradition_wits, $_->sigil.$c->ac_label ) if $_->is_layered }
135 $tradition->witnesses;
136 push( @lacunose, _symmdiff( [ $stemma->witnesses ], \@tradition_wits ) );
138 # Find and mark 'common' ranks for exclusion, unless they were
139 # explicitly specified.
142 foreach my $rdg ( $c->common_readings ) {
143 $common_rank{$rdg->rank} = 1;
145 @ranks = grep { !$common_rank{$_} } ( 1 .. $c->end->rank-1 );
148 # Group the variants to send to the solver
151 foreach my $rank ( @ranks ) {
152 my $missing = [ @lacunose ];
153 push( @groups, group_variants( $tradition, $rank, $missing, \@collapse ) );
154 $lacunae{$rank} = $missing;
158 my $answer = solve_variants( $stemma, @groups );
160 # Do further analysis on the answer
161 my $conflict_count = 0;
162 foreach my $idx ( 0 .. $#ranks ) {
163 my $location = $answer->{'variants'}->[$idx];
164 # Add the rank back in
165 $location->{'id'} = $ranks[$idx];
166 # Add the lacunae back in
167 $location->{'missing'} = $lacunae{$ranks[$idx]};
168 # Run the extra analysis we need.
169 analyze_location( $tradition, $stemma->graph, $location );
170 # Add the reading text back in
171 foreach my $rdghash ( @{$location->{'readings'}} ) {
173 if exists $rdghash->{'conflict'} && $rdghash->{'conflict'};
174 my $rdg = $c->reading( $rdghash->{'readingid'} );
175 $rdghash->{'text'} = $rdg ? $rdg->text : $rdghash->{'readingid'};
178 $answer->{'conflict_count'} = $conflict_count;
183 =head2 group_variants( $tradition, $rank, $lacunose, @merge_relationship_types )
185 Groups the variants at the given $rank of the collation, treating any
186 relationships in @merge_relationship_types as equivalent. $lacunose should
187 be a reference to an array, to which the sigla of lacunose witnesses at this
188 rank will be appended.
190 Returns two ordered lists $readings, $groups, where $readings->[$n] is attested
191 by the witnesses listed in $groups->[$n].
195 # Return group_readings, groups, lacunose
197 my( $tradition, $rank, $lacunose, $collapse ) = @_;
198 my $c = $tradition->collation;
199 my $aclabel = $c->ac_label;
200 # Get the alignment table readings
201 my %readings_at_rank;
203 foreach my $tablewit ( @{$c->alignment_table->{'alignment'}} ) {
204 my $rdg = $tablewit->{'tokens'}->[$rank-1];
205 my $wit = $tablewit->{'witness'};
206 if( $rdg && $rdg->{'t'}->is_lacuna ) {
207 _add_to_witlist( $wit, $lacunose, $aclabel );
209 $readings_at_rank{$rdg->{'t'}->text} = $rdg->{'t'};
211 _add_to_witlist( $wit, \@gap_wits, $aclabel );
215 # Group the readings, collapsing groups by relationship if needed
216 my %grouped_readings;
217 foreach my $rdg ( sort { $b->witnesses <=> $a->witnesses }
218 values %readings_at_rank ) {
219 # Skip readings that have been collapsed into others.
220 next if exists $grouped_readings{$rdg->id} && !$grouped_readings{$rdg->id};
221 my @wits = $rdg->witnesses;
223 my $filter = sub { my $r = $_[0]; grep { $_ eq $r->type } @$collapse; };
224 foreach my $other ( $rdg->related_readings( $filter ) ) {
225 my @otherwits = $other->witnesses;
226 push( @wits, @otherwits );
227 $grouped_readings{$other->id} = 0;
230 $grouped_readings{$rdg->id} = \@wits;
232 $grouped_readings{'(omitted)'} = \@gap_wits if @gap_wits;
233 # Get rid of our collapsed readings
234 map { delete $grouped_readings{$_} unless $grouped_readings{$_} }
235 keys %grouped_readings
238 return \%grouped_readings;
241 =head2 solve_variants( $graph, @groups )
243 Sends the set of groups to the external graph solver service and returns
244 a cleaned-up answer, adding the rank IDs back where they belong.
246 The JSON has the form
247 { "graph": [ stemmagraph DOT string without newlines ],
248 "groupings": [ array of arrays of groups, one per rank ] }
250 The answer has the form
251 { "variants" => [ array of variant location structures ],
252 "variant_count" => total,
253 "conflict_count" => number of conflicts detected,
254 "genealogical_count" => number of solutions found }
259 my( $stemma, @groups ) = @_;
261 # Make the json with stemma + groups
263 foreach my $ghash ( @groups ) {
265 foreach my $k ( keys %$ghash ) {
266 push( @grouping, $ghash->{$k} );
268 push( @$groupings, \@grouping );
270 ## Witness map is a HACK to get around limitations in node names from IDP
271 my $witness_map = {};
272 my $json = encode_json( _safe_wit_strings( $stemma, $groupings, $witness_map ) );
274 # Send it off and get the result
275 my $solver_url = 'http://byzantini.st/cgi-bin/graphcalc.cgi';
276 my $ua = LWP::UserAgent->new();
277 my $resp = $ua->post( $solver_url, 'Content-Type' => 'application/json',
278 'Content' => $json );
282 if( $resp->is_success ) {
283 $answer = _desanitize_names( decode_json( $resp->content ), $witness_map );
286 # Fall back to the old method.
287 warn "IDP solver returned " . $resp->status_line . " / " . $resp->content
288 . "; falling back to perl method";
289 $answer = perl_solver( $stemma, @$groupings );
292 # Fold the result back into what we know about the groups.
294 my $genealogical = 0;
295 foreach my $idx ( 0 .. $#groups ) {
296 my( $calc_groups, $result ) = @{$answer->[$idx]};
299 # Prune the calculated groups, in case the IDP solver failed to.
302 foreach my $cg ( @$calc_groups ) {
303 my @pg = _prune_group( $cg, $stemma );
304 push( @pruned_groups, \@pg );
306 $calc_groups = \@pruned_groups;
309 my $input_group = $groups[$idx];
310 foreach my $k ( sort keys %$input_group ) {
311 my $cg = shift @$calc_groups;
312 $input_group->{$k} = $cg;
315 'genealogical' => $result,
318 foreach my $k ( keys %$input_group ) {
319 push( @{$vstruct->{'readings'}},
320 { 'readingid' => $k, 'group' => $input_group->{$k}} );
322 push( @$variants, $vstruct );
325 return { 'variants' => $variants,
326 'variant_count' => scalar @$variants,
327 'genealogical_count' => $genealogical };
330 #### HACKERY to cope with IDP's limited idea of what a node name looks like ###
332 sub _safe_wit_strings {
333 my( $stemma, $groupings, $witness_map ) = @_;
334 my $safegraph = Graph->new();
335 # Convert the graph to a safe representation and store the conversion.
336 foreach my $n ( $stemma->graph->vertices ) {
337 my $sn = _safe_witstr( $n );
338 warn "Ambiguous stringification $sn for $n and " . $witness_map->{$sn}
339 if exists $witness_map->{$sn};
340 $witness_map->{$sn} = $n;
341 $safegraph->add_vertex( $sn );
342 $safegraph->set_vertex_attributes( $sn,
343 $stemma->graph->get_vertex_attributes( $n ) );
345 foreach my $e ( $stemma->graph->edges ) {
346 my @safe_e = ( _safe_witstr( $e->[0] ), _safe_witstr( $e->[1] ) );
347 $safegraph->add_edge( @safe_e );
349 my $safe_stemma = Text::Tradition::Stemma->new(
350 'collation' => $stemma->collation, 'graph' => $safegraph );
352 # Now convert the witness groupings to a safe representation.
353 my $safe_groupings = [];
354 foreach my $grouping ( @$groupings ) {
355 my $safe_grouping = [];
356 foreach my $group ( @$grouping ) {
358 foreach my $n ( @$group ) {
359 my $sn = _safe_witstr( $n );
360 warn "Ambiguous stringification $sn for $n and " . $witness_map->{$sn}
361 if exists $witness_map->{$sn} && $witness_map->{$sn} ne $n;
362 $witness_map->{$sn} = $n;
363 push( @$safe_group, $sn );
365 push( @$safe_grouping, $safe_group );
367 push( @$safe_groupings, $safe_grouping );
370 # Return it all in the struct we expect. We have stored the reductions
371 # in the $witness_map that we were passed.
372 return { 'graph' => $safe_stemma->editable( ' ' ), 'groupings' => $safe_groupings };
377 $witstr =~ s/\s+/_/g;
378 $witstr =~ s/[^\w\d-]//g;
382 sub _desanitize_names {
383 my( $jsonstruct, $witness_map ) = @_;
385 foreach my $grouping ( @$jsonstruct ) {
386 my $real_grouping = [];
387 foreach my $element ( @$grouping ) {
388 if( ref( $element ) eq 'ARRAY' ) {
390 my $real_groupset = [];
391 foreach my $group ( @$element ) {
393 foreach my $n ( @$group ) {
394 my $rn = $witness_map->{$n};
395 push( @$real_group, $rn );
397 push( @$real_groupset, $real_group );
399 push( @$real_grouping, $real_groupset );
401 # It is the boolean, not actually a group.
402 push( @$real_grouping, $element );
405 push( @$result, $real_grouping );
412 =head2 analyze_location ( $tradition, $graph, $location_hash )
414 Given the tradition, its stemma graph, and the solution from the graph solver,
415 work out the rest of the information we want. For each reading we need missing,
416 conflict, reading_parents, independent_occurrence, followed, not_followed, and follow_unknown. Alters the location_hash in place.
420 sub analyze_location {
421 my ( $tradition, $graph, $variant_row ) = @_;
423 # Make a hash of all known node memberships, and make the subgraphs.
425 my $reading_roots = {};
427 foreach my $rdghash ( @{$variant_row->{'readings'}} ) {
428 my $rid = $rdghash->{'readingid'};
429 map { $contig->{$_} = $rid } @{$rdghash->{'group'}};
432 my $part = $graph->copy;
434 map { $these_vertices{$_} = 1 } @{$rdghash->{'group'}};
435 $part->delete_vertices( grep { !$these_vertices{$_} } $part->vertices );
436 $subgraph->{$rid} = $part;
437 # Get the reading roots.
438 map { $reading_roots->{$_} = $rid } $part->predecessorless_vertices;
441 # Now that we have all the node group memberships, calculate followed/
442 # non-followed/unknown values for each reading. Also figure out the
443 # reading's evident parent(s).
444 foreach my $rdghash ( @{$variant_row->{'readings'}} ) {
445 # Group string key - TODO do we need this?
446 my $gst = wit_stringify( $rdghash->{'group'} );
447 my $rid = $rdghash->{'readingid'};
449 my $part = $subgraph->{$rid};
451 # Start figuring things out.
452 my @roots = $part->predecessorless_vertices;
453 $rdghash->{'independent_occurrence'} = scalar @roots;
454 $rdghash->{'followed'} = scalar( $part->vertices ) - scalar( @roots );
455 # Find the parent readings, if any, of this reading.
457 foreach my $wit ( @roots ) {
458 # Look in the main stemma to find this witness's extant or known-reading
459 # immediate ancestor(s), and look up the reading that each ancestor olds.
460 my @check = $graph->predecessors( $wit );
463 foreach my $wparent( @check ) {
464 my $preading = $contig->{$wparent};
466 $rdgparents{$preading} = 1;
468 push( @next, $graph->predecessors( $wparent ) );
474 $rdghash->{'reading_parents'} = [ keys %rdgparents ];
476 # Find the number of times this reading was altered, and the number of
477 # times we're not sure.
478 my( %nofollow, %unknownfollow );
479 foreach my $wit ( $part->vertices ) {
480 foreach my $wchild ( $graph->successors( $wit ) ) {
481 next if $part->has_vertex( $wchild );
482 if( $reading_roots->{$wchild} && $contig->{$wchild} ) {
483 # It definitely changed here.
484 $nofollow{$wchild} = 1;
485 } elsif( !($contig->{$wchild}) ) {
486 # The child is a hypothetical node not definitely in
487 # any group. Answer is unknown.
488 $unknownfollow{$wchild} = 1;
489 } # else it's a non-root node in a known group, and therefore
490 # is presumed to have its reading from its group, not this link.
493 $rdghash->{'not_followed'} = keys %nofollow;
494 $rdghash->{'follow_unknown'} = keys %unknownfollow;
496 # Now say whether this reading represents a conflict.
497 unless( $variant_row->{'genealogical'} ) {
498 $rdghash->{'conflict'} = @roots != 1;
504 =head2 perl_solver( $tradition, $rank, $stemma_id, @merge_relationship_types )
506 ** NOTE ** This method should hopefully not be called - it is not guaranteed
507 to be correct. Serves as a backup for the real solver.
509 Runs an analysis of the given tradition, at the location given in $rank,
510 against the graph of the stemma specified in $stemma_id. The argument
511 @merge_relationship_types is an optional list of relationship types for
512 which readings so related should be treated as equivalent.
514 Returns a nested array data structure as follows:
516 [ [ group_list, is_genealogical ], [ group_list, is_genealogical ] ... ]
518 where the group list is the array of arrays passed in for each element of @groups,
519 possibly with the addition of hypothetical readings.
525 my( $stemma, @groups ) = @_;
526 my $graph = $stemma->graph;
528 foreach my $g ( @groups ) {
529 push( @answer, _solve_variant_location( $graph, $g ) );
534 sub _solve_variant_location {
535 my( $graph, $groups ) = @_;
542 # Mark each ms as in its own group, first.
543 foreach my $g ( @$groups ) {
544 my $gst = wit_stringify( $g );
545 map { $contig->{$_} = $gst } @$g;
548 # Now for each unmarked node in the graph, initialize an array
549 # for possible group memberships. We will use this later to
550 # resolve potential conflicts.
551 map { $contig->{$_} = [] unless $contig->{$_} } $graph->vertices;
552 foreach my $g ( sort { scalar @$b <=> scalar @$a } @$groups ) {
553 my $gst = wit_stringify( $g ); # This is the group name
554 # Copy the graph, and delete all non-members from the new graph.
555 my $part = $graph->copy;
557 $part->delete_vertices(
558 grep { !ref( $contig->{$_} ) && $contig->{$_} ne $gst } $graph->vertices );
560 # Now look to see if our group is connected.
562 # We have to take directionality into account.
563 # How many root nodes do we have?
564 my @roots = grep { ref( $contig->{$_} ) || $contig->{$_} eq $gst }
565 $part->predecessorless_vertices;
566 # Assuming that @$g > 1, find the first root node that has at
567 # least one successor belonging to our group. If this reading
568 # is genealogical, there should be only one, but we will check
569 # that implicitly later.
570 foreach my $root ( @roots ) {
571 # Prune the tree to get rid of extraneous hypotheticals.
572 $root = _prune_subtree( $part, $root, $contig );
574 # Save this root for our group.
575 push( @group_roots, $root );
576 # Get all the successor nodes of our root.
579 # Dispense with the trivial case of one reading.
581 @group_roots = ( $wit );
582 foreach my $v ( $part->vertices ) {
583 $part->delete_vertex( $v ) unless $v eq $wit;
587 if( @group_roots > 1 ) {
588 $conflict->{$gst} = 1;
591 # Paint the 'hypotheticals' with our group.
592 foreach my $wit ( $part->vertices ) {
593 if( ref( $contig->{$wit} ) ) {
594 push( @{$contig->{$wit}}, $gst );
595 } elsif( $contig->{$wit} ne $gst ) {
596 warn "How did we get here?";
601 # Save the relevant subgraph.
602 $subgraph->{$gst} = $part;
605 # For each of our hypothetical readings, flatten its 'contig' array if
606 # the array contains zero or one group. If we have any unflattened arrays,
607 # we may need to run the resolution process. If the reading is already known
608 # to have a conflict, flatten the 'contig' array to nothing; we won't resolve
611 foreach my $wit ( keys %$contig ) {
612 next unless ref( $contig->{$wit} );
613 if( @{$contig->{$wit}} > 1 ) {
614 if( $is_conflicted ) {
615 $contig->{$wit} = ''; # We aren't going to decide.
617 push( @resolve, $wit );
620 my $gst = pop @{$contig->{$wit}};
621 $contig->{$wit} = $gst || '';
626 my $still_contig = {};
627 foreach my $h ( @resolve ) {
628 # For each of the hypothetical readings with more than one possibility,
629 # try deleting it from each of its member subgraphs in turn, and see
630 # if that breaks the contiguous grouping.
631 # TODO This can still break in a corner case where group A can use
632 # either vertex 1 or 2, and group B can use either vertex 2 or 1.
633 # Revisit this if necessary; it could get brute-force nasty.
634 foreach my $gst ( @{$contig->{$h}} ) {
635 my $gpart = $subgraph->{$gst}->copy();
636 # If we have come this far, there is only one root and everything
637 # is reachable from it.
638 my( $root ) = $gpart->predecessorless_vertices;
640 map { $reachable->{$_} = 1 } $gpart->vertices;
642 # Try deleting the hypothetical node.
643 $gpart->delete_vertex( $h );
645 # See if we still have a single root.
646 my @roots = $gpart->predecessorless_vertices;
647 warn "This shouldn't have happened" unless @roots;
649 # $h is needed by this group.
650 if( exists( $still_contig->{$h} ) ) {
652 $conflict->{$gst} = 1;
653 $still_contig->{$h} = '';
655 $still_contig->{$h} = $gst;
659 # $h is somewhere in the middle. See if everything
660 # else can still be reached from the root.
661 my %still_reachable = ( $root => 1 );
662 map { $still_reachable{$_} = 1 }
663 $gpart->all_successors( $root );
664 foreach my $v ( keys %$reachable ) {
666 if( !$still_reachable{$v}
667 && ( $contig->{$v} eq $gst
668 || ( exists $still_contig->{$v}
669 && $still_contig->{$v} eq $gst ) ) ) {
671 if( exists $still_contig->{$h} ) {
673 $conflict->{$gst} = 1;
674 $still_contig->{$h} = '';
676 $still_contig->{$h} = $gst;
679 } # else we don't need $h in this group.
681 } # endif $h eq $root
685 # Now we have some hypothetical vertices in $still_contig that are the
686 # "real" group memberships. Replace these in $contig.
687 foreach my $v ( keys %$contig ) {
688 next unless ref $contig->{$v};
689 $contig->{$v} = $still_contig->{$v};
693 my $is_genealogical = keys %$conflict ? JSON::false : JSON::true;
694 my $variant_row = [ [], $is_genealogical ];
695 # Fill in the groupings from $contig.
696 foreach my $g ( @$groups ) {
697 my $gst = wit_stringify( $g );
698 my @realgroup = grep { $contig->{$_} eq $gst } keys %$contig;
699 push( @{$variant_row->[0]}, \@realgroup );
705 my( $group, $stemma ) = @_;
706 # Get these into a form prune_subtree will recognize. Make a "contighash"
708 map { $hypohash->{$_} = 1 } @$group;
709 # ...with reference values for hypotheticals.
710 map { $hypohash->{$_} = [] } $stemma->hypotheticals;
712 my $subgraph = $stemma->graph->copy;
713 map { $subgraph->delete_vertex( $_ ) unless exists $hypohash->{$_} }
715 # ...and find the root.
716 my( $root ) = $subgraph->predecessorless_vertices;
717 # Now prune and return the remaining vertices.
718 _prune_subtree( $subgraph, $root, $hypohash );
719 return $subgraph->vertices;
723 my( $tree, $root, $contighash ) = @_;
724 # First, delete hypothetical leaves / orphans until there are none left.
725 my @orphan_hypotheticals = grep { ref( $contighash->{$_} ) }
726 $tree->successorless_vertices;
727 while( @orphan_hypotheticals ) {
728 $tree->delete_vertices( @orphan_hypotheticals );
729 @orphan_hypotheticals = grep { ref( $contighash->{$_} ) }
730 $tree->successorless_vertices;
732 # Then delete a hypothetical root with only one successor, moving the
733 # root to the first child that has no other predecessors.
734 while( $tree->successors( $root ) == 1 && ref $contighash->{$root} ) {
735 my @nextroot = $tree->successors( $root );
736 $tree->delete_vertex( $root );
737 ( $root ) = grep { $tree->is_predecessorless_vertex( $_ ) } @nextroot;
739 # The tree has been modified in place, but we need to know the new root.
740 $root = undef unless $root && $tree->has_vertex( $root );
743 # Add the variant, subject to a.c. representation logic.
744 # This assumes that we will see the 'main' version before the a.c. version.
745 sub add_variant_wit {
746 my( $arr, $wit, $acstr ) = @_;
748 if( $wit =~ /^(.*)\Q$acstr\E$/ ) {
750 $skip = grep { $_ =~ /^\Q$real\E$/ } @$arr;
752 push( @$arr, $wit ) unless $skip;
755 sub _useful_variant {
756 my( $group_readings, $graph, $acstr ) = @_;
758 # TODO Decide what to do with AC witnesses
760 # Sort by group size and return
762 my( @readings, @groups ); # The sorted groups for our answer.
763 foreach my $rdg ( sort { @{$group_readings->{$b}} <=> @{$group_readings->{$a}} }
764 keys %$group_readings ) {
765 push( @readings, $rdg );
766 push( @groups, $group_readings->{$rdg} );
767 if( @{$group_readings->{$rdg}} > 1 ) {
770 my( $wit ) = @{$group_readings->{$rdg}};
771 $wit =~ s/^(.*)\Q$acstr\E$/$1/;
772 $is_useful++ unless( $graph->is_sink_vertex( $wit ) );
775 if( $is_useful > 1 ) {
776 return( \@readings, \@groups );
782 =head2 wit_stringify( $groups )
784 Takes an array of witness groupings and produces a string like
785 ['A','B'] / ['C','D','E'] / ['F']
792 # If we were passed an array of witnesses instead of an array of
793 # groupings, then "group" the witnesses first.
794 unless( ref( $groups->[0] ) ) {
795 my $mkgrp = [ $groups ];
798 foreach my $g ( @$groups ) {
799 push( @gst, '[' . join( ',', map { "'$_'" } @$g ) . ']' );
801 return join( ' / ', @gst );
804 # Helper function to ensure that X and X a.c. never appear in the same list.
805 sub _add_to_witlist {
806 my( $wit, $list, $acstr ) = @_;
809 map { $inlist{$_} = $idx++ } @$list;
810 if( $wit =~ /^(.*)\Q$acstr\E$/ ) {
812 unless( exists $inlist{$acwit} ) {
813 push( @$list, $acwit.$acstr );
816 if( exists( $inlist{$wit.$acstr} ) ) {
817 # Replace the a.c. version with the main witness
818 my $i = $inlist{$wit.$acstr};
821 push( @$list, $wit );
827 my( $lista, $listb ) = @_;
830 map { $union{$_} = 1; $scalars{$_} = $_ } @$lista;
831 map { $union{$_} += 1; $scalars{$_} = $_ } @$listb;
832 my @set = grep { $union{$_} == 1 } keys %union;
833 return map { $scalars{$_} } @set;
840 This package is free software and is provided "as is" without express
841 or implied warranty. You can redistribute it and/or modify it under
842 the same terms as Perl itself.
846 Tara L Andrews E<lt>aurum@cpan.orgE<gt>