File Coverage

blib/lib/FLAT/NFA.pm
Criterion Covered Total %
statement 85 273 31.1
branch 8 48 16.6
condition n/a
subroutine 15 28 53.5
pod 18 21 85.7
total 126 370 34.0


line stmt bran cond sub pod time code
1             package FLAT::NFA;
2              
3 6     6   2554 use strict;
  6         12  
  6         162  
4 6     6   27 use warnings;
  6         10  
  6         165  
5 6     6   30 use parent qw(FLAT::FA);
  6         10  
  6         38  
6              
7 6     6   308 use FLAT::Transition::Simple;
  6         13  
  6         503  
8 6     6   3120 use FLAT::Symbol::Regex;
  6         20  
  6         18275  
9              
10             =head1 NAME
11              
12             FLAT::NFA - Nondeterministic finite automata
13              
14             =head1 SYNOPSIS
15              
16             A FLAT::NFA object is a finite automata whose transitions are labeled
17             either with characters or the empty string (epsilon).
18              
19             =cut
20              
21             sub new {
22 975     975 0 1916 my $pkg = shift;
23 975         3839 my $self = $pkg->SUPER::new(@_);
24 975         2828 $self->{TRANS_CLASS} = "FLAT::Transition::Simple";
25 975         2122 $self->{ALPHA_CLASS} = "FLAT::Symbol::Regex";
26 975         1845 return $self;
27             }
28              
29             sub singleton {
30 0     0 0 0 my ( $class, $char ) = @_;
31 0         0 my $nfa = $class->new;
32              
33 0 0       0 if ( not defined $char ) {
    0          
34 0         0 $nfa->add_states(1);
35 0         0 $nfa->set_starting(0);
36             }
37             elsif ( $char eq "" ) {
38 0         0 $nfa->add_states(1);
39 0         0 $nfa->set_starting(0);
40 0         0 $nfa->set_accepting(0);
41             }
42             else {
43 0         0 $nfa->add_states(2);
44 0         0 $nfa->set_starting(0);
45 0         0 $nfa->set_accepting(1);
46 0         0 $nfa->set_transition( 0, 1, $char );
47             }
48 0         0 return $nfa;
49             }
50              
51 6     6 1 28 sub as_nfa { $_[0]->clone }
52              
53             sub union {
54 3     3 1 15 my @nfas = map { $_->as_nfa } @_;
  6         36  
55 3         20 my $result = $nfas[0]->clone;
56 3         39 $result->_swallow($_) for @nfas[ 1 .. $#nfas ];
57 3         676 $result;
58             }
59              
60             sub concat {
61 0     0 1 0 my @nfas = map { $_->as_nfa } @_;
  0         0  
62              
63 0         0 my $result = $nfas[0]->clone;
64 0         0 my @newstate = ( [ $result->get_states ] );
65 0         0 my @start = $result->get_starting;
66              
67 0         0 for ( 1 .. $#nfas ) {
68 0         0 push @newstate, [ $result->_swallow( $nfas[$_] ) ];
69             }
70              
71 0         0 $result->unset_accepting( $result->get_states );
72 0         0 $result->unset_starting( $result->get_states );
73 0         0 $result->set_starting(@start);
74              
75 0         0 for my $nfa_id ( 1 .. $#nfas ) {
76 0         0 for my $s1 ( $nfas[ $nfa_id - 1 ]->get_accepting ) {
77 0         0 for my $s2 ( $nfas[$nfa_id]->get_starting ) {
78 0         0 $result->set_transition( $newstate[ $nfa_id - 1 ][$s1], $newstate[$nfa_id][$s2], "" );
79             }
80             }
81             }
82              
83 0         0 $result->set_accepting( @{ $newstate[-1] }[ $nfas[-1]->get_accepting ] );
  0         0  
84              
85 0         0 $result;
86             }
87              
88             sub kleene {
89 0     0 1 0 my $result = $_[0]->clone;
90              
91 0         0 my ( $newstart, $newfinal ) = $result->add_states(2);
92              
93 0         0 $result->set_transition( $newstart, $_, "" ) for $result->get_starting;
94 0         0 $result->unset_starting( $result->get_starting );
95 0         0 $result->set_starting($newstart);
96              
97 0         0 $result->set_transition( $_, $newfinal, "" ) for $result->get_accepting;
98 0         0 $result->unset_accepting( $result->get_accepting );
99 0         0 $result->set_accepting($newfinal);
100              
101 0         0 $result->set_transition( $newstart, $newfinal, "" );
102 0         0 $result->set_transition( $newfinal, $newstart, "" );
103              
104 0         0 $result;
105             }
106              
107             sub reverse {
108 560     560 1 2985 my $self = $_[0]->clone;
109 560         3593 $self->_transpose;
110              
111 560         3936 my @start = $self->get_starting;
112 560         2206 my @final = $self->get_accepting;
113              
114 560         1980 $self->unset_accepting( $self->get_states );
115 560         2015 $self->unset_starting( $self->get_states );
116              
117 560         2348 $self->set_accepting(@start);
118 560         3009 $self->set_starting(@final);
119              
120 560         2081 $self;
121             }
122              
123             ###########
124              
125             sub is_empty {
126 3     3 1 10 my $self = shift;
127              
128 3         17 my @queue = $self->get_starting;
129 3         12 my %seen = map { $_ => 1 } @queue;
  6         28  
130              
131 3         15 while (@queue) {
132 18 50       28 return 0 if grep { $self->is_accepting($_) } @queue;
  80         160  
133 18         53 @queue = grep { !$seen{$_}++ } $self->successors( \@queue );
  122         262  
134             }
135 3         439 return 1;
136             }
137              
138             sub is_finite {
139 0     0 1 0 my $self = shift;
140              
141 0         0 my @alphabet = $self->alphabet;
142 0 0       0 return 1 if @alphabet == 0;
143              
144 0         0 my @queue = $self->get_starting;
145 0         0 my %seen = map { $_ => 1 } @queue;
  0         0  
146              
147 0         0 while (@queue) {
148 0         0 @queue = grep { !$seen{$_}++ } $self->successors( \@queue );
  0         0  
149             }
150              
151 0         0 for my $s ( grep { $self->is_accepting($_) } keys %seen ) {
  0         0  
152 0         0 @queue = $self->epsilon_closure($s);
153 0         0 %seen = map { $_ => 1 } @queue;
  0         0  
154              
155 0         0 while (@queue) {
156 0         0 my @next = $self->epsilon_closure( $self->successors( \@queue, \@alphabet ) );
157              
158 0 0       0 return 0 if grep { $s eq $_ } @next;
  0         0  
159 0         0 @queue = grep { !$seen{$_}++ } @next;
  0         0  
160             }
161             }
162 0         0 return 1;
163             }
164              
165             sub epsilon_closure {
166 5128     5128 1 9823 my ( $self, @states ) = @_;
167 5128         8569 my %seen = map { $_ => 1 } @states;
  4446         9650  
168 5128         8031 my @queue = @states;
169              
170 5128         10523 while (@queue) {
171 3710         10029 @queue = grep { !$seen{$_}++ } $self->successors( \@queue, "" );
  11607         25337  
172             }
173              
174 5128         16088 keys %seen;
175             }
176              
177             sub contains {
178 0     0 1 0 my ( $self, $string ) = @_;
179              
180 0         0 my @active = $self->epsilon_closure( $self->get_starting );
181 0         0 for my $char ( split //, $string ) {
182 0 0       0 return 0 if !@active;
183 0         0 @active = $self->epsilon_closure( $self->successors( \@active, $char ) );
184             }
185 0         0 return !!grep { $self->is_accepting($_) } @active;
  0         0  
186             }
187              
188             sub trace {
189 0     0 1 0 my ( $self, $string ) = @_;
190              
191 0         0 my @trace = ( [ $self->epsilon_closure( $self->get_starting ) ] );
192              
193 0         0 for my $char ( split //, $string ) {
194 0         0 push @trace, [ $self->epsilon_closure( $self->successors( $trace[-1], $char ) ) ];
195             }
196 0         0 return @trace;
197             }
198             ############
199              
200             sub _extend_alphabet {
201 12     12   39 my ( $self, @alpha ) = @_;
202              
203 12         23 my %alpha = map { $_ => 1 } @alpha;
  72         114  
204 12         36 delete $alpha{$_} for $self->alphabet;
205              
206 12 50       64 return if not keys %alpha;
207              
208 0         0 my $trash = $self->add_states(1);
209 0         0 for my $state ( $self->get_states ) {
210 0 0       0 next if $state eq $trash;
211 0         0 for my $char ( keys %alpha ) {
212 0         0 $self->add_transition( $state, $trash, $char );
213             }
214             }
215 0         0 $self->add_transition( $trash, $trash, $self->alphabet );
216             }
217              
218             ######## transformations
219              
220             sub as_min_dfa {
221 12     12 1 63 my $self = shift;
222 12         55 return $self->as_dfa()->as_min_dfa();
223             }
224              
225             # subset construction
226             sub as_dfa {
227 149     149 1 285 my $self = shift;
228              
229 149         741 my $result = FLAT::DFA->new;
230 149         282 my %subset;
231              
232 149         461 my %final = map { $_ => 1 } $self->get_accepting;
  217         739  
233 149         574 my @start = sort { $a <=> $b } $self->epsilon_closure( $self->get_starting );
  438         749  
234              
235 149         581 my $start = $subset{ _SET_ID(@start) } = $result->add_states(1);
236 149         836 $result->set_starting($start);
237              
238             $result->set_accepting($start)
239 149 100       695 if grep $_, @final{@start};
240              
241 149         399 my @queue = ( \@start );
242 149         382 while (@queue) {
243 1151         1788 my @states = @{ shift @queue };
  1151         3453  
244 1151         2825 my $S = $subset{ _SET_ID(@states) };
245              
246 1151         3521 for my $symb ( $self->alphabet ) {
247 4979         12859 my @to = $self->epsilon_closure( $self->successors( \@states, $symb ) );
248              
249 4979 100       12740 if ( not exists $subset{ _SET_ID(@to) } ) {
250 1002         1968 push @queue, \@to;
251 1002         3185 my $T = $subset{ _SET_ID(@to) } = $result->add_states(1);
252             $result->set_accepting($T)
253 1002 100       6287 if grep $_, @final{@to};
254             }
255              
256 4979         10350 $result->add_transition( $S, $subset{ _SET_ID(@to) }, $symb );
257             }
258             }
259              
260 149         2290 $result;
261             }
262              
263             ############ Formatted output
264              
265             # Format that Dr. Sukhamay KUNDU likes to use in his assignments :)
266             # This format is just a undirected graph - so transition and state info is lost
267              
268             sub as_undirected {
269 0     0 1 0 my $self = shift;
270 0         0 my @symbols = $self->alphabet();
271 0         0 my @states = $self->get_states();
272 0         0 my %edges = ();
273 0         0 foreach (@states) {
274 0         0 my $s = $_;
275 0         0 foreach (@symbols) {
276 0         0 my $a = $_;
277              
278             # foreach state, get all nodes connected to it; ignore symbols and
279             # treat transitions simply as directed
280 0         0 push( @{ $edges{$s} }, $self->successors( $s, $a ) );
  0         0  
281 0         0 foreach ( $self->successors( $s, $a ) ) {
282 0         0 push( @{ $edges{$_} }, $s );
  0         0  
283             }
284             }
285             }
286 0         0 my @lines = ( ( $#states + 1 ) );
287 0         0 foreach ( sort { $a <=> $b; } ( keys(%edges) ) ) { #<-- iterate over numerically sorted list of keys
  0         0  
288 0         0 @{ $edges{$_} } = sort { $a <=> $b; } $self->array_unique( @{ $edges{$_} } ); #<- make items unique and sort numerically
  0         0  
  0         0  
  0         0  
289 0         0 push( @lines, sprintf( "%s(%s):%s", $_, ( $#{ $edges{$_} } + 1 ), join( ' ', @{ $edges{$_} } ) ) );
  0         0  
  0         0  
290             }
291 0         0 return join( "\n", @lines );
292             }
293              
294             # Format that Dr. Sukhamay KUNDU likes to use in his assignments :)
295             # This format is just a directed graph - so transition and state info is lost
296              
297             sub as_digraph {
298 0     0 1 0 my $self = shift;
299 0         0 my @symbols = $self->alphabet();
300 0         0 my @states = $self->get_states();
301 0         0 my @lines = ();
302 0         0 foreach (@states) {
303 0         0 my $s = $_;
304 0         0 my @edges = ();
305 0         0 foreach (@symbols) {
306 0         0 my $a = $_;
307              
308             # foreach state, get all nodes connected to it; ignore symbols and
309             # treat transitions simply as directed
310 0         0 push( @edges, $self->successors( $s, $a ) );
311             }
312 0         0 @edges = sort { $a <=> $b; } $self->array_unique(@edges); #<- make items unique and sort numerically
  0         0  
313 0         0 push( @lines, sprintf( "%s(%s): %s", $s, ( $#edges + 1 ), join( ' ', @edges ) ) );
314             }
315 0         0 return sprintf( "%s\n%s", ( $#states + 1 ), join( "\n", @lines ) );
316             }
317              
318             # Graph Description Language, aiSee, etc
319             sub as_gdl {
320 0     0 1 0 my $self = shift;
321              
322 0 0       0 my @states = map { sprintf qq{node: { title:"%s" shape:circle borderstyle: %s}\n}, $_, ( $self->is_accepting($_) ? "double bordercolor: red" : "solid" ) } $self->get_states;
  0         0  
323              
324 0         0 my @trans;
325 0         0 for my $s1 ( $self->get_states ) {
326 0         0 for my $s2 ( $self->get_states ) {
327 0         0 my $t = $self->get_transition( $s1, $s2 );
328              
329 0 0       0 if ( defined $t ) {
330 0         0 push @trans, sprintf qq[edge: { source: "%s" target: "%s" label: "%s" arrowstyle: line }\n], $s1, $s2, $t->as_string;
331             }
332             }
333             }
334              
335 0         0 return sprintf "graph: {\ndisplay_edge_labels: yes\n\n%s\n%s}\n", join( "", @states ), join( "", @trans );
336             }
337              
338             # JFLAP, for importing into it
339             sub as_jflap {
340 0     0 0 0 my $self = shift;
341 0         0 my $XMLstart = <
342            
343            
344             fa
345            
346             END
347 0         0 my $XMLend = <
348            
349            
350             END
351 0 0       0 my @states = map { sprintf( qq{\n \n%s%s \n}, $_, $_, ( $self->is_starting($_) ? " \n" : '' ), ( $self->is_accepting($_) ? " \n" : '' ) ) } $self->get_states;
  0 0       0  
352 0         0 my @trans;
353 0         0 for my $s1 ( $self->get_states ) {
354 0         0 for my $s2 ( $self->get_states ) {
355 0         0 my $t = $self->get_transition( $s1, $s2 );
356 0 0       0 if ( defined $t ) {
357 0         0 my $label = $t->as_string;
358 0 0       0 $label = ( $label eq 'epsilon' ) ? '' : sprintf( "%s", $label );
359 0         0 push @trans, sprintf( "\n \n %s\n %s\n %s\n \n", $s1, $s2, $label );
360             }
361             }
362             }
363              
364 0         0 return sprintf( "%s\n\n%s\n%s%s\n", $XMLstart, join( "", @states ), join( "", @trans ), $XMLend );
365             }
366              
367             # Graphviz: dot, etc
368             ## digraph, directed
369             sub as_graphviz {
370 0     0 1 0 my $self = shift;
371              
372 0 0       0 my @states = map { sprintf qq{%s [label="%s",shape=%s]\n}, $_, ( $self->is_starting($_) ? "start ($_)" : "$_" ), ( $self->is_accepting($_) ? "doublecircle" : "circle" ) } $self->get_states;
  0 0       0  
373              
374 0         0 my @trans;
375 0         0 for my $s1 ( $self->get_states ) {
376 0         0 for my $s2 ( $self->get_states ) {
377 0         0 my $t = $self->get_transition( $s1, $s2 );
378              
379 0 0       0 if ( defined $t ) {
380 0         0 push @trans, sprintf qq[%s -> %s [label="%s"]\n], $s1, $s2, $t->as_string;
381             }
382             }
383             }
384              
385 0         0 return sprintf "digraph G {\ngraph [rankdir=LR]\n\n%s\n%s}\n", join( "", @states ), join( "", @trans );
386             }
387             ## undirected
388             sub as_undirected_graphviz {
389 0     0 1 0 my $self = shift;
390              
391 0         0 my @states = map { sprintf qq{%s [label="%s",shape=%s]\n}, $_, ("$_"), ("circle") } $self->get_states;
  0         0  
392              
393 0         0 my @trans;
394 0         0 for my $s1 ( $self->get_states ) {
395 0         0 for my $s2 ( $self->get_states ) {
396 0         0 my $t = $self->get_transition( $s1, $s2 );
397              
398 0 0       0 if ( defined $t ) {
399 0         0 push @trans, sprintf qq[%s -- %s\n], $s1, $s2, $t->as_string;
400             }
401             }
402             }
403              
404 0         0 return sprintf "graph G {\ngraph [rankdir=LR]\n\n%s\n%s}\n", join( "", @states ), join( "", @trans );
405             }
406              
407             #### end formatted output section - probably deserves its own module
408              
409             sub _SET_ID {
410 12260     12260   36015 return join "\0", sort { $a <=> $b } @_;
  84620         98818  
411             }
412              
413             sub as_summary {
414 0     0 1   my $self = shift;
415 0           my $out = '';
416 0           $out .= sprintf("States : ");
417 0           my @start;
418             my @final;
419 0           foreach ( $self->get_states() ) {
420 0           $out .= sprintf "'$_' ";
421 0 0         if ( $self->is_starting($_) ) {
422 0           push( @start, $_ );
423             }
424 0 0         if ( $self->is_accepting($_) ) {
425 0           push( @final, $_ );
426             }
427             }
428 0           $out .= sprintf( "\nStart State : '%s'\n", join( '', @start ) );
429 0           $out .= sprintf("Final State(s) : ");
430 0           foreach (@final) {
431 0           $out .= sprintf "'$_' ";
432             }
433 0           $out .= sprintf("\nAlphabet : ");
434 0           foreach ( $self->alphabet() ) {
435 0           $out .= sprintf "'$_' ";
436             }
437 0           $out .= sprintf("\nTransitions :\n");
438 0           my @trans;
439 0           for my $s1 ( $self->get_states ) {
440 0           for my $s2 ( $self->get_states ) {
441 0           my $t = $self->get_transition( $s1, $s2 );
442 0 0         if ( defined $t ) {
443 0           push @trans, sprintf qq[%s -> %s on "%s"\n], $s1, $s2, $t->as_string;
444             }
445             }
446             }
447 0           $out .= join( '', @trans );
448 0           return $out;
449             }
450              
451             1;
452              
453             __END__