src/Graph/Base.pm

package Graph::Base;
use strict;
local $^W = 1;
use vars qw(@ISA);
require Exporter;
@ISA = qw(Exporter);

sub new
   {
   my $class = shift;
   my $G = { };

   bless $G, $class;

   $G->add_vertices(@_) if @_;
   
   return $G;
   }

sub add_vertices
   {
   my ($G, @v) = @_;
   @{ $G->{ V } }{ @v } = @v;
   
   return $G;
   }

sub add_vertex
   {
   my ($G, $v) = @_;
   return $G->add_vertices($v);
   }

sub vertices
   {
   my $G = shift;
   my @V = exists $G->{ V } ? sort values %{ $G->{ V } } : ();
   
   return @V;
   }

sub has_vertex
   {
   my ($G, $v) = @_;
   return exists $G->{V}->{ $v };
   }

sub vertex
   {
   my ($G, $v) = @_;
   
   return $G->{ V }->{ $v };
   }

sub directed
   {
   my ($G, $d) = @_;
   
   if (defined $d)
      {
      if ($d)
         {
         my $o = $G->{ D }; # Old directedness.

         $G->{ D } = $d;
         if (not $o)
            {
            my @E = $G->edges;
            
            while (my ($u, $v) = splice(@E, 0, 2))
               {
               $G->add_edge($v, $u);
               }
            }

         return bless $G, 'Graph::Directed'; # Re-bless.
         }
      else
         {
         return $G->undirected(not $d);
         }
      }
   
   return $G->{ D };
   }

sub undirected
   {
   my ($G, $u) = @_;
   $G->{ D } = 1 unless defined $G->{ D };

   if (defined $u)
      {
      if ($u)
         {
         my $o = $G->{ D }; # Old directedness.
         
         $G->{ D } = not $u;
         if ($o)
            {
            my @E = $G->edges;
            my %E;
            
            while (my ($u, $v) = splice(@E, 0, 2))
               {
               # Throw away duplicate edges.
               $G->delete_edge($u, $v) if exists $E{$v}->{$u};
               $E{$u}->{$v}++;
               }
            }
         
         return bless $G, 'Graph::Undirected'; # Re-bless.
         }
      else
         {
         return $G->directed(not $u);
         }
      }
   
   return not $G->{ D };
   }

sub _union_vertex_set
   {
   my ($G, $u, $v) = @_;
   
   my $su = $G->vertex_set( $u );
   my $sv = $G->vertex_set( $v );
   my $ru = $G->{ VertexSetRank }->{ $su };
   my $rv = $G->{ VertexSetRank }->{ $sv };
   
   if ( $ru < $rv )
      { # Union by rank (weight balancing).
      $G->{ VertexSetParent }->{ $su } = $sv;
      }
   else
      {
      $G->{ VertexSetParent }->{ $sv } = $su;
      $G->{ VertexSetRank   }->{ $sv }++ if $ru == $rv;
      }
   }

sub vertex_set
   {
   my ($G, $v) = @_;
   
   if ( exists  $G->{ VertexSetParent }->{ $v } )
      {
      # Path compression.
      $G->{ VertexSetParent }->{ $v } =
         $G->vertex_set( $G->{ VertexSetParent }->{ $v } )
         if $v ne $G->{ VertexSetParent }->{ $v };
      }
   else
      {
      $G->{ VertexSetParent }->{ $v } = $v;
      $G->{ VertexSetRank   }->{ $v } = 0;
      }
   return $G->{ VertexSetParent }->{ $v };
   }

sub add_edge
   {
   my ($G, $u, $v) = @_;
   
   $G->add_vertex($u);
   $G->add_vertex($v);
   $G->_union_vertex_set( $u, $v );
   push @{ $G->{ Succ }->{ $u }->{ $v } }, $v;
   push @{ $G->{ Pred }->{ $v }->{ $u } }, $u;
   return $G;
   }

sub _successors
   {
   my ($G, $v) = @_;
   my @s =
      defined $G->{ Succ }->{ $v } ?
      map { @{ $G->{ Succ }->{ $v }->{ $_ } } }
      sort keys %{ $G->{ Succ }->{ $v } } :
      ( );
   
   return @s;
   }

sub _predecessors
   {
   my ($G, $v) = @_;
   my @p =
        defined $G->{ Pred }->{ $v } ?
            map { @{ $G->{ Pred }->{ $v }->{ $_ } } }
                sort keys %{ $G->{ Pred }->{ $v } } :
            ( );

   return @p;
   }

sub neighbors
   {
   my ($G, $v) = @_;
   my @n = ($G->_successors($v), $G->_predecessors($v));
   return @n;
   }

use vars '*neighbours';
*neighbours = \&neighbors; # Keep both sides of the Atlantic happy.

sub successors
   {
   my ($G, $v) = @_;
   return $G->directed ? $G->_successors($v) : $G->neighbors($v);
   }

sub out_edges
   {
   my ($G, $v) = @_;
   return () unless $G->has_vertex($v);
   
   my @e = $G->_edges($v, undef);
   
   return wantarray ? @e : @e / 2;
   }

sub edges
   {
   my ($G, $u, $v) = @_;
   return () if defined $v and not $G->has_vertex($v);
   
   my @e =
      defined $u ?
            ( defined $v ?
              $G->_edges($u, $v) :
              ($G->in_edges($u), $G->out_edges($u)) ) :
              $G->_edges;
   return wantarray ? @e : @e / 2;
   }

sub delete_edge
   {
   my ($G, $u, $v) = @_;
   pop @{ $G->{ Succ }->{ $u }->{ $v } };
   pop @{ $G->{ Pred }->{ $v }->{ $u } };
   
   delete $G->{ Succ }->{ $u }->{ $v }
   unless @{ $G->{ Succ }->{ $u }->{ $v } };
   delete $G->{ Pred }->{ $v }->{ $u }
   unless @{ $G->{ Pred }->{ $v }->{ $u } };
   
   delete $G->{ Succ }->{ $u }
   unless keys %{ $G->{ Succ }->{ $u } };
   delete $G->{ Pred }->{ $v }
   unless keys %{ $G->{ Pred }->{ $v } };
   
   return $G;
   }

sub out_degree
   {
   my ($G, $v) = @_;
   return undef unless $G->has_vertex($v);
   
   if ($G->directed)
      {
      if (defined $v)
         {
         return scalar $G->out_edges($v);
         }
      else
         {
         my $out = 0;
         
         foreach my $v ($G->vertices)
            {
            $out += $G->out_degree($v);
            }
         return $out;
         }
      }
   else
      {
      return scalar $G->edges($v);
      }
   }

sub copy
   {
   my $G = shift;
   my $C = (ref $G)->new($G->vertices);
   
   if (my @E = $G->edges)
      {
      while (my ($u, $v) = splice(@E, 0, 2))
         {
         $C->add_edge($u, $v);
         }
      }
   
   $C->directed($G->directed);
   
   return $C;
   }

sub edge_classify
   {
   my $G = shift;
   my $unseen_successor =
      sub {
            my ($u, $v, $T) = @_;               
            # Freshly seen successors make for tree edges.
            push @{ $T->{ edge_class_list } },
                 [ $u, $v, 'tree' ];
        };
   my $seen_successor =
      sub {
            my ($u, $v, $T) = @_;
                        
            my $class;
        
            if ( $T->{ G }->directed )
               {
               $class = 'cross'; # Default for directed non-tree edges.
               
               unless ( exists $T->{ vertex_finished }->{ $v } )
                  {
                  $class = 'back';
                  }
               elsif ( $T->{ vertex_found }->{ $u } <
                          $T->{ vertex_found }->{ $v })
                  {
                  $class = 'forward';
                  }
               }
            else
               {
               # No cross nor forward edges in
               # an undirected graph, by definition.
               $class = 'back';
               }
            
            push @{ $T->{ edge_class_list } }, [ $u, $v, $class ];
            };
   use Graph::DFS;
   my $d =
      Graph::DFS->
            new( $G,
                 unseen_successor => $unseen_successor,
                 seen_successor   => $seen_successor,
                 @_);

   $d->preorder;

   return @{ $d->{ edge_class_list } };
   }

sub toposort
   {
   my $G = shift;
   my $d = Graph::DFS->new($G);
   $d->postorder; # That's it.
   }

sub largest_out_degree
   {
   my $G = shift;
   my @R = map { $_->[ 0 ] } # A Schwartzian Transform.
                sort { $b->[ 1 ] <=> $a->[ 1 ] || $a cmp $b }
                     map { [ $_, $G->out_degree($_) ] }
                         @_;

   return $R[ 0 ];
   }

1;
Revision:	1.2
Committed:	Fri Dec 10 13:41:40 2004 UTC (20 years, 4 months ago) by sashby
Content type:	text/plain
Branch:	MAIN
CVS Tags:	V1_1_7, V1_1_6, V1_1_5, V1_2_0-cand1, V1_1_4, V1_1_3, V1_1_2, V1_1_0_reltag8, V1_1_0_reltag7, V1_1_0_reltag6, V1_1_1, V1_1_0_reltag5, V1_1_0_reltag4, V1_1_0_reltag3, V1_1_0_reltag2, V1_1_0_reltag1, V1_1_0_reltag, V1_0_3-p4, V1_1_0_cand3, V1_1_0_cand2, V1_1_0_cand1, HEAD_SM_071214, forV1_1_0, v103_xml_071106, V1_0_3-p3, V1_0_3-p2, V1_1_0, v110p1, V110p6, V110p5, V110p4, V110p3, before110xmlBRmerge, V110p2, V110p1, V1_0_4p1, V1_0_3-p1, V1_0_3, V1_0_2, V1_0_2_p1, v102p1, V1_0_1, V1_0_0
Branch point for:	forBinLess_SCRAM, HEAD_BRANCH_SM_071214, v200branch, v103_with_xml, v103_branch
Changes since 1.1:	+373 -0 lines
Log Message:	Merged V1_0 branch to HEAD
#	Content
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;