9 use Text::Tradition::Analysis qw/ run_analysis /;
11 binmode STDOUT, ':utf8';
12 binmode STDERR, ':utf8';
13 eval { no warnings; binmode $DB::OUT, ':utf8'; $DB::deep = 1000 };
15 my $tradition = Text::Tradition->new(
17 'file' => 't/data/besoin.xml' );
18 $tradition->add_stemma( 'dotfile' => 't/data/besoin.dot' );
20 # Run the analysis of the tradition
21 my $results = run_analysis( $tradition );
87 # Look through the results
88 my $display = $ARGV[0];
89 my $c = $tradition->collation;
90 foreach my $row ( @{$results->{'variants'}} ) {
92 say sprintf( "=== Looking at rank %d (%s) ===", $row->{'id'},
93 $row->{'genealogical'} ? 'genealogical' : 'not genealogical' );
94 foreach my $rdg ( @{$row->{'readings'}} ) {
95 my $parents = $rdg->{'reading_parents'};
96 say sprintf( "Reading %s: %s", $rdg->{'readingid'},
97 $rdg->{'conflict'} ? '(conflicted)' : '' );
98 if( $parents && @$parents ) {
99 say "\tParent reading(s) " . join( ', ', @$parents );
100 foreach my $p ( @$parents ) {
101 # Is there a relationship here?
102 my $rel = $c->get_relationship( $rdg->{'readingid'}, $p );
104 say sprintf( "\t* Relationship %s %s to parent %s",
106 $rel->annotation ? '('.$rel->annotation.')' : '',
111 say sprintf( "\t%d independent, %d followed, %d changed, %d unknown",
112 $rdg->{'independent_occurrence'}, $rdg->{'followed'},
113 $rdg->{'not_followed'}, $rdg->{'follow_unknown'} );
116 # If not displaying, we're testing.
117 # HACK to cope with formerly unuseful rows
118 unless( exists $expected{$row->{'id'}} ) {
119 $expected{$row->{'id'}} = 1;
121 my $gen_bool = $row->{'genealogical'} ? 1 : '';
122 is( $gen_bool, $expected{$row->{'id'}},
123 "Got expected genealogical result for rank " . $row->{'id'} );
124 # If the row is genealogical, there should be one reading with no parents,
125 # every reading should independently occur exactly once, and the total
126 # number of changes + maybe-changes should equal the total number of
127 # readings who have that one as a parent.
128 if( $row->{'genealogical'} ) {
129 # Make the mapping of parent -> child readings
132 foreach my $rdg ( @{$row->{'readings'}} ) {
133 my $parents = $rdg->{'reading_parents'} || [];
134 foreach my $p ( @$parents ) {
135 push( @{$is_parent{$p}}, $rdg->{'readingid'} );
137 push( @has_no_parent, $rdg->{'readingid'} ) unless @$parents;
140 foreach my $rdg ( @{$row->{'readings'}} ) {
141 is( $rdg->{'independent_occurrence'}, 1,
142 "Genealogical reading originates exactly once" );
144 is( @has_no_parent, 1, "Only one genealogical reading lacks a parent" );
148 done_testing() unless $display;