ViewVC Help

View File | Revision Log | Show Annotations | Root Listing

root/cvsroot/COMP/SCRAM/src/Graph/Base.pm

Comparing COMP/SCRAM/src/Graph/Base.pm (file contents):
Revision 1.1 by sashby, Tue Jul 20 12:02:52 2004 UTC vs.
Revision 1.2 by sashby, Fri Dec 10 13:41:40 2004 UTC

#	Line 0 | Line 1
1	+	package Graph::Base;
2	+	use strict;
3	+	local $^W = 1;
4	+	use vars qw(@ISA);
5	+	require Exporter;
6	+	@ISA = qw(Exporter);
7	+
8	+	sub new
9	+	{
10	+	my $class = shift;
11	+	my $G = { };
12	+
13	+	bless $G, $class;
14	+
15	+	$G->add_vertices(@_) if @_;
16	+
17	+	return $G;
18	+	}
19	+
20	+	sub add_vertices
21	+	{
22	+	my ($G, @v) = @_;
23	+	@{ $G->{ V } }{ @v } = @v;
24	+
25	+	return $G;
26	+	}
27	+
28	+	sub add_vertex
29	+	{
30	+	my ($G, $v) = @_;
31	+	return $G->add_vertices($v);
32	+	}
33	+
34	+	sub vertices
35	+	{
36	+	my $G = shift;
37	+	my @V = exists $G->{ V } ? sort values %{ $G->{ V } } : ();
38	+
39	+	return @V;
40	+	}
41	+
42	+	sub has_vertex
43	+	{
44	+	my ($G, $v) = @_;
45	+	return exists $G->{V}->{ $v };
46	+	}
47	+
48	+	sub vertex
49	+	{
50	+	my ($G, $v) = @_;
51	+
52	+	return $G->{ V }->{ $v };
53	+	}
54	+
55	+	sub directed
56	+	{
57	+	my ($G, $d) = @_;
58	+
59	+	if (defined $d)
60	+	{
61	+	if ($d)
62	+	{
63	+	my $o = $G->{ D }; # Old directedness.
64	+
65	+	$G->{ D } = $d;
66	+	if (not $o)
67	+	{
68	+	my @E = $G->edges;
69	+
70	+	while (my ($u, $v) = splice(@E, 0, 2))
71	+	{
72	+	$G->add_edge($v, $u);
73	+	}
74	+	}
75	+
76	+	return bless $G, 'Graph::Directed'; # Re-bless.
77	+	}
78	+	else
79	+	{
80	+	return $G->undirected(not $d);
81	+	}
82	+	}
83	+
84	+	return $G->{ D };
85	+	}
86	+
87	+	sub undirected
88	+	{
89	+	my ($G, $u) = @_;
90	+	$G->{ D } = 1 unless defined $G->{ D };
91	+
92	+	if (defined $u)
93	+	{
94	+	if ($u)
95	+	{
96	+	my $o = $G->{ D }; # Old directedness.
97	+
98	+	$G->{ D } = not $u;
99	+	if ($o)
100	+	{
101	+	my @E = $G->edges;
102	+	my %E;
103	+
104	+	while (my ($u, $v) = splice(@E, 0, 2))
105	+	{
106	+	# Throw away duplicate edges.
107	+	$G->delete_edge($u, $v) if exists $E{$v}->{$u};
108	+	$E{$u}->{$v}++;
109	+	}
110	+	}
111	+
112	+	return bless $G, 'Graph::Undirected'; # Re-bless.
113	+	}
114	+	else
115	+	{
116	+	return $G->directed(not $u);
117	+	}
118	+	}
119	+
120	+	return not $G->{ D };
121	+	}
122	+
123	+	sub _union_vertex_set
124	+	{
125	+	my ($G, $u, $v) = @_;
126	+
127	+	my $su = $G->vertex_set( $u );
128	+	my $sv = $G->vertex_set( $v );
129	+	my $ru = $G->{ VertexSetRank }->{ $su };
130	+	my $rv = $G->{ VertexSetRank }->{ $sv };
131	+
132	+	if ( $ru < $rv )
133	+	{ # Union by rank (weight balancing).
134	+	$G->{ VertexSetParent }->{ $su } = $sv;
135	+	}
136	+	else
137	+	{
138	+	$G->{ VertexSetParent }->{ $sv } = $su;
139	+	$G->{ VertexSetRank   }->{ $sv }++ if $ru == $rv;
140	+	}
141	+	}
142	+
143	+	sub vertex_set
144	+	{
145	+	my ($G, $v) = @_;
146	+
147	+	if ( exists  $G->{ VertexSetParent }->{ $v } )
148	+	{
149	+	# Path compression.
150	+	$G->{ VertexSetParent }->{ $v } =
151	+	$G->vertex_set( $G->{ VertexSetParent }->{ $v } )
152	+	if $v ne $G->{ VertexSetParent }->{ $v };
153	+	}
154	+	else
155	+	{
156	+	$G->{ VertexSetParent }->{ $v } = $v;
157	+	$G->{ VertexSetRank   }->{ $v } = 0;
158	+	}
159	+	return $G->{ VertexSetParent }->{ $v };
160	+	}
161	+
162	+	sub add_edge
163	+	{
164	+	my ($G, $u, $v) = @_;
165	+
166	+	$G->add_vertex($u);
167	+	$G->add_vertex($v);
168	+	$G->_union_vertex_set( $u, $v );
169	+	push @{ $G->{ Succ }->{ $u }->{ $v } }, $v;
170	+	push @{ $G->{ Pred }->{ $v }->{ $u } }, $u;
171	+	return $G;
172	+	}
173	+
174	+	sub _successors
175	+	{
176	+	my ($G, $v) = @_;
177	+	my @s =
178	+	defined $G->{ Succ }->{ $v } ?
179	+	map { @{ $G->{ Succ }->{ $v }->{ $_ } } }
180	+	sort keys %{ $G->{ Succ }->{ $v } } :
181	+	( );
182	+
183	+	return @s;
184	+	}
185	+
186	+	sub _predecessors
187	+	{
188	+	my ($G, $v) = @_;
189	+	my @p =
190	+	defined $G->{ Pred }->{ $v } ?
191	+	map { @{ $G->{ Pred }->{ $v }->{ $_ } } }
192	+	sort keys %{ $G->{ Pred }->{ $v } } :
193	+	( );
194	+
195	+	return @p;
196	+	}
197	+
198	+	sub neighbors
199	+	{
200	+	my ($G, $v) = @_;
201	+	my @n = ($G->_successors($v), $G->_predecessors($v));
202	+	return @n;
203	+	}
204	+
205	+	use vars '*neighbours';
206	+	*neighbours = \&neighbors; # Keep both sides of the Atlantic happy.
207	+
208	+	sub successors
209	+	{
210	+	my ($G, $v) = @_;
211	+	return $G->directed ? $G->_successors($v) : $G->neighbors($v);
212	+	}
213	+
214	+	sub out_edges
215	+	{
216	+	my ($G, $v) = @_;
217	+	return () unless $G->has_vertex($v);
218	+
219	+	my @e = $G->_edges($v, undef);
220	+
221	+	return wantarray ? @e : @e / 2;
222	+	}
223	+
224	+	sub edges
225	+	{
226	+	my ($G, $u, $v) = @_;
227	+	return () if defined $v and not $G->has_vertex($v);
228	+
229	+	my @e =
230	+	defined $u ?
231	+	( defined $v ?
232	+	$G->_edges($u, $v) :
233	+	($G->in_edges($u), $G->out_edges($u)) ) :
234	+	$G->_edges;
235	+	return wantarray ? @e : @e / 2;
236	+	}
237	+
238	+	sub delete_edge
239	+	{
240	+	my ($G, $u, $v) = @_;
241	+	pop @{ $G->{ Succ }->{ $u }->{ $v } };
242	+	pop @{ $G->{ Pred }->{ $v }->{ $u } };
243	+
244	+	delete $G->{ Succ }->{ $u }->{ $v }
245	+	unless @{ $G->{ Succ }->{ $u }->{ $v } };
246	+	delete $G->{ Pred }->{ $v }->{ $u }
247	+	unless @{ $G->{ Pred }->{ $v }->{ $u } };
248	+
249	+	delete $G->{ Succ }->{ $u }
250	+	unless keys %{ $G->{ Succ }->{ $u } };
251	+	delete $G->{ Pred }->{ $v }
252	+	unless keys %{ $G->{ Pred }->{ $v } };
253	+
254	+	return $G;
255	+	}
256	+
257	+	sub out_degree
258	+	{
259	+	my ($G, $v) = @_;
260	+	return undef unless $G->has_vertex($v);
261	+
262	+	if ($G->directed)
263	+	{
264	+	if (defined $v)
265	+	{
266	+	return scalar $G->out_edges($v);
267	+	}
268	+	else
269	+	{
270	+	my $out = 0;
271	+
272	+	foreach my $v ($G->vertices)
273	+	{
274	+	$out += $G->out_degree($v);
275	+	}
276	+	return $out;
277	+	}
278	+	}
279	+	else
280	+	{
281	+	return scalar $G->edges($v);
282	+	}
283	+	}
284	+
285	+	sub copy
286	+	{
287	+	my $G = shift;
288	+	my $C = (ref $G)->new($G->vertices);
289	+
290	+	if (my @E = $G->edges)
291	+	{
292	+	while (my ($u, $v) = splice(@E, 0, 2))
293	+	{
294	+	$C->add_edge($u, $v);
295	+	}
296	+	}
297	+
298	+	$C->directed($G->directed);
299	+
300	+	return $C;
301	+	}
302	+
303	+	sub edge_classify
304	+	{
305	+	my $G = shift;
306	+	my $unseen_successor =
307	+	sub {
308	+	my ($u, $v, $T) = @_;
309	+	# Freshly seen successors make for tree edges.
310	+	push @{ $T->{ edge_class_list } },
311	+	[ $u, $v, 'tree' ];
312	+	};
313	+	my $seen_successor =
314	+	sub {
315	+	my ($u, $v, $T) = @_;
316	+
317	+	my $class;
318	+
319	+	if ( $T->{ G }->directed )
320	+	{
321	+	$class = 'cross'; # Default for directed non-tree edges.
322	+
323	+	unless ( exists $T->{ vertex_finished }->{ $v } )
324	+	{
325	+	$class = 'back';
326	+	}
327	+	elsif ( $T->{ vertex_found }->{ $u } <
328	+	$T->{ vertex_found }->{ $v })
329	+	{
330	+	$class = 'forward';
331	+	}
332	+	}
333	+	else
334	+	{
335	+	# No cross nor forward edges in
336	+	# an undirected graph, by definition.
337	+	$class = 'back';
338	+	}
339	+
340	+	push @{ $T->{ edge_class_list } }, [ $u, $v, $class ];
341	+	};
342	+	use Graph::DFS;
343	+	my $d =
344	+	Graph::DFS->
345	+	new( $G,
346	+	unseen_successor => $unseen_successor,
347	+	seen_successor   => $seen_successor,
348	+	@_);
349	+
350	+	$d->preorder;
351	+
352	+	return @{ $d->{ edge_class_list } };
353	+	}
354	+
355	+	sub toposort
356	+	{
357	+	my $G = shift;
358	+	my $d = Graph::DFS->new($G);
359	+	$d->postorder; # That's it.
360	+	}
361	+
362	+	sub largest_out_degree
363	+	{
364	+	my $G = shift;
365	+	my @R = map { $_->[ 0 ] } # A Schwartzian Transform.
366	+	sort { $b->[ 1 ] <=> $a->[ 1 ] || $a cmp $b }
367	+	map { [ $_, $G->out_degree($_) ] }
368	+	@_;
369	+
370	+	return $R[ 0 ];
371	+	}
372	+
373	+	1;

Diff Legend

–	Removed lines
+	Added lines
<	Changed lines
>	Changed lines