new library working with old graph functionality tests
[scpubgit/stemmatology.git] / lib / Traditions / Graph / Position.pm
1 package Traditions::Graph::Position;
2
3 use strict;
4 use warnings;
5
6 =head1 NAME
7
8 Traditions::Graph::Position
9
10 =head1 SUMMARY
11
12 An object to go with a text graph that keeps track of relative
13 positions of the nodes.
14
15 =head1 METHODS
16
17 =over 4
18
19 =item B<new>
20
21 Takes two arguments: a list of names of common nodes in the graph, and
22 a list of witness paths.  Calculates position identifiers for each
23 node based on this.
24
25 =cut
26
27 sub new {
28     my $proto = shift;
29     my( $common_nodes, $witness_paths ) = @_;
30
31     my $self = {};
32
33     # We have to calculate the position identifiers for each word,
34     # keyed on the common nodes.  This will be 'fun'.  The end result
35     # is a hash per witness, whose key is the word node and whose
36     # value is its position in the text.  Common nodes are always N,1
37     # so have identical positions in each text.
38
39     my $node_pos = {};
40     foreach my $wit ( keys %$witness_paths ) {
41         # First we walk each path, making a matrix for each witness that
42         # corresponds to its eventual position identifier.  Common nodes
43         # always start a new row, and are thus always in the first column.
44
45         my $wit_matrix = [];
46         my $cn = 0;  # We should hit the common nodes in order.
47         my $row = [];
48         foreach my $wn ( @{$witness_paths->{$wit}} ) { # $wn is a node name
49             if( $wn eq $common_nodes->[$cn] ) {
50                 # Set up to look for the next common node, and
51                 # start a new row of words.
52                 $cn++;
53                 push( @$wit_matrix, $row ) if scalar( @$row );
54                 $row = [];
55             }
56             push( @$row, $wn );
57         }
58         push( @$wit_matrix, $row );  # Push the last row onto the matrix
59
60         # Now we have a matrix per witness, so that each row in the
61         # matrix begins with a common node, and continues with all the
62         # variant words that appear in the witness.  We turn this into
63         # real positions in row,cell format.  But we need some
64         # trickery in order to make sure that each node gets assigned
65         # to only one position.
66
67         foreach my $li ( 1..scalar(@$wit_matrix) ) {
68             foreach my $di ( 1..scalar(@{$wit_matrix->[$li-1]}) ) {
69                 my $node = $wit_matrix->[$li-1]->[$di-1];
70                 my $position = "$li,$di";
71                 # If we have seen this node before, we need to compare
72                 # its position with what went before.
73                 unless( exists $node_pos->{ $node } && 
74                         _cmp_position( $position, $node_pos->{ $node }) < 1 ) {
75                     # The new position ID replaces the old one.
76                     $node_pos->{$node} = $position;
77                 } # otherwise, the old position needs to stay.
78             }
79         }
80     }
81     # Now we have a hash of node positions keyed on node.
82     $self->{'node_positions'} = $node_pos;
83     $self->{'witness_paths'} = $witness_paths;
84
85     bless( $self, $proto );
86     return $self;
87 }
88
89 sub node_position {
90     my( $self, $node ) = @_;
91     $node = _name( $node );
92
93     unless( exists( $self->{'node_positions'}->{ $node } ) ) {
94         warn "No node with name $node known to the graph";
95         return;
96     }
97
98     return $self->{'node_positions'}->{ $node };
99 }
100
101 sub nodes_at_position {
102     my( $self, $pos ) = @_;
103
104     my $positions = $self->calc_positions();
105     unless( exists $positions->{ $pos } ) {
106         warn "No position $pos in the graph";
107         return;
108     }
109     return @{ $positions->{ $pos }};
110 }
111
112 sub colocated_nodes {
113     my( $self, $node ) = @_;
114     $node = _name( $node );
115     my $pos = $self->node_position( $node );
116     my @loc_nodes = $self->nodes_at_position( $pos );
117
118     my @cn = grep { $_ !~ /^$node$/ } @loc_nodes;
119     return @cn;
120 }
121
122 sub all {
123     my( $self ) = @_;
124     my $pos = $self->calc_positions;
125     return sort by_position keys( %$pos );
126 }
127
128 sub witness_path {
129     my( $self, $wit ) = @_;
130     return @{$self->{'witness_paths'}->{ $wit }};
131 }
132
133 # At some point I may find myself using scalar references for the node
134 # positions, in order to keep them easily in sync.  Just in case, I will
135 # calculate this every time I need it.
136 sub calc_positions {
137     my $self = shift;
138     return _invert_hash( $self->{'node_positions'} )
139 }
140
141 # Helper for dealing with node refs
142 sub _name {
143     my( $node ) = @_;
144     # We work with node names in this library
145     if( ref( $node ) && ref( $node ) eq 'Graph::Easy::Node' ) {
146         $node = $node->name();
147     }
148     return $node;
149 }
150
151 ### Comparison functions
152
153 # Compares two nodes according to their positions in the witness 
154 # index hash.
155 sub by_position {
156     my $self = shift;
157     return _cmp_position( $a, $b );
158 }
159
160 # Takes two position strings (X,Y) and sorts them.
161 sub _cmp_position {
162     my( $a, $b ) = @_;
163     my @pos_a = split(/,/, $a );
164     my @pos_b = split(/,/, $b );
165
166     my $big_cmp = $pos_a[0] <=> $pos_b[0];
167     return $big_cmp if $big_cmp;
168     # else 
169     return $pos_a[1] <=> $pos_b[1];
170 }
171
172 # Useful helper.  Will be especially useful if I find myself using
173 # scalar references for the positions after all - it can dereference
174 # them here.
175 sub _invert_hash {
176     my ( $hash, $plaintext_keys ) = @_;
177     my %new_hash;
178     foreach my $key ( keys %$hash ) {
179         my $val = $hash->{$key};
180         my $valkey = $val;
181         if( $plaintext_keys 
182             && ref( $val ) ) {
183             $valkey = $plaintext_keys->{ scalar( $val ) };
184             warn( "No plaintext value given for $val" ) unless $valkey;
185         }
186         if( exists ( $new_hash{$valkey} ) ) {
187             push( @{$new_hash{$valkey}}, $key );
188         } else {
189             $new_hash{$valkey} = [ $key ];
190         }
191     }
192     return \%new_hash;
193 }
194
195 1;