1package Graph::AdjacencyMap::Heavy;
2
3# THIS IS INTERNAL IMPLEMENTATION ONLY, NOT TO BE USED DIRECTLY.
4# THE INTERFACE IS HARD TO USE AND GOING TO STAY THAT WAY AND
5# ALMOST GUARANTEED TO CHANGE OR GO AWAY IN FUTURE RELEASES.
6
7use strict;
8
9# $SIG{__DIE__ } = sub { use Carp; confess };
10# $SIG{__WARN__} = sub { use Carp; confess };
11
12use Graph::AdjacencyMap qw(:flags :fields);
13use base 'Graph::AdjacencyMap';
14
15require overload; # for de-overloading
16
17require Data::Dumper;
18
19sub __set_path {
20    my $m = shift;
21    my $f = $m->[ _f ];
22    my $id = pop if ($f & _MULTI);
23    if (@_ != $m->[ _a ] && !($f & _HYPER)) {
24	require Carp;
25	Carp::confess(sprintf "Graph::AdjacencyMap::Heavy: arguments %d expected %d",
26		      scalar @_, $m->[ _a ]);
27    }
28    my $p;
29    $p = ($f & _HYPER) ?
30	(( $m->[ _s ] ||= [ ] )->[ @_ ] ||= { }) :
31	(  $m->[ _s ]                   ||= { });
32    my @p = $p;
33    my @k;
34    while (@_) {
35	my $k = shift;
36	my $q = ref $k && ($f & _REF) && overload::Method($k, '""') ? overload::StrVal($k) : $k;
37	if (@_) {
38	    $p = $p->{ $q } ||= {};
39	    return unless $p;
40	    push @p, $p;
41	}
42	push @k, $q;
43    }
44    return (\@p, \@k);
45}
46
47sub __set_path_node {
48    my ($m, $p, $l) = splice @_, 0, 3;
49    my $f = $m->[ _f ] ;
50    my $id = pop if ($f & _MULTI);
51    unless (exists $p->[-1]->{ $l }) {
52	my $i = $m->_new_node( \$p->[-1]->{ $l }, $id );
53	$m->[ _i ]->{ defined $i ? $i : "" } = [ @_ ];
54        return defined $id ? ($id eq _GEN_ID ? $$id : $id) : $i;
55    } else {
56	return $m->_inc_node( \$p->[-1]->{ $l }, $id );
57    }
58}
59
60sub set_path {
61    my $m = shift;
62    my $f = $m->[ _f ];
63    if (@_ > 1 && ($f & _UNORDUNIQ)) {
64	if (($f & _UNORDUNIQ) == _UNORD && @_ == 2) { @_ = sort @_ }
65        else { $m->__arg(\@_) }
66    }
67    my ($p, $k) = $m->__set_path( @_ );
68    return unless defined $p && defined $k;
69    my $l = defined $k->[-1] ? $k->[-1] : "";
70    return $m->__set_path_node( $p, $l, @_ );
71}
72
73sub __has_path {
74    my $m = shift;
75    my $f = $m->[ _f ];
76    if (@_ != $m->[ _a ] && !($f & _HYPER)) {
77	require Carp;
78	Carp::confess(sprintf "Graph::AdjacencyMap::Heavy: arguments %d expected %d",
79		      scalar @_, $m->[ _a ]);
80    }
81    if (@_ > 1 && ($f & _UNORDUNIQ)) {
82	if (($f & _UNORDUNIQ) == _UNORD && @_ == 2) { @_ = sort @_ }
83        else { $m->__arg(\@_) }
84    }
85    my $p = $m->[ _s ];
86    return unless defined $p;
87    $p = $p->[ @_ ] if ($f & _HYPER);
88    return unless defined $p;
89    my @p = $p;
90    my @k;
91    while (@_) {
92	my $k = shift;
93	my $q = ref $k && ($f & _REF) && overload::Method($k, '""') ? overload::StrVal($k) : $k;
94	if (@_) {
95	    $p = $p->{ $q };
96	    return unless defined $p;
97	    push @p, $p;
98	}
99	push @k, $q;
100    }
101    return (\@p, \@k);
102}
103
104sub has_path {
105    my $m = shift;
106    my $f = $m->[ _f ];
107    if (@_ > 1 && ($f & _UNORDUNIQ)) {
108	if (($f & _UNORDUNIQ) == _UNORD && @_ == 2) { @_ = sort @_ }
109        else { $m->__arg(\@_) }
110    }
111    my ($p, $k) = $m->__has_path( @_ );
112    return unless defined $p && defined $k;
113    return exists $p->[-1]->{ defined $k->[-1] ? $k->[-1] : "" };
114}
115
116sub has_path_by_multi_id {
117    my $m = shift;
118    my $f = $m->[ _f ];
119    my $id = pop;
120    if (@_ > 1 && ($f & _UNORDUNIQ)) {
121	if (($f & _UNORDUNIQ) == _UNORD && @_ == 2) { @_ = sort @_ }
122        else { $m->__arg(\@_) }
123    }
124    my ($e, $n) = $m->__get_path_node( @_ );
125    return undef unless $e;
126    return exists $n->[ _nm ]->{ $id };
127}
128
129sub _get_path_node {
130    my $m = shift;
131    my $f = $m->[ _f ];
132    if ($m->[ _a ] == 2 && @_ == 2 && !($f & (_HYPER|_REF|_UNIQ))) { # Fast path.
133	@_ = sort @_ if ($f & _UNORD);
134	return unless exists $m->[ _s ]->{ $_[0] };
135	my $p = [ $m->[ _s ], $m->[ _s ]->{ $_[0] } ];
136	my $k = [ $_[0], $_[1] ];
137	my $l = $_[1];
138	return ( exists $p->[-1]->{ $l }, $p->[-1]->{ $l }, $p, $k, $l );
139    } else {
140	if (@_ > 1 && ($f & _UNORDUNIQ)) {
141	    if (($f & _UNORDUNIQ) == _UNORD && @_ == 2) { @_ = sort @_ }
142	    else { $m->__arg(\@_) }
143	}
144	$m->__get_path_node( @_ );
145    }
146}
147
148sub _get_path_id {
149    my $m = shift;
150    my $f = $m->[ _f ];
151    my ($e, $n);
152    if ($m->[ _a ] == 2 && @_ == 2 && !($f & (_HYPER|_REF|_UNIQ))) { # Fast path.
153	@_ = sort @_ if ($f & _UNORD);
154	return unless exists $m->[ _s ]->{ $_[0] };
155	my $p = $m->[ _s ]->{ $_[0] };
156	$e = exists $p->{ $_[1] };
157	$n = $p->{ $_[1] };
158    } else {
159	($e, $n) = $m->_get_path_node( @_ );
160    }
161    return undef unless $e;
162    return ref $n ? $n->[ _ni ] : $n;
163}
164
165sub _get_path_count {
166    my $m = shift;
167    my $f = $m->[ _f ];
168    my ($e, $n) = $m->_get_path_node( @_ );
169    return undef unless $e && defined $n;
170    return
171	($f & _COUNT) ? $n->[ _nc ] :
172	($f & _MULTI) ? scalar keys %{ $n->[ _nm ] } : 1;
173}
174
175sub __attr {
176    my $m = shift;
177    if (@_) {
178	if (ref $_[0] && @{ $_[0] }) {
179	    if (@{ $_[0] } != $m->[ _a ]) {
180		require Carp;
181		Carp::confess(sprintf
182			      "Graph::AdjacencyMap::Heavy: arguments %d expected %d\n",
183			      scalar @{ $_[0] }, $m->[ _a ]);
184	    }
185	    my $f = $m->[ _f ];
186	    if (@{ $_[0] } > 1 && ($f & _UNORDUNIQ)) {
187		if (($f & _UNORDUNIQ) == _UNORD && @{ $_[0] } == 2) {
188		    @{ $_[0] } = sort @{ $_[0] }
189		} else { $m->__arg(\@_) }
190	    }
191	}
192    }
193}
194
195sub _get_id_path {
196    my ($m, $i) = @_;
197    my $p = defined $i ? $m->[ _i ]->{ $i } : undef;
198    return defined $p ? @$p : ( );
199}
200
201sub del_path {
202    my $m = shift;
203    my $f = $m->[ _f ];
204    if (@_ > 1 && ($f & _UNORDUNIQ)) {
205	if (($f & _UNORDUNIQ) == _UNORD && @_ == 2) { @_ = sort @_ }
206        else { $m->__arg(\@_) }
207    }
208    my ($e, $n, $p, $k, $l) = $m->__get_path_node( @_ );
209    return unless $e;
210    my $c = ($f & _COUNT) ? --$n->[ _nc ] : 0;
211    if ($c == 0) {
212	delete $m->[ _i ]->{ ref $n ? $n->[ _ni ] : $n };
213	delete $p->[-1]->{ $l };
214	while (@$p && @$k && keys %{ $p->[-1]->{ $k->[-1] } } == 0) {
215	    delete $p->[-1]->{ $k->[-1] };
216	    pop @$p;
217	    pop @$k;
218	}
219    }
220    return 1;
221}
222
223sub del_path_by_multi_id {
224    my $m = shift;
225    my $f = $m->[ _f ];
226    my $id = pop;
227    if (@_ > 1 && ($f & _UNORDUNIQ)) {
228	if (($f & _UNORDUNIQ) == _UNORD && @_ == 2) { @_ = sort @_ }
229        else { $m->__arg(\@_) }
230    }
231    my ($e, $n, $p, $k, $l) = $m->__get_path_node( @_ );
232    return unless $e;
233    delete $n->[ _nm ]->{ $id };
234    unless (keys %{ $n->[ _nm ] }) {
235	delete $m->[ _i ]->{ $n->[ _ni ] };
236	delete $p->[-1]->{ $l };
237	while (@$p && @$k && keys %{ $p->[-1]->{ $k->[-1] } } == 0) {
238	    delete $p->[-1]->{ $k->[-1] };
239	    pop @$p;
240	    pop @$k;
241	}
242    }
243    return 1;
244}
245
246sub paths {
247    my $m = shift;
248    return values %{ $m->[ _i ] } if defined $m->[ _i ];
249    wantarray ? ( ) : 0;
250}
251
2521;
253__END__
254