1package Graph::AdjacencyMap;
2
3use strict;
4
5require Exporter;
6use vars qw(@ISA @EXPORT_OK %EXPORT_TAGS);
7@ISA = qw(Exporter);
8@EXPORT_OK   = qw(_COUNT _MULTI _COUNTMULTI _GEN_ID
9		  _HYPER _UNORD _UNIQ _REF _UNORDUNIQ _UNIONFIND _LIGHT
10		  _STR _REFSTR
11		  _n _f _a _i _s _p _g _u _ni _nc _na _nm);
12%EXPORT_TAGS =
13    (flags =>  [qw(_COUNT _MULTI _COUNTMULTI _GEN_ID
14		   _HYPER _UNORD _UNIQ _REF _UNORDUNIQ _UNIONFIND _LIGHT
15		   _STR _REFSTR)],
16     fields => [qw(_n _f _a _i _s _p _g _u _ni _nc _na _nm)]);
17
18sub _COUNT       () {  0x00000001   }
19sub _MULTI       () {  0x00000002   }
20sub _COUNTMULTI  () { _COUNT|_MULTI }
21sub _HYPER       () {  0x00000004   }
22sub _UNORD       () {  0x00000008   }
23sub _UNIQ        () {  0x00000010   }
24sub _REF         () {  0x00000020   }
25sub _UNORDUNIQ   () { _UNORD|_UNIQ  }
26sub _UNIONFIND   () {  0x00000040   }
27sub _LIGHT       () {  0x00000080   }
28sub _STR         () {  0x00000100   }
29sub _REFSTR      () { _REF|_STR     }
30
31my $_GEN_ID = 0;
32
33sub _GEN_ID () { \$_GEN_ID }
34
35sub _ni () { 0 } # Node index.
36sub _nc () { 1 } # Node count.
37sub _na () { 2 } # Node attributes.
38sub _nm () { 3 } # Node map.
39
40sub _n () { 0 } # Next id.
41sub _f () { 1 } # Flags.
42sub _a () { 2 } # Arity.
43sub _i () { 3 } # Index to path.
44sub _s () { 4 } # Successors / Path to Index.
45sub _p () { 5 } # Predecessors.
46sub _g () { 6 } # Graph (AdjacencyMap::Light)
47
48sub _V () { 2 }  # Graph::_V()
49
50sub _new {
51    my $class = shift;
52    my $map = bless [ 0, @_ ], $class;
53    return $map;
54}
55
56sub _ids {
57    my $m = shift;
58    return $m->[ _i ];
59}
60
61sub has_paths {
62    my $m = shift;
63    return defined $m->[ _i ] && keys %{ $m->[ _i ] };
64}
65
66sub _dump {
67    my $d = Data::Dumper->new([$_[0]],[ref $_[0]]);
68    defined wantarray ? $d->Dump : print $d->Dump;
69}
70
71sub _del_id {
72    my ($m, $i) = @_;
73    my @p = $m->_get_id_path( $i );
74    $m->del_path( @p ) if @p;
75}
76
77sub _new_node {
78    my ($m, $n, $id) = @_;
79    my $f = $m->[ _f ];
80    my $i = $m->[ _n ]++;
81    if (($f & _MULTI)) {
82	$id = 0 if $id eq _GEN_ID;
83	$$n = [ $i, 0, undef, { $id => { } } ];
84    } elsif (($f & _COUNT)) {
85	$$n = [ $i, 1 ];
86    } else {
87	$$n = $i;
88    }
89    return $i;
90}
91
92sub _inc_node {
93    my ($m, $n, $id) = @_;
94    my $f = $m->[ _f ];
95    if (($f & _MULTI)) {
96	if ($id eq _GEN_ID) {
97	    $$n->[ _nc ]++
98		while exists $$n->[ _nm ]->{ $$n->[ _nc ] };
99	    $id = $$n->[ _nc ];
100	}
101	$$n->[ _nm ]->{ $id } = { };
102    } elsif (($f & _COUNT)) {
103	$$n->[ _nc ]++;
104    }
105    return $id;
106}
107
108sub __get_path_node {
109    my $m = shift;
110    my ($p, $k);
111    my $f = $m->[ _f ];
112    @_ = sort @_ if ($f & _UNORD);
113    if ($m->[ _a ] == 2 && @_ == 2 && !($f & (_HYPER|_REF|_UNIQ))) { # Fast path.
114	return unless exists $m->[ _s ]->{ $_[0] };
115	$p = [ $m->[ _s ], $m->[ _s ]->{ $_[0] } ];
116	$k = [ $_[0], $_[1] ];
117    } else {
118	($p, $k) = $m->__has_path( @_ );
119    }
120    return unless defined $p && defined $k;
121    my $l = defined $k->[-1] ? $k->[-1] : "";
122    return ( exists $p->[-1]->{ $l }, $p->[-1]->{ $l }, $p, $k, $l );
123}
124
125sub set_path_by_multi_id {
126    my $m = shift;
127    my ($p, $k) = $m->__set_path( @_ );
128    return unless defined $p && defined $k;
129    my $l = defined $k->[-1] ? $k->[-1] : "";
130    return $m->__set_path_node( $p, $l, @_ );
131}
132
133sub get_multi_ids {
134    my $m = shift;
135    my $f = $m->[ _f ];
136    return () unless ($f & _MULTI);
137    my ($e, $n) = $m->__get_path_node( @_ );
138    return $e ? keys %{ $n->[ _nm ] } : ();
139}
140
141sub _has_path_attrs {
142    my $m = shift;
143    my $f = $m->[ _f ];
144    my $id = pop if ($f & _MULTI);
145    @_ = sort @_ if ($f & _UNORD);
146    $m->__attr( \@_ );
147    if (($f & _MULTI)) {
148	my ($p, $k) = $m->__has_path( @_ );
149	return unless defined $p && defined $k;
150	my $l = defined $k->[-1] ? $k->[-1] : "";
151	return keys %{ $p->[-1]->{ $l }->[ _nm ]->{ $id } } ? 1 : 0;
152    } else {
153	my ($e, $n) = $m->__get_path_node( @_ );
154	return undef unless $e;
155	return ref $n && $#$n == _na && keys %{ $n->[ _na ] } ? 1 : 0;
156    }
157}
158
159sub _set_path_attrs {
160    my $m = shift;
161    my $f = $m->[ _f ];
162    my $attr = pop;
163    my $id   = pop if ($f & _MULTI);
164    @_ = sort @_ if ($f & _UNORD);
165    $m->__attr( @_ );
166    push @_, $id if ($f & _MULTI);
167    my ($p, $k) = $m->__set_path( @_ );
168    return unless defined $p && defined $k;
169    my $l = defined $k->[-1] ? $k->[-1] : "";
170    $m->__set_path_node( $p, $l, @_ ) unless exists $p->[-1]->{ $l };
171    if (($f & _MULTI)) {
172	$p->[-1]->{ $l }->[ _nm ]->{ $id } = $attr;
173    } else {
174	# Extend the node if it is a simple id node.
175	$p->[-1]->{ $l } = [ $p->[-1]->{ $l }, 1 ] unless ref $p->[-1]->{ $l };
176	$p->[-1]->{ $l }->[ _na ] = $attr;
177    }
178}
179
180sub _has_path_attr {
181    my $m = shift;
182    my $f = $m->[ _f ];
183    my $attr = pop;
184    my $id   = pop if ($f & _MULTI);
185    @_ = sort @_ if ($f & _UNORD);
186    $m->__attr( \@_ );
187    if (($f & _MULTI)) {
188	my ($p, $k) = $m->__has_path( @_ );
189	return unless defined $p && defined $k;
190	my $l = defined $k->[-1] ? $k->[-1] : "";
191	exists $p->[-1]->{ $l }->[ _nm ]->{ $id }->{ $attr };
192    } else {
193	my ($e, $n) = $m->__get_path_node( @_ );
194	return undef unless $e;
195	return ref $n && $#$n == _na ? exists $n->[ _na ]->{ $attr } : undef;
196    }
197}
198
199sub _set_path_attr {
200    my $m = shift;
201    my $f = $m->[ _f ];
202    my $val  = pop;
203    my $attr = pop;
204    my $id   = pop if ($f & _MULTI);
205    @_ = sort @_ if ($f & _UNORD);
206    my ($p, $k);
207    $m->__attr( \@_ ); # _LIGHT maps need this to get upgraded when needed.
208    push @_, $id if ($f & _MULTI);
209    @_ = sort @_ if ($f & _UNORD);
210    if ($m->[ _a ] == 2 && @_ == 2 && !($f & (_REF|_UNIQ|_HYPER|_UNIQ))) {
211	$m->[ _s ]->{ $_[0] } ||= { };
212	$p = [ $m->[ _s ], $m->[ _s ]->{ $_[0] } ];
213	$k = [ $_[0], $_[1] ];
214    } else {
215	($p, $k) = $m->__set_path( @_ );
216    }
217    return unless defined $p && defined $k;
218    my $l = defined $k->[-1] ? $k->[-1] : "";
219    $m->__set_path_node( $p, $l, @_ ) unless exists $p->[-1]->{ $l };
220    if (($f & _MULTI)) {
221	$p->[-1]->{ $l }->[ _nm ]->{ $id }->{ $attr } = $val;
222    } else {
223	# Extend the node if it is a simple id node.
224	$p->[-1]->{ $l } = [ $p->[-1]->{ $l }, 1 ] unless ref $p->[-1]->{ $l };
225	$p->[-1]->{ $l }->[ _na ]->{ $attr } = $val;
226    }
227    return $val;
228}
229
230sub _get_path_attrs {
231    my $m = shift;
232    my $f = $m->[ _f ];
233    my $id   = pop if ($f & _MULTI);
234    @_ = sort @_ if ($f & _UNORD);
235    $m->__attr( \@_ );
236    if (($f & _MULTI)) {
237	my ($p, $k) = $m->__has_path( @_ );
238	return unless defined $p && defined $k;
239	my $l = defined $k->[-1] ? $k->[-1] : "";
240	$p->[-1]->{ $l }->[ _nm ]->{ $id };
241    } else {
242	my ($e, $n) = $m->__get_path_node( @_ );
243	return unless $e;
244	return $n->[ _na ] if ref $n && $#$n == _na;
245	return;
246    }
247}
248
249sub _get_path_attr {
250    my $m = shift;
251    my $f = $m->[ _f ];
252    my $attr = pop;
253    my $id = pop if ($f & _MULTI);
254    @_ = sort @_ if ($f & _UNORD);
255    $m->__attr( \@_ );
256    if (($f & _MULTI)) {
257	my ($p, $k) = $m->__has_path( @_ );
258	return unless defined $p && defined $k;
259	my $l = defined $k->[-1] ? $k->[-1] : "";
260	return $p->[-1]->{ $l }->[ _nm ]->{ $id }->{ $attr };
261    } else {
262	my ($e, $n) = $m->__get_path_node( @_ );
263	return undef unless $e;
264	return ref $n && $#$n == _na ? $n->[ _na ]->{ $attr } : undef;
265    }
266}
267
268sub _get_path_attr_names {
269    my $m = shift;
270    my $f = $m->[ _f ];
271    my $id = pop if ($f & _MULTI);
272    @_ = sort @_ if ($f & _UNORD);
273    $m->__attr( \@_ );
274    if (($f & _MULTI)) {
275	my ($p, $k) = $m->__has_path( @_ );
276	return unless defined $p && defined $k;
277	my $l = defined $k->[-1] ? $k->[-1] : "";
278	keys %{ $p->[-1]->{ $l }->[ _nm ]->{ $id } };
279    } else {
280	my ($e, $n) = $m->__get_path_node( @_ );
281	return undef unless $e;
282	return keys %{ $n->[ _na ] } if ref $n && $#$n == _na;
283	return;
284    }
285}
286
287sub _get_path_attr_values {
288    my $m = shift;
289    my $f = $m->[ _f ];
290    my $id = pop if ($f & _MULTI);
291    @_ = sort @_ if ($f & _UNORD);
292    $m->__attr( \@_ );
293    if (($f & _MULTI)) {
294	my ($p, $k) = $m->__has_path( @_ );
295	return unless defined $p && defined $k;
296	my $l = defined $k->[-1] ? $k->[-1] : "";
297	values %{ $p->[-1]->{ $l }->[ _nm ]->{ $id } };
298    } else {
299	my ($e, $n) = $m->__get_path_node( @_ );
300	return undef unless $e;
301	return values %{ $n->[ _na ] } if ref $n && $#$n == _na;
302	return;
303    }
304}
305
306sub _del_path_attrs {
307    my $m = shift;
308    my $f = $m->[ _f ];
309    my $id = pop if ($f & _MULTI);
310    @_ = sort @_ if ($f & _UNORD);
311    $m->__attr( \@_ );
312    if (($f & _MULTI)) {
313	my ($p, $k) = $m->__has_path( @_ );
314	return unless defined $p && defined $k;
315	my $l = defined $k->[-1] ? $k->[-1] : "";
316	delete $p->[-1]->{ $l }->[ _nm ]->{ $id };
317	unless (keys %{ $p->[-1]->{ $l }->[ _nm ] } ||
318		(defined $p->[-1]->{ $l }->[ _na ] &&
319		 keys %{ $p->[-1]->{ $l }->[ _na ] })) {
320	    delete $p->[-1]->{ $l };
321	}
322    } else {
323	my ($e, $n) = $m->__get_path_node( @_ );
324	return undef unless $e;
325	if (ref $n) {
326	    $e = _na == $#$n && keys %{ $n->[ _na ] } ? 1 : 0;
327	    $#$n = _na - 1;
328	    return $e;
329	} else {
330	    return 0;
331	}
332    }
333}
334
335sub _del_path_attr {
336    my $m = shift;
337    my $f = $m->[ _f ];
338    my $attr = pop;
339    my $id = pop if ($f & _MULTI);
340    @_ = sort @_ if ($f & _UNORD);
341    $m->__attr( \@_ );
342    if (($f & _MULTI)) {
343	my ($p, $k) = $m->__has_path( @_ );
344	return unless defined $p && defined $k;
345	my $l = defined $k->[-1] ? $k->[-1] : "";
346	delete $p->[-1]->{ $l }->[ _nm ]->{ $id }->{ $attr };
347	$m->_del_path_attrs( @_, $id )
348	    unless keys %{ $p->[-1]->{ $l }->[ _nm ]->{ $id } };
349    } else {
350	my ($e, $n) = $m->__get_path_node( @_ );
351	return undef unless $e;
352	if (ref $n && $#$n == _na && exists $n->[ _na ]->{ $attr }) {
353	    delete $n->[ _na ]->{ $attr };
354	    return 1;
355	} else {
356	    return 0;
357	}
358    }
359}
360
361sub _is_COUNT { $_[0]->[ _f ] & _COUNT }
362sub _is_MULTI { $_[0]->[ _f ] & _MULTI }
363sub _is_HYPER { $_[0]->[ _f ] & _HYPER }
364sub _is_UNORD { $_[0]->[ _f ] & _UNORD }
365sub _is_UNIQ  { $_[0]->[ _f ] & _UNIQ  }
366sub _is_REF   { $_[0]->[ _f ] & _REF   }
367sub _is_STR   { $_[0]->[ _f ] & _STR   }
368
369sub __arg {
370    my $m = shift;
371    my $f = $m->[ _f ];
372    my @a = @{$_[0]};
373    if ($f & _UNIQ) {
374	my %u;
375	if ($f & _UNORD) {
376	    @u{ @a } = @a;
377	    @a = values %u;
378	} else {
379	    my @u;
380	    for my $e (@a) {
381		push @u, $e if $u{$e}++ == 0;
382	    }
383	    @a = @u;
384	}
385    }
386    # Alphabetic or numeric sort, does not matter as long as it unifies.
387    @{$_[0]} = ($f & _UNORD) ? sort @a : @a;
388}
389
390sub _successors {
391    my $E = shift;
392    my $g = shift;
393    my $V = $g->[ _V ];
394    map { my @v = @{ $_->[ 1 ] };
395	  shift @v;
396	  map { $V->_get_id_path($_) } @v } $g->_edges_from( @_ );
397}
398
399sub _predecessors {
400    my $E = shift;
401    my $g = shift;
402    my $V = $g->[ _V ];
403    if (wantarray) {
404	map { my @v = @{ $_->[ 1 ] };
405	      pop @v;
406	      map { $V->_get_id_path($_) } @v } $g->_edges_to( @_ );
407    } else {
408	return $g->_edges_to( @_ );
409    }
410}
411
4121;
413__END__
414=pod
415
416=head1 NAME
417
418Graph::AdjacencyMap - create and a map of graph vertices or edges
419
420=head1 SYNOPSIS
421
422    Internal.
423
424=head1 DESCRIPTION
425
426B<This module is meant for internal use by the Graph module.>
427
428=head2 Object Methods
429
430=over 4
431
432=item del_path(@id)
433
434Delete a Map path by ids.
435
436=item del_path_by_multi_id($id)
437
438Delete a Map path by a multi(vertex) id.
439
440=item get_multi_ids
441
442Return the multi ids.
443
444=item has_path(@id)
445
446Return true if the Map has the path by ids, false if not.
447
448=item has_paths
449
450Return true if the Map has any paths, false if not.
451
452=item has_path_by_multi_id($id)
453
454Return true if the Map has the path by a multi(vertex) id, false if not.
455
456=item paths
457
458Return all the paths of the Map.
459
460=item set_path(@id)
461
462Set the path by @ids.
463
464=item set_path_by_multi_id
465
466Set the path in the Map by the multi id.
467
468=back
469
470=head1 AUTHOR AND COPYRIGHT
471
472Jarkko Hietaniemi F<jhi@iki.fi>
473
474=head1 LICENSE
475
476This module is licensed under the same terms as Perl itself.
477
478=cut
479