1 package Traditions::Graph::Position;
8 Traditions::Graph::Position
12 An object to go with a text graph that keeps track of relative
13 positions of the nodes.
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
29 my( $common_nodes, $witness_paths ) = @_;
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.
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.
46 my $cn = 0; # We should hit the common nodes in order.
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.
53 push( @$wit_matrix, $row ) if scalar( @$row );
58 push( @$wit_matrix, $row ); # Push the last row onto the matrix
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.
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.
81 # Now we have a hash of node positions keyed on node.
82 $self->{'node_positions'} = $node_pos;
83 $self->{'witness_paths'} = $witness_paths;
85 bless( $self, $proto );
90 my( $self, $node ) = @_;
91 $node = _name( $node );
93 unless( exists( $self->{'node_positions'}->{ $node } ) ) {
94 warn "No node with name $node known to the graph";
98 return $self->{'node_positions'}->{ $node };
101 sub nodes_at_position {
102 my( $self, $pos ) = @_;
104 my $positions = $self->calc_positions();
105 unless( exists $positions->{ $pos } ) {
106 warn "No position $pos in the graph";
109 return @{ $positions->{ $pos }};
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 );
118 my @cn = grep { $_ !~ /^$node$/ } @loc_nodes;
124 my $pos = $self->calc_positions;
125 return sort by_position keys( %$pos );
129 my( $self, $wit ) = @_;
130 return @{$self->{'witness_paths'}->{ $wit }};
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.
138 return _invert_hash( $self->{'node_positions'} )
141 # Helper for dealing with node refs
144 # We work with node names in this library
145 if( ref( $node ) && ref( $node ) eq 'Graph::Easy::Node' ) {
146 $node = $node->name();
151 ### Comparison functions
153 # Compares two nodes according to their positions in the witness
157 return _cmp_position( $a, $b );
160 # Takes two position strings (X,Y) and sorts them.
163 my @pos_a = split(/,/, $a );
164 my @pos_b = split(/,/, $b );
166 my $big_cmp = $pos_a[0] <=> $pos_b[0];
167 return $big_cmp if $big_cmp;
169 return $pos_a[1] <=> $pos_b[1];
172 # Useful helper. Will be especially useful if I find myself using
173 # scalar references for the positions after all - it can dereference
176 my ( $hash, $plaintext_keys ) = @_;
178 foreach my $key ( keys %$hash ) {
179 my $val = $hash->{$key};
183 $valkey = $plaintext_keys->{ scalar( $val ) };
184 warn( "No plaintext value given for $val" ) unless $valkey;
186 if( exists ( $new_hash{$valkey} ) ) {
187 push( @{$new_hash{$valkey}}, $key );
189 $new_hash{$valkey} = [ $key ];