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