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
#	User	Rev	Content
1	sashby	1.2	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;