ViewVC Help

View File | Revision Log | Show Annotations | Root Listing

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

Comparing COMP/SCRAM/src/Graph/Traversal.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::Traversal;
2	+	use strict;
3	+	local $^W = 1;
4	+	use Graph::Base;
5	+	use vars qw(@ISA);
6	+	@ISA = qw(Graph::Base);
7	+
8	+	sub new
9	+	{
10	+	my $class  = shift;
11	+	my $G      = shift;
12	+	my $S = { G => $G };
13	+	bless $S, $class;
14	+	$S->reset(@_);
15	+	return $S;
16	+	}
17	+
18	+	sub reset
19	+	{
20	+	my $S = shift;
21	+	my $G = $S->{ G };
22	+
23	+	@{ $S->{ pool } }{ $G->vertices } = ( );
24	+	$S->{ active_list       }         = [ ];
25	+	$S->{ root_list         }         = [ ];
26	+	$S->{ preorder_list     }         = [ ];
27	+	$S->{ postorder_list    }         = [ ];
28	+	$S->{ active_pool       }         = { };
29	+	$S->{ vertex_found      }         = { };
30	+	$S->{ vertex_root       }         = { };
31	+	$S->{ vertex_successors }         = { };
32	+	$S->{ param             }         = { @_ };
33	+	$S->{ when              }         = 0;
34	+	}
35	+
36	+	sub _get_next_root_vertex
37	+	{
38	+	my $S      = shift;
39	+	my %param  = ( %{ $S->{ param } }, @_ ? %{ $_[0] } : ( ));
40	+	my $G      = $S->{ G };
41	+
42	+	if ( exists $param{ get_next_root } )
43	+	{
44	+	if ( ref $param{ get_next_root } eq 'CODE' )
45	+	{
46	+	return $param{ get_next_root }->( $S, %param ); # Dynamic.
47	+	}
48	+	else
49	+	{
50	+	my $get_next_root = $param{ get_next_root };   # Static.
51	+
52	+	# Use only once.
53	+	delete $S->{ param }->{ get_next_root };
54	+	delete $_[0]->{ get_next_root } if @_;
55	+
56	+	return $get_next_root;
57	+	}
58	+	}
59	+	else
60	+	{
61	+	return $G->largest_out_degree( keys %{ $S->{ pool } } );
62	+	}
63	+	}
64	+
65	+	sub _mark_vertex_found
66	+	{
67	+	my ( $S, $u ) = @_;
68	+
69	+	$S->{ vertex_found }->{ $u } = $S->{ when }++;
70	+	delete $S->{ pool }->{ $u };
71	+	}
72	+
73	+	sub _next_state
74	+	{
75	+	my $S = shift;       # The current state.
76	+	my $G = $S->{ G };   # The current graph.
77	+	my %param = ( %{ $S->{ param } }, @_);
78	+	my ($u, $v); # The current vertex and its successor.
79	+	my $return = 0;      # Return when this becomes true.
80	+
81	+	until ( $return )
82	+	{
83	+	# Initialize our search when needed.
84	+	# (Start up a new tree.)
85	+	unless ( @{ $S->{ active_list } } )
86	+	{
87	+	do
88	+	{
89	+	$u = $S->_get_next_root_vertex(\%param);
90	+	return wantarray ? ( ) : $u unless defined $u;
91	+	} while exists $S->{ vertex_found }->{ $u };
92	+
93	+	# A new root vertex found.
94	+	push @{ $S->{ active_list } }, $u;
95	+	$S->{ active_pool }->{ $u } = 1;
96	+	push @{ $S->{ root_list   } }, $u;
97	+	$S->{ vertex_root }->{ $u } = $#{ $S->{ root_list } };
98	+	}
99	+
100	+	# Get the current vertex.
101	+	$u = $param{ current }->( $S );
102	+	return wantarray ? () : $u unless defined $u;
103	+
104	+	# Record the vertex if necessary.
105	+	unless ( exists $S->{ vertex_found }->{ $u } )
106	+	{
107	+	$S->_mark_vertex_found( $u );
108	+	push @{ $S->{ preorder_list } }, $u;
109	+	# Time to return?
110	+	$return++ if $param{ return_next_preorder };
111	+	}
112	+
113	+	# Initialized the list successors if necessary.
114	+	$S->{ vertex_successors }->{ $u } = [ $G->successors( $u ) ]
115	+	unless exists $S->{ vertex_successors }->{ $u };
116	+
117	+	# Get the next successor vertex.
118	+	$v = shift @{ $S->{ vertex_successors }->{ $u } };
119	+
120	+	if ( defined $v )
121	+	{
122	+	# Something to do for each successor?
123	+	$param{ successor }->( $u, $v, $S )
124	+	if exists $param{ successor };
125	+
126	+	unless ( exists $S->{ vertex_found }->{ $v } )
127	+	{
128	+	# An unseen successor.
129	+	$S->_mark_vertex_found( $v );
130	+	push @{ $S->{ preorder_list } }, $v;
131	+	$S->{ vertex_root }->{ $v } = $S->{ vertex_root }->{ $u };
132	+	push @{ $S->{ active_list } }, $v;
133	+	$S->{ active_pool }->{ $v } = 1;
134	+
135	+	# Something to for each unseen edge?
136	+	# For multiedges, triggered only for the first edge.
137	+	$param{ unseen_successor }->( $u, $v, $S )
138	+	if exists $param{ unseen_successor };
139	+	}
140	+	else
141	+	{
142	+	# Something to do for each seen edge?
143	+	# For multiedges, triggered for the 2nd, etc, edges.
144	+	$param{ seen_successor }->( $u, $v, $S )
145	+	if exists $param{ seen_successor };
146	+	}
147	+
148	+	# Time to return?
149	+	$return++ if $param{ return_next_edge };
150	+
151	+	}
152	+	elsif ( not exists $S->{ vertex_finished }->{ $u } )
153	+	{
154	+	# Finish off with this vertex (we run out of descendants).
155	+	$param{ finish }->( $S );
156	+	$S->{ vertex_finished }->{ $u } = $S->{ when }++;
157	+	push @{ $S->{ postorder_list } }, $u;
158	+	delete $S->{ active_pool }->{ $u };
159	+
160	+	# Time to return?
161	+	$return++ if $param{ return_next_postorder };
162	+	}
163	+	}
164	+
165	+	# Return an edge if so asked.
166	+	return ( $u, $v ) if $param{ return_next_edge };
167	+
168	+	# Return a vertex.
169	+	return $u;
170	+	}
171	+
172	+	sub next_preorder
173	+	{
174	+	my $S = shift;
175	+	$S->_next_state( return_next_preorder => 1, @_ );
176	+	}
177	+
178	+	sub next_postorder
179	+	{
180	+	my $S = shift;
181	+	$S->_next_state( return_next_postorder => 1, @_ );
182	+	}
183	+
184	+	sub next_edge
185	+	{
186	+	my $S = shift;
187	+	$S->_next_state( return_next_edge => 1, @_ );
188	+	}
189	+
190	+	sub preorder
191	+	{
192	+	my $S = shift;
193	+	1 while defined $S->next_preorder;  # Process entire graph.
194	+	return @{ $S->{ preorder_list } };
195	+	}
196	+
197	+	sub postorder
198	+	{
199	+	my $S = shift;
200	+	1 while defined $S->next_postorder; # Process entire graph.
201	+	return @{ $S->{ postorder_list } };
202	+	}
203	+
204	+	sub edges
205	+	{
206	+	my $S = shift;
207	+	my (@E, $u, $v);
208	+	push @E, $u, $v while ($u, $v) = $S->next_edge;
209	+	return @E;
210	+	}
211	+
212	+	sub roots
213	+	{
214	+	my $S = shift;
215	+
216	+	$S->preorder
217	+	unless exists $S->{ preorder_list } and
218	+	@{ $S->{ preorder_list } } == $S->{ G }->vertices;
219	+	return @{ $S->{ root_list } };
220	+	}
221	+
222	+	sub vertex_roots
223	+	{
224	+	my $S = shift;
225	+	my $G = $S->{ G };
226	+
227	+	$S->preorder
228	+	unless exists $S->{ preorder_list } and
229	+	@{ $S->{ preorder_list } } == $G->vertices;
230	+	return
231	+	map { ( $_, $S->{ vertex_root }->{ $_ } ) } $G->vertices;
232	+	}
233	+
234	+	sub DELETE
235	+	{
236	+	my $S = shift;
237	+	delete $S->{ G }; # Release the graph.
238	+	}
239	+
240	+	1;

Diff Legend

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