1package Graph::AdjacencyMap::Light;
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
9use Graph::AdjacencyMap qw(:flags :fields);
10use base 'Graph::AdjacencyMap';
11
12use Scalar::Util qw(weaken);
13
14use Graph::AdjacencyMap::Heavy;
15use Graph::AdjacencyMap::Vertex;
16
17sub _V () { 2 } # Graph::_V
18sub _E () { 3 } # Graph::_E
19sub _F () { 0 } # Graph::_F
20
21sub _new {
22    my ($class, $graph, $flags, $arity) = @_;
23    my $m = bless [ ], $class;
24    $m->[ _n ] = 0;
25    $m->[ _f ] = $flags | _LIGHT;
26    $m->[ _a ] = $arity;
27    $m->[ _i ] = { };
28    $m->[ _s ] = { };
29    $m->[ _p ] = { };
30    $m->[ _g ] = $graph;
31    weaken $m->[ _g ]; # So that DESTROY finds us earlier.
32    return $m;
33}
34
35sub set_path {
36    my $m = shift;
37    my ($n, $f, $a, $i, $s, $p) = @$m;
38    if ($a == 2) {
39	@_ = sort @_ if ($f & _UNORD);
40    }
41    my $e0 = shift;
42    if ($a == 2) {
43	my $e1 = shift;
44	unless (exists $s->{ $e0 } && exists $s->{ $e0 }->{ $e1 }) {
45	    $n = $m->[ _n ]++;
46	    $i->{ $n } = [ $e0, $e1 ];
47	    $s->{ $e0 }->{ $e1 } = $n;
48	    $p->{ $e1 }->{ $e0 } = $n;
49	}
50    } else {
51	unless (exists $s->{ $e0 }) {
52	    $n = $m->[ _n ]++;
53	    $s->{ $e0 } = $n;
54	    $i->{ $n } = $e0;
55	}
56    }
57}
58
59sub has_path {
60    my $m = shift;
61    my ($n, $f, $a, $i, $s) = @$m;
62    return 0 unless $a == @_;
63    my $e;
64    if ($a == 2) {
65	@_ = sort @_ if ($f & _UNORD);
66	$e = shift;
67	return 0 unless exists $s->{ $e };
68        $s = $s->{ $e };
69    }
70    $e = shift;
71    exists $s->{ $e };
72}
73
74sub _get_path_id {
75    my $m = shift;
76    my ($n, $f, $a, $i, $s) = @$m;
77    return undef unless $a == @_;
78    my $e;
79    if ($a == 2) {
80	@_ = sort @_ if ($f & _UNORD);
81	$e = shift;
82	return undef unless exists $s->{ $e };
83        $s = $s->{ $e };
84    }
85    $e = shift;
86    $s->{ $e };
87}
88
89sub _get_path_count {
90    my $m = shift;
91    my ($n, $f, $a, $i, $s) = @$m;
92    my $e;
93    if (@_ == 2) {
94	@_ = sort @_ if ($f & _UNORD);
95	$e = shift;
96	return undef unless exists $s->{ $e };
97        $s = $s->{ $e };
98    }
99    $e = shift;
100    return exists $s->{ $e } ? 1 : 0;
101}
102
103sub has_paths {
104    my $m = shift;
105    my ($n, $f, $a, $i, $s) = @$m;
106    keys %$s;
107}
108
109sub paths {
110    my $m = shift;
111    my ($n, $f, $a, $i) = @$m;
112    if (defined $i) {
113	my ($k, $v) = each %$i;
114	if (ref $v) {
115	    return values %{ $i };
116	} else {
117	    return map { [ $_ ] } values %{ $i };
118	}
119    } else {
120	return ( );
121    }
122}
123
124sub _get_id_path {
125    my $m = shift;
126    my ($n, $f, $a, $i) = @$m;
127    my $p = $i->{ $_[ 0 ] };
128    defined $p ? ( ref $p eq 'ARRAY' ? @$p : $p ) : ( );
129}
130
131sub del_path {
132    my $m = shift;
133    my ($n, $f, $a, $i, $s, $p) = @$m;
134    if (@_ == 2) {
135	@_ = sort @_ if ($f & _UNORD);
136	my $e0 = shift;
137	return 0 unless exists $s->{ $e0 };
138	my $e1 = shift;
139	if (defined($n = $s->{ $e0 }->{ $e1 })) {
140	    delete $i->{ $n };
141            delete $s->{ $e0 }->{ $e1 };
142            delete $p->{ $e1 }->{ $e0 };
143	    delete $s->{ $e0 } unless keys %{ $s->{ $e0 } };
144	    delete $p->{ $e1 } unless keys %{ $p->{ $e1 } };
145	    return 1;
146	}
147    } else {
148	my $e = shift;
149	if (defined($n = $s->{ $e })) {
150	    delete $i->{ $n };
151	    delete $s->{ $e };
152	    return 1;
153	}
154    }
155    return 0;
156}
157
158sub __successors {
159    my $E = shift;
160    return wantarray ? () : 0 unless defined $E->[ _s ];
161    my $g = shift;
162    my $V = $g->[ _V ];
163    return wantarray ? () : 0 unless defined $V && defined $V->[ _s ];
164    # my $i = $V->_get_path_id( $_[0] );
165    my $i =
166	($V->[ _f ] & _LIGHT) ?
167	    $V->[ _s ]->{ $_[0] } :
168	    $V->_get_path_id( $_[0] );
169    return wantarray ? () : 0 unless defined $i && defined $E->[ _s ]->{ $i };
170    return keys %{ $E->[ _s ]->{ $i } };
171}
172
173sub _successors {
174    my $E = shift;
175    my $g = shift;
176    my @s = $E->__successors($g, @_);
177    if (($E->[ _f ] & _UNORD)) {
178	push @s, $E->__predecessors($g, @_);
179	my %s; @s{ @s } = ();
180	@s = keys %s;
181    }
182    my $V = $g->[ _V ];
183    return wantarray ? map { $V->[ _i ]->{ $_ } } @s : @s;
184}
185
186sub __predecessors {
187    my $E = shift;
188    return wantarray ? () : 0 unless defined $E->[ _p ];
189    my $g = shift;
190    my $V = $g->[ _V ];
191    return wantarray ? () : 0 unless defined $V && defined $V->[ _s ];
192    # my $i = $V->_get_path_id( $_[0] );
193    my $i =
194	($V->[ _f ] & _LIGHT) ?
195	    $V->[ _s ]->{ $_[0] } :
196	    $V->_get_path_id( $_[0] );
197    return wantarray ? () : 0 unless defined $i && defined $E->[ _p ]->{ $i };
198    return keys %{ $E->[ _p ]->{ $i } };
199}
200
201sub _predecessors {
202    my $E = shift;
203    my $g = shift;
204    my @p = $E->__predecessors($g, @_);
205    if ($E->[ _f ] & _UNORD) {
206	push @p, $E->__successors($g, @_);
207	my %p; @p{ @p } = ();
208	@p = keys %p;
209    }
210    my $V = $g->[ _V ];
211    return wantarray ? map { $V->[ _i ]->{ $_ } } @p : @p;
212}
213
214sub __attr {
215    # Major magic takes place here: we rebless the appropriate 'light'
216    # map into a more complex map and then redispatch the method.
217    my $m = $_[0];
218    my ($n, $f, $a, $i, $s, $p, $g) = @$m;
219    my ($k, $v) = each %$i;
220    my @V = @{ $g->[ _V ] };
221    my @E = $g->edges; # TODO: Both these (ZZZ) lines are mysteriously needed!
222    # ZZZ: an example of failing tests is t/52_edge_attributes.t.
223    if (ref $v eq 'ARRAY') { # Edges, then.
224	# print "Reedging.\n";
225	@E = $g->edges; # TODO: Both these (ZZZ) lines are mysteriously needed!
226	$g->[ _E ] = $m = Graph::AdjacencyMap::Heavy->_new($f, 2);
227	$g->add_edges( @E );
228    } else {
229	# print "Revertexing.\n";
230	$m = Graph::AdjacencyMap::Vertex->_new(($f & ~_LIGHT), 1);
231	$m->[ _n ] = $V[ _n ];
232	$m->[ _i ] = $V[ _i ];
233	$m->[ _s ] = $V[ _s ];
234	$m->[ _p ] = $V[ _p ];
235	$g->[ _V ] = $m;
236    }
237    $_[0] = $m;
238    goto &{ ref($m) . "::__attr" }; # Redispatch.
239}
240
241sub _is_COUNT    () { 0 }
242sub _is_MULTI    () { 0 }
243sub _is_HYPER    () { 0 }
244sub _is_UNIQ     () { 0 }
245sub _is_REF      () { 0 }
246
2471;
248