Commit | Line | Data |
b49c4318 |
1 | #!/usr/bin/perl |
2 | |
3 | use strict; use warnings; |
4 | use Test::More; |
5 | use lib 'lib'; |
8e1394aa |
6 | use Text::Tradition; |
b49c4318 |
7 | use XML::LibXML; |
8 | use XML::LibXML::XPathContext; |
9 | |
10 | my $datafile = 't/data/Collatex-16.xml'; |
11 | |
12 | open( GRAPHFILE, $datafile ) or die "Could not open $datafile"; |
13 | my @lines = <GRAPHFILE>; |
14 | close GRAPHFILE; |
ec3f9144 |
15 | my $tradition = Text::Tradition->new( 'CollateX' => join( '', @lines ) ); |
8e1394aa |
16 | my $collation = $tradition->collation; |
b49c4318 |
17 | |
18 | # Test the svg creation |
19 | my $parser = XML::LibXML->new(); |
20 | $parser->load_ext_dtd( 0 ); |
8e1394aa |
21 | my $svg = $parser->parse_string( $collation->as_svg() ); |
b49c4318 |
22 | is( $svg->documentElement->nodeName(), 'svg', 'Got an svg document' ); |
23 | |
24 | # Test for the correct number of nodes in the SVG |
25 | my $svg_xpc = XML::LibXML::XPathContext->new( $svg->documentElement() ); |
26 | $svg_xpc->registerNs( 'svg', 'http://www.w3.org/2000/svg' ); |
27 | my @svg_nodes = $svg_xpc->findnodes( '//svg:g[@class="node"]' ); |
3265b0ce |
28 | is( scalar @svg_nodes, 26, "Correct number of nodes in the graph" ); |
b49c4318 |
29 | |
30 | # Test for the correct number of edges |
31 | my @svg_edges = $svg_xpc->findnodes( '//svg:g[@class="edge"]' ); |
3265b0ce |
32 | is( scalar @svg_edges, 32, "Correct number of edges in the graph" ); |
b49c4318 |
33 | |
34 | # Test for the correct common nodes |
b15511bf |
35 | my @common_nodes = ( '#START#' ); |
36 | push( @common_nodes, qw/ n1 n5 n6 n7 n12 n16 n19 n20 n27 / ); |
37 | my @expected_nodes = map { [ $_, 1 ] } @common_nodes; |
3265b0ce |
38 | foreach my $idx ( qw/2 3 4 8 10 11 13 16 17 18/ ) { |
b49c4318 |
39 | splice( @expected_nodes, $idx, 0, [ "node_null", undef ] ); |
40 | } |
3a1f2523 |
41 | my @active_nodes = $collation->lemma_readings(); |
b49c4318 |
42 | subtest 'Initial common points' => \&compare_active; |
3265b0ce |
43 | my $string = '# when ... ... ... showers sweet with ... fruit ... ... of ... has pierced ... ... ... #'; |
b49c4318 |
44 | is( make_text( @active_nodes ), $string, "Got the right starting text" ); |
45 | |
46 | sub compare_active { |
47 | is( scalar( @active_nodes ), scalar ( @expected_nodes ), |
48 | "Arrays are same length" ); |
49 | |
50 | foreach ( 0 .. scalar(@active_nodes)-1 ) { |
51 | is( $active_nodes[$_]->[1], $expected_nodes[$_]->[1], |
52 | "Element has same toggle value" ); |
53 | if( defined $active_nodes[$_]->[1] ) { |
54 | is( $active_nodes[$_]->[0], $expected_nodes[$_]->[0], |
de51424a |
55 | "Active or toggled element has same node name " |
56 | . $active_nodes[$_]->[0] ); |
b49c4318 |
57 | } |
58 | } |
59 | } |
60 | |
61 | sub make_text { |
62 | my @words; |
63 | foreach my $n ( @_ ) { |
64 | if( $n->[1] ) { |
3a1f2523 |
65 | push( @words, $collation->reading( $n->[0] )->label ); |
b49c4318 |
66 | } elsif ( !defined $n->[1] ) { |
67 | push( @words, '...' ); |
68 | } |
69 | } |
70 | return join( ' ', @words ); |
71 | } |
72 | |
b15511bf |
73 | # Test that the common nodes are marked common |
74 | foreach my $cn ( @common_nodes ) { |
75 | ok( $collation->reading( $cn )->is_common, "Node $cn is marked common" ); |
76 | } |
77 | |
b49c4318 |
78 | # Test the manuscript paths |
79 | my $wit_a = '# when april with his showers sweet with fruit the drought of march has pierced unto the root #'; |
80 | my $wit_b = '# when showers sweet with april fruit the march of drought has pierced to the root #'; |
3265b0ce |
81 | my $wit_c = '# when showers sweet with april fruit teh drought of march has pierced teh rood #'; |
de51424a |
82 | is( join( ' ', @{$tradition->witness( "A" )->text} ), $wit_a, "Correct path for witness A" ); |
83 | is( join( ' ', @{$tradition->witness( "B" )->text} ), $wit_b, "Correct path for witness B" ); |
84 | is( join( ' ', @{$tradition->witness( "C" )->text} ), $wit_c, "Correct path for witness C" ); |
b49c4318 |
85 | |
86 | # Test the transposition identifiers |
c557b209 |
87 | my $transposition_pools = [ [ 'n2', 'n11' ], [ 'n14', 'n18' ], |
88 | [ 'n17', 'n15' ] ]; |
89 | my $transposed_nodes = { 'n2' => $transposition_pools->[0], |
90 | 'n11' => $transposition_pools->[0], |
91 | 'n14' => $transposition_pools->[1], |
92 | 'n15' => $transposition_pools->[2], |
93 | 'n17' => $transposition_pools->[2], |
94 | 'n18' => $transposition_pools->[1], |
b49c4318 |
95 | }; |
de51424a |
96 | |
97 | my $real_transposed_nodes = {}; |
98 | foreach my $r ( $collation->readings ) { |
99 | my @same = map { $_->name } @{$r->same_as}; |
100 | $real_transposed_nodes->{ $r->name } = \@same if @same > 1; |
c2d16875 |
101 | } |
de51424a |
102 | |
103 | is_deeply( $real_transposed_nodes, $transposed_nodes, "Found the right transpositions" ); |
b49c4318 |
104 | |
105 | # Test turning on a node |
3265b0ce |
106 | my @off = $collation->toggle_reading( 'n21' ); |
107 | $expected_nodes[ 16 ] = [ "n21", 1 ]; |
de51424a |
108 | @active_nodes = $collation->lemma_readings( @off ); |
b49c4318 |
109 | subtest 'Turned on node for new location' => \&compare_active; |
3265b0ce |
110 | $string = '# when ... ... ... showers sweet with ... fruit ... ... of ... has pierced unto ... ... #'; |
b49c4318 |
111 | is( make_text( @active_nodes ), $string, "Got the right text" ); |
112 | |
113 | # Test the toggling effects of same-column |
3265b0ce |
114 | @off = $collation->toggle_reading( 'n22' ); |
115 | splice( @expected_nodes, 16, 1, ( [ "n21", 0 ], [ "n22", 1 ] ) ); |
de51424a |
116 | @active_nodes = $collation->lemma_readings( @off ); |
b49c4318 |
117 | subtest 'Turned on other node in that location' => \&compare_active; |
3265b0ce |
118 | $string = '# when ... ... ... showers sweet with ... fruit ... ... of ... has pierced to ... ... #'; |
b49c4318 |
119 | is( make_text( @active_nodes ), $string, "Got the right text" ); |
120 | |
121 | # Test the toggling effects of transposition |
122 | |
de51424a |
123 | @off = $collation->toggle_reading( 'n14' ); |
b49c4318 |
124 | # Add the turned on node |
c557b209 |
125 | $expected_nodes[ 11 ] = [ "n14", 1 ]; |
58a3c424 |
126 | # Remove the 'off' for the previous node |
3265b0ce |
127 | splice( @expected_nodes, 16, 1 ); |
de51424a |
128 | @active_nodes = $collation->lemma_readings( @off ); |
b49c4318 |
129 | subtest 'Turned on transposition node' => \&compare_active; |
3265b0ce |
130 | $string = '# when ... ... ... showers sweet with ... fruit ... drought of ... has pierced to ... ... #'; |
b49c4318 |
131 | is( make_text( @active_nodes ), $string, "Got the right text" ); |
132 | |
de51424a |
133 | @off = $collation->toggle_reading( 'n18' ); |
58a3c424 |
134 | # Toggle on the new node |
c557b209 |
135 | $expected_nodes[ 13 ] = [ "n18", 1 ]; |
58a3c424 |
136 | # Toggle off the transposed node |
c557b209 |
137 | $expected_nodes[ 11 ] = [ "n14", undef ]; |
de51424a |
138 | @active_nodes = $collation->lemma_readings( @off ); |
b49c4318 |
139 | subtest 'Turned on that node\'s partner' => \&compare_active; |
3265b0ce |
140 | $string = '# when ... ... ... showers sweet with ... fruit ... ... of drought has pierced to ... ... #'; |
b49c4318 |
141 | is( make_text( @active_nodes ), $string, "Got the right text" ); |
142 | |
de51424a |
143 | @off = $collation->toggle_reading( 'n14' ); |
58a3c424 |
144 | # Toggle on the new node |
c557b209 |
145 | $expected_nodes[ 11 ] = [ "n14", 1 ]; |
58a3c424 |
146 | # Toggle off the transposed node |
c557b209 |
147 | $expected_nodes[ 13 ] = [ "n18", undef ]; |
de51424a |
148 | @active_nodes = $collation->lemma_readings( @off ); |
b49c4318 |
149 | subtest 'Turned on the original node' => \&compare_active; |
3265b0ce |
150 | $string = '# when ... ... ... showers sweet with ... fruit ... drought of ... has pierced to ... ... #'; |
b49c4318 |
151 | is( make_text( @active_nodes ), $string, "Got the right text" ); |
152 | |
de51424a |
153 | @off = $collation->toggle_reading( 'n15' ); |
58a3c424 |
154 | # Toggle on the new node, and off with the old |
c557b209 |
155 | splice( @expected_nodes, 11, 1, [ "n14", 0 ], [ "n15", 1 ] ); |
de51424a |
156 | @active_nodes = $collation->lemma_readings( @off ); |
58a3c424 |
157 | subtest 'Turned on the colocated node' => \&compare_active; |
3265b0ce |
158 | $string = '# when ... ... ... showers sweet with ... fruit ... march of ... has pierced to ... ... #'; |
58a3c424 |
159 | is( make_text( @active_nodes ), $string, "Got the right text" ); |
160 | |
de51424a |
161 | @off = $collation->toggle_reading( 'n3' ); |
58a3c424 |
162 | # Toggle on the new node |
c557b209 |
163 | splice( @expected_nodes, 3, 1, [ "n3", 1 ] ); |
58a3c424 |
164 | # Remove the old toggle-off |
c557b209 |
165 | splice( @expected_nodes, 11, 1 ); |
de51424a |
166 | @active_nodes = $collation->lemma_readings( @off ); |
b49c4318 |
167 | subtest 'Turned on a singleton node' => \&compare_active; |
3265b0ce |
168 | $string = '# when ... with ... showers sweet with ... fruit ... march of ... has pierced to ... ... #'; |
b49c4318 |
169 | is( make_text( @active_nodes ), $string, "Got the right text" ); |
170 | |
de51424a |
171 | @off = $collation->toggle_reading( 'n3' ); |
58a3c424 |
172 | # Toggle off this node |
c557b209 |
173 | splice( @expected_nodes, 3, 1, [ "n3", 0 ] ); |
de51424a |
174 | @active_nodes = $collation->lemma_readings( @off ); |
b49c4318 |
175 | subtest 'Turned off a singleton node' => \&compare_active; |
3265b0ce |
176 | $string = '# when ... ... showers sweet with ... fruit ... march of ... has pierced to ... ... #'; |
58a3c424 |
177 | is( make_text( @active_nodes ), $string, "Got the right text" ); |
178 | |
de51424a |
179 | @off = $collation->toggle_reading( 'n21' ); |
3265b0ce |
180 | splice( @expected_nodes, 16, 1, ["n22", 0 ], [ "n21", 1 ] ); |
de51424a |
181 | @active_nodes = $collation->lemma_readings( @off ); |
3265b0ce |
182 | subtest 'Turned on another node after singleton switchoff' => \&compare_active; |
183 | $string = '# when ... ... showers sweet with ... fruit ... march of ... has pierced unto ... ... #'; |
b49c4318 |
184 | is( make_text( @active_nodes ), $string, "Got the right text" ); |
185 | |
b15511bf |
186 | # Now start testing some position identifiers |
187 | # 2. 'april with his' have no colocated |
188 | # 3. 'april' 2 has no colocated |
189 | # 4. 'teh' and 'the' |
190 | # 5. 'drought' & 'march' |
191 | # 6. 'march' & 'drought' |
192 | # 7. 'unto' 'the' 'root'... |
193 | # 'unto can match 'to' or 'teh' |
194 | # 'the' can match 'teh' or 'rood' |
195 | # 'root' can mach 'rood' |
196 | |
197 | foreach my $cn ( @common_nodes ) { |
198 | my $cnr = $collation->reading( $cn ); |
199 | is( scalar( $collation->same_position_as( $cnr ) ), 0, "Node $cn has no colocations" ); |
200 | } |
201 | |
202 | my %expected_colocations = ( |
203 | 'n2' => [], # april |
204 | 'n3' => [], # with |
205 | 'n4' => [], # his |
206 | 'n11' => [], # april |
207 | 'n8' => [ 'n13' ], # teh -> the |
208 | 'n13' => [ 'n8' ], # the -> teh |
209 | 'n14' => [ 'n15' ], # drought -> march |
210 | 'n18' => [ 'n17' ], # drought -> march |
211 | 'n17' => [ 'n18' ], # march -> drought |
212 | 'n15' => [ 'n14' ], # march -> drought |
213 | 'n21' => [ 'n9', 'n22' ], # unto -> to, teh |
214 | 'n22' => [ 'n9', 'n21' ], # to -> unto, teh |
215 | 'n9' => [ 'n21', 'n22', 'n23' ], # teh -> unto, to, the |
216 | 'n23' => [ 'n9', 'n25' ], # the -> teh, rood |
217 | 'n25' => [ 'n9', 'n26' ], # rood -> the, root |
218 | 'n26' => [ 'n25' ], # root -> rood |
219 | ); |
220 | |
221 | foreach my $n ( keys %expected_colocations ) { |
222 | my $nr = $collation->reading( $n ); |
223 | my @colocated = sort( map { $_->name } $collation->same_position_as( $nr ) ); |
224 | is_deeply( \@colocated, $expected_colocations{$n}, "Colocated nodes for $n correct" ); |
225 | } |
226 | |
b49c4318 |
227 | done_testing(); |