File Coverage

blib/lib/FLAT/Legacy/FA/PFA.pm
Criterion Covered Total %
statement 326 552 59.0
branch 41 122 33.6
condition 5 24 20.8
subroutine 36 51 70.5
pod 0 46 0.0
total 408 795 51.3


line stmt bran cond sub pod time code
1             # $Revision: 1.5 $ $Date: 2006/03/02 21:00:28 $ $Author: estrabd $
2              
3             package FLAT::Legacy::FA::PFA;
4              
5 3     3   4652 use base 'FLAT::Legacy::FA';
  3         3  
  3         243  
6 3     3   16 use strict;
  3         5  
  3         65  
7 3     3   12 use Carp;
  3         4  
  3         212  
8              
9 3     3   15 use FLAT::Legacy::FA::NFA;
  3         4  
  3         54  
10 3     3   9 use Data::Dumper;
  3         3  
  3         13663  
11              
12             sub new {
13 861     861 0 774 my $class = shift;
14 861         4574 bless {
15             _START_NODES => [], # start node - subset of nodes to start on;
16             _NODES => [], # nodes - nodes make up nodes in PFA
17             _ACTIVE_NODES => [], # list of active nodes - corresponds to a "node"
18             _FINAL_NODES => [], # Set of final node - a string is accepted when set of active nodes
19             # is exactly this and end of string is encountered
20             _SYMBOLS => [], # Symbols
21             _TRANSITIONS => {}, # Nodal transitions on symbol (gamma functions)
22             _EPSILON => 'epsilon', # how an epsilon transition is represented
23             _LAMBDA => 'lambda', # how lambda transitions is represented
24             _TIED => [], # stores look up of tied nodes; computed when
25             # $self->find_tied() is called
26             }, $class;
27             }
28              
29             sub load_file {
30 0     0 0 0 my $self = shift;
31 0         0 my $file = shift;
32 0 0       0 if (-e $file) {
33 0         0 open (PFA,"<$file");
34 0         0 my $string = undef;
35 0         0 while () {
36 0         0 $string .= $_;
37             }
38 0         0 close (PFA);
39 0         0 $self->load_string($string);
40             }
41             }
42              
43             sub load_string {
44 0     0 0 0 my $self = shift;
45 0         0 my $string = shift;
46 0         0 my @lines = split("\n",$string);
47 0         0 my $CURR_NODE = undef;
48 0         0 foreach (@lines) {
49             # strip comments
50 0         0 $_ =~ s/\s*#.*$//;
51             # check if line is a node, transition, or keyword
52 0 0 0     0 if (m/^\s*([\w\d]*)\s*:\s*$/) {
    0 0        
    0          
53             #print STDERR "Found transitions for node $1\n";
54 0         0 $self->add_node($1);
55 0         0 $CURR_NODE = $1;
56             } elsif (m/^\s*([\w\d]*)\s*([\w\d,]*)\s*$/ && ! m/^$/) {
57             # treat as transition
58             #print STDERR "Input: '$1' goes to $2\n";
59 0         0 my @s = split(',',$2);
60 0         0 $self->add_transition($CURR_NODE,$1,@s);
61 0         0 $self->add_symbol($1);
62             } elsif (m/^\s*([\w\d]*)\s*::\s*([\w\d,]*)\s*$/ && ! m/^$/) {
63             # Check for known header keywords
64 0         0 my $val = $2;
65 0 0       0 if ($1 =~ m/START/i) {
    0          
    0          
    0          
66 0         0 my @s = split(',',$val);
67 0         0 $self->set_start(@s);
68             } elsif ($1 =~ m/FINAL/i) {
69 0         0 my @s = split(',',$val);
70 0         0 $self->add_final(@s);
71             } elsif ($1 =~ m/EPSILON/i) {
72 0         0 $self->set_epsilon($val);
73             } elsif ($1 =~ m/LAMBDA/i) {
74 0         0 $self->set_lambda($val);
75             } else {
76 0         0 print STDERR "WARNING: $1 is not a valid header...\n";
77             }
78             }
79             }
80 0         0 $self->find_tied();
81 0         0 return;
82             }
83              
84             sub jump_start {
85 521     521 0 424 my $self = shift;
86 521         862 my $PFA = FLAT::Legacy::FA::PFA->new();
87 521         506 my $symbol = shift;
88 521 50       626 if (!defined($symbol)) {
89 0         0 $symbol = $PFA->get_epsilon_symbol();
90             } else {
91 521         533 chomp($symbol);
92             }
93 521         12224 my $newstart = crypt(rand 8,join('',[rand 8, rand 8]));
94 521         6132 my $newfinal = crypt(rand 8,join('',[rand 8, rand 8]));
95             # add states
96 521         963 $PFA->add_node($newstart,$newfinal);
97             # add symbol
98 521         905 $PFA->add_symbol($symbol);
99             # set start and final
100 521         734 $PFA->set_start($newstart);
101 521         659 $PFA->add_final($newfinal);
102             # add single transition
103 521         815 $PFA->add_transition($newstart,$symbol,$newfinal);
104 521         958 return $PFA;
105             }
106              
107             sub find_tied {
108 77     77 0 95 my $self = shift;
109 77         137 my $lambda = $self->get_lambda_symbol();
110 77         132 my %tied = ();
111 77         130 foreach my $node ($self->get_nodes()) {
112 1354         1569 my @trans = $self->get_lambda_transitions($node);
113 1354 100       2036 if (@trans) {
114 162         243 my $name = $self->serialize_name(@trans);
115 162 100       306 if (!defined($tied{$name})) {
116 108         186 $tied{$name} = [];
117             }
118 162         132 push(@{$tied{$name}},$node);
  162         280  
119             }
120             }
121 77         227 foreach my $t (keys(%tied)) {
122 108         88 push(@{$self->{_TIED}},[@{$tied{$t}}]);
  108         123  
  108         169  
123             }
124 77         207 return;
125             }
126              
127             sub get_tied {
128 3906     3906 0 2998 my $self = shift;
129 3906         2510 return @{$self->{_TIED}};
  3906         6043  
130             }
131              
132             sub has_tied {
133 3368     3368 0 3009 my $self = shift;
134 3368         4622 my @testset = @_;
135 3368         2680 my $ok = 0;
136 3368         4451 foreach my $tied ($self->get_tied()) {
137 12702         8068 my $allornone = 0;
138 12702         7376 foreach my $tn (@{$tied}) {
  12702         10551  
139             #if $tn is in @testset, increment $allornone
140 18885 100       26952 if ($self->is_member($tn,@testset)) {
141 2797         2862 $allornone++;
142             }
143             }
144             # if $allornone is equal to the number of items in the tied set,
145             # assume that the entire set is in @testset thus satisfiying the
146             # tied requirement for lambda transitions
147 12702 100       8488 if ($allornone == @{$tied}) {
  12702         17426  
148 538         341 $ok++;
149 538         550 last;
150             }
151             }
152 3368         10668 return $ok;
153             }
154              
155             sub extract_tied {
156 538     538 0 560 my $self = shift;
157 538         835 my @testset = @_;
158 538         620 my @ret = ();
159 538         812 foreach my $tied ($self->get_tied()) {
160 4136         2574 my $count = 0;
161 4136         3001 my @tmp = ();
162 4136         2755 foreach my $tn (@{$tied}) {
  4136         3655  
163             #if $tn is in @testset, increment $count
164 6204 100       8655 if ($self->is_member($tn,@testset)) {
165 1237         1088 push(@tmp,$tn);
166 1237         1287 $count++;
167             }
168             }
169 4136 100       2786 if ($count == @{$tied}) {
  4136         6389  
170 538         553 foreach (@tmp) {
171 807 50       1422 if (!$self->is_member($_,@ret)) {
172 807         1160 push(@ret,$_);
173             }
174             }
175             }
176             }
177 538         1085 return @ret;
178             }
179              
180             sub to_nfa {
181 77     77 0 726 my $self = shift;
182 77         114 my @Dstates = (); # stack of new states to find transitions for
183 77         104 my %Dtran =(); # hash of serialized state names that have been searched
184             # New NFA object reference
185 77         364 my $NFA = FLAT::Legacy::FA::NFA->new();
186 77         177 $NFA->set_epsilon($self->get_epsilon_symbol());
187             # Initialize NFA start state by performing e-closure on the PFA start state
188 77         124 my @Start = $self->get_start();
189             # Add this state to Dstates - subsets stored as anonymous arrays (no faking here!)
190 77         165 push(@Dstates,[sort(@Start)]);
191             # Serialize subset into new state name - i.e, generate string-ified name
192 77         166 my $ns = $self->serialize_name(@Start);
193             # add to Dtran as well for tracking
194 77         115 $Dtran{$ns}++;
195             # serialize final node set
196 77         138 my $final_state = $self->serialize_name($self->get_final());
197             # set this state as final - since there will be only ONE!
198 77         232 $NFA->add_final($final_state);
199 77         134 $NFA->add_state($final_state);
200             # Add start state to NFA (placeholder Dtran not used)
201 77         203 $NFA->set_start($ns);
202             # Add new state (serialized name) to NFA state array
203 77         154 $NFA->add_state($ns);
204             # Loop until Dstate stack is exhausted
205 77         164 while (@Dstates) {
206             # shift next state off to check
207 3914         2930 my @T = @{pop @Dstates};
  3914         6382  
208             # Serialize subset into a string name
209 3914         5943 my $CURR_STATE = $self->serialize_name(@T);
210             #print "$CURR_STATE\n";
211             # loop over each input symbol
212 3914         7057 foreach my $symbol ($self->get_symbols()) {
213 15094 100 100     17211 if ($symbol eq $self->get_lambda_symbol() && $self->has_tied(@T)) {
    100          
214             # get flattened list of all tied nodes in @T
215 538         919 my @tied = $self->extract_tied(@T);
216 538         529 my @new = ();
217 538         473 my @next = ();
218 538         645 foreach my $t (@tied) {
219 807         1132 my @trans = $self->get_lambda_transitions($t);
220 807         1049 foreach (@trans) {
221 1076 100       1987 if (!$self->is_member($_,@new)) {
222 807         1119 push(@new,$_);
223             }
224             } # foreach (@trans)
225             } # foreach my $t (@tied)
226             # @next contains new, obviously
227 538         585 push(@next,@new);
228             # @next also contains @T - @tied
229 538         1142 push(@next,$self->compliment(\@T,\@tied));
230             # see if the resulting state can be added to @Dstates
231 538         1046 my $state = $self->serialize_name(@next);
232 538 100       1260 if (!defined($Dtran{$state})) {
233 151         302 push(@Dstates,[sort(@next)]);
234 151         253 $Dtran{$state}++;
235             # add transition to $NFA
236             }
237 538         918 $NFA->add_transition($CURR_STATE,$self->get_epsilon_symbol(),$state);
238             } elsif ($symbol ne $self->get_lambda_symbol()) {
239 11726         10293 foreach my $node (@T) {
240 32822 100       57064 if (defined($self->{_TRANSITIONS}{$node}{$symbol})) {
241 7686         9855 my @new = $self->get_transition_on($node,$symbol);
242 7686         7647 foreach my $new (@new) {
243 8234         19470 my @next = $self->compliment(\@T,[$node]);
244 8234         10364 push(@next,$new);
245 8234         11013 my $state = $self->serialize_name(@next);
246 8234 100       15558 if (!defined($Dtran{$state})) {
247 3686         6414 push(@Dstates,[sort(@next)]);
248 3686         5993 $Dtran{$state}++;
249             }
250             # add transition to $NFA
251 8234         16104 $NFA->add_transition($CURR_STATE,$symbol,$state);
252             } # foreach my $new (@new)
253             }
254             } # foreach my $node (@T)
255             }
256             } # foreach my $symbol ($self->get_symbols())
257             }
258 77         1481 return $NFA;
259             }
260              
261             sub serialize_name {
262 13002     13002 0 10001 my $self = shift;
263             # note that the nature of Perl subs causes @_ to be flattened
264 13002         38384 my $name = join('_',sort(@_));
265 13002         13137 return $name;
266             }
267              
268             sub set_start {
269 1016     1016 0 925 my $self = shift;
270             # flushes out current start nodes, and saves in entire list of provided nodes
271 1016         1314 $self->{_START_NODES} = [@_];
272             # these nodes are also reset as the default active nodes
273 1016         1563 $self->set_active(@_);
274             # add to node list if not already there
275 1016         1147 $self->add_node(@_);
276 1016         640 return;
277             }
278              
279             sub get_start {
280 1016     1016 0 797 my $self = shift;
281 1016         654 return @{$self->{_START_NODES}};
  1016         1580  
282             }
283              
284             sub set_active {
285 1016     1016 0 950 my $self = shift;
286 1016         1130 $self->{_ACTIVE_NODES} = [@_];
287             # add to node list if not already there
288 1016         811 return;
289             }
290              
291             sub get_active {
292 0     0 0 0 my $self = shift;
293 0         0 return @{$self->{_ACTIVE_NODES}};
  0         0  
294             }
295              
296             sub add_node {
297 3979     3979 0 2943 my $self = shift;
298 3979         3300 foreach my $node (@_) {
299 5042 100       4906 if (!$self->is_node($node)) {
300 3636         2237 push(@{$self->{_NODES}},$node);
  3636         5642  
301             }
302             }
303 3979         3187 return;
304             }
305              
306             sub get_nodes {
307 18980     18980 0 12121 my $self = shift;
308 18980         11101 return @{$self->{_NODES}};
  18980         57225  
309             }
310              
311             sub add_transition {
312 2983     2983 0 2048 my $self = shift;
313 2983         2065 my $node = shift;
314 2983         1919 my $symbol = shift;
315 2983         4385 $self->add_symbol($symbol);
316 2983         2587 foreach my $next (@_) {
317 3189 50       1983 if (!$self->is_member($next,@{$self->{_TRANSITIONS}{$node}{$symbol}})) {
  3189         8087  
318 3189         1977 push (@{$self->{_TRANSITIONS}{$node}{$symbol}},$next);
  3189         5293  
319             }
320             }
321 2983         3272 return;
322             }
323              
324             sub get_transition_on {
325 7686     7686 0 5574 my $self = shift;
326 7686         5089 my $node = shift;
327 7686         5593 my $symbol = shift;
328 7686         7995 my @ret = undef;
329 7686 50 33     9699 if ($self->is_node($node) && $self->is_symbol($symbol)) {
330 7686 50       12105 if (defined($self->{_TRANSITIONS}{$node}{$symbol})) {
331 7686         5199 @ret = @{$self->{_TRANSITIONS}{$node}{$symbol}};
  7686         12166  
332             }
333             }
334 7686         15976 return @ret;
335             }
336              
337             sub is_start {
338 0     0 0 0 my $self = shift;
339 0         0 return $self->is_member(shift,$self->get_start());
340             }
341              
342             sub set_epsilon {
343 339     339 0 255 my $self = shift;
344 339         236 my $epsilon = shift;
345 339         319 $self->{_EPSILON} = $epsilon;
346 339         260 return;
347             }
348              
349             sub get_epsilon_symbol {
350 2589     2589 0 2203 my $self = shift;
351 2589         4859 return $self->{_EPSILON};
352             }
353              
354             sub get_epsilon_transitions {
355 0     0 0 0 my $self = shift;
356 0         0 my $node = shift;
357 0         0 my @ret = ();
358 0 0       0 if ($self->is_node($node)) {
359 0 0       0 if (defined($self->{_TRANSITIONS}{$node}{$self->get_epsilon_symbol()})) {
360 0         0 @ret = @{$self->{_TRANSITIONS}{$node}{$self->get_epsilon_symbol()}};
  0         0  
361             }
362             }
363 0         0 return @ret;
364             }
365              
366             sub delete_epsilon {
367 0     0 0 0 my $self = shift;
368 0         0 delete($self->{_EPSILON});
369 0         0 return;
370             }
371              
372             sub set_lambda {
373 339     339 0 263 my $self = shift;
374 339         241 my $lambda = shift;
375 339         311 $self->{_LAMBDA} = $lambda;
376 339         244 return;
377             }
378              
379             sub get_lambda_symbol {
380 33520     33520 0 22562 my $self = shift;
381 33520         71596 return $self->{_LAMBDA};
382             }
383              
384             sub get_lambda_transitions {
385 2161     2161 0 1619 my $self = shift;
386 2161         1511 my $node = shift;
387 2161         1619 my @ret = ();
388 2161 50       2271 if ($self->is_node($node)) {
389 2161 100       3187 if (defined($self->{_TRANSITIONS}{$node}{$self->get_lambda_symbol()})) {
390 969         1856 @ret = @{$self->{_TRANSITIONS}{$node}{$self->get_lambda_symbol()}};
  969         1239  
391             }
392             }
393 2161         3868 return @ret;
394             }
395              
396             sub delete_lambda {
397 0     0 0 0 my $self = shift;
398 0         0 delete($self->{_LAMBDA});
399 0         0 return;
400             }
401              
402             sub is_node {
403 17337     17337 0 13517 my $self = shift;
404 17337         17946 return $self->is_member(shift,$self->get_nodes());
405             }
406              
407             sub add_final {
408 1742     1742 0 1210 my $self = shift;
409 1742         1584 foreach my $node (@_) {
410 1742 50       1709 if (!$self->is_final($node)) {
411 1742         1329 push(@{$self->{_FINAL_NODES}},$node);
  1742         2146  
412             }
413             }
414 1742         1181 return;
415             }
416              
417             sub get_final {
418 2656     2656 0 1726 my $self = shift;
419 2656         1939 return @{$self->{_FINAL_NODES}}
  2656         4191  
420             }
421              
422             sub is_final {
423 1742     1742 0 1407 my $self = shift;
424 1742         1988 return $self->is_member(shift,$self->get_final());
425             }
426              
427             sub clone {
428 339     339 0 230 my $self = shift;
429 339         473 my $PFA = FLAT::Legacy::FA::PFA->new();
430 339         490 $PFA->add_node($self->get_nodes());
431 339         468 $PFA->add_final($self->get_final());
432 339         612 $PFA->add_symbol($self->get_symbols());
433 339         556 $PFA->set_start($self->get_start());
434 339         548 $PFA->set_epsilon($self->get_epsilon_symbol);
435 339         499 $PFA->set_lambda($self->get_lambda_symbol);
436 339         402 foreach my $node ($self->get_nodes()) {
437 830         524 foreach my $symbol (keys %{$self->{_TRANSITIONS}{$node}}) {
  830         1791  
438 491         376 $PFA->add_transition($node,$symbol,@{$self->{_TRANSITIONS}{$node}{$symbol}});
  491         742  
439             }
440             }
441 339         360 return $PFA;
442             }
443              
444             sub append_pfa {
445 339     339 0 300 my $self = shift;
446 339         234 my $PFA = shift;
447             # clone $PFA
448 339         455 my $PFA1 = $PFA->clone();
449             # pinch off self - ensures a single final node to append PFA1 to
450 339         496 $self->pinch();
451             # ensure unique node names
452 339         5247 $self->ensure_unique_nodes($PFA1,crypt(rand 8,join('',[rand 8, rand 8])));
453             # sychronize epsilon symbol
454 339 50       554 if ($PFA1->get_epsilon_symbol() ne $self->get_epsilon_symbol()) {
455 0         0 $PFA1->rename_symbol($PFA1->get_epsilon_symbol(),$self->get_epsilon_symbol());
456             }
457             # add new nodes from PFA1
458 339         465 foreach my $node ($PFA1->get_nodes()) {
459 830         853 $self->add_node($node);
460             };
461             # add new symbols from PFA1
462 339         704 foreach my $symbol ($PFA1->get_symbols()) {
463 396         602 $self->add_symbol($symbol);
464             }
465             # add epsilon transitions from PFA1
466 339         290 foreach my $node (keys %{$PFA1->{_TRANSITIONS}}) {
  339         710  
467 491         388 foreach my $symbol (keys %{$PFA1->{_TRANSITIONS}{$node}}) {
  491         803  
468 491         427 $self->add_transition($node,$symbol,@{$PFA1->{_TRANSITIONS}{$node}{$symbol}});
  491         745  
469             }
470             }
471             # remove current final node and saves it for future reference
472 339         256 my $oldfinal = pop(@{$self->{_FINAL_NODES}});
  339         410  
473             # add new epsilon transition from the old final node of $self to the start nodes of PFA1
474 339         504 $self->add_transition($oldfinal,$self->get_epsilon_symbol(),$PFA1->get_start());
475             # mark the final node of PFA1 as the final node of $self
476 339         473 $self->add_final($PFA1->get_final());
477             # nodes not renumbered - can done explicity by user
478 339         1683 return;
479             }
480              
481             sub prepend_pfa {
482 0     0 0 0 my $self = shift;
483 0         0 my $PFA = shift;
484             # clone $PFA
485 0         0 my $PFA1 = $PFA->clone();
486             # pinch off $PFA1 to ensure a single final node to join self to
487 0         0 $PFA1->pinch();
488             # ensure unique node names
489 0         0 $self->ensure_unique_nodes($PFA1,crypt(rand 8,join('',[rand 8, rand 8])));
490             # sychronize epsilon symbol
491 0 0       0 if ($PFA1->get_epsilon_symbol() ne $self->get_epsilon_symbol()) {
492 0         0 $PFA1->rename_symbol($PFA1->get_epsilon_symbol(),$self->get_epsilon_symbol());
493             }
494             # add new nodes from PFA1
495 0         0 foreach my $node ($PFA1->get_nodes()) {
496 0         0 $self->add_node($node);
497             };
498             # add new symbols from PFA1
499 0         0 foreach my $symbol ($PFA1->get_symbols()) {
500 0         0 $self->add_symbol($symbol);
501             }
502             # add transitions from PFA1
503 0         0 foreach my $node (keys %{$PFA1->{_TRANSITIONS}}) {
  0         0  
504 0         0 foreach my $symbol (keys %{$PFA1->{_TRANSITIONS}{$node}}) {
  0         0  
505 0         0 $self->add_transition($node,$symbol,@{$PFA1->{_TRANSITIONS}{$node}{$symbol}});
  0         0  
506             }
507             }
508             # remove current final node of $PFA1 and saves it for future reference
509 0         0 my $oldfinal = pop(@{$PFA1->{_FINAL_NODES}});
  0         0  
510             # add new epsilon transition from the old final node of $PFA1 to the start nodes of $self
511 0         0 $self->add_transition($oldfinal,$self->get_epsilon_symbol(),$self->get_start());
512             # mark the final node of PFA1 as the final node of $self
513 0         0 $self->set_start($PFA1->get_start());
514             # nodes not renumbered - can done explicity by user
515 0         0 return;
516             }
517              
518             sub or_pfa {
519 51     51 0 78 my $self = shift;
520 51         60 my $PFA1 = shift;
521             # (NOTE: epsilon pinch not used)
522 51         807 $self->ensure_unique_nodes($PFA1,crypt(rand 8,join('',[rand 8, rand 8])));
523             # sychronize epsilon symbol
524 51 50       112 if ($PFA1->get_epsilon_symbol() ne $self->get_epsilon_symbol()) {
525 0         0 $PFA1->rename_symbol($PFA1->get_epsilon_symbol(),$self->get_epsilon_symbol());
526             }
527             # add new nodes from PFA1
528 51         99 foreach my $node ($PFA1->get_nodes()) {
529 276         293 $self->add_node($node);
530             };
531             # add new symbols from PFA1
532 51         148 foreach my $symbol ($PFA1->get_symbols()) {
533 118         171 $self->add_symbol($symbol);
534             }
535             # add transitions from PFA1
536 51         57 foreach my $node (keys %{$PFA1->{_TRANSITIONS}}) {
  51         137  
537 225         165 foreach my $symbol (keys %{$PFA1->{_TRANSITIONS}{$node}}) {
  225         352  
538 225         169 $self->add_transition($node,$symbol,@{$PFA1->{_TRANSITIONS}{$node}{$symbol}});
  225         312  
539             }
540             }
541             # save old start nodes
542 51         109 my @start1 = $self->get_start();
543 51         78 my @start2 = $PFA1->get_start();
544             # create new start node
545 51         757 my $newstart = crypt(rand 8,join('',[rand 8, rand 8]));
546 51         114 $self->add_node($newstart);
547             # set this new node as the start
548 51         87 $self->set_start($newstart);
549             # add the final node from PFA1
550 51         90 $self->add_final($PFA1->get_final());
551             # create transitions to old start nodes from new start node
552 51         105 $self->add_transition($newstart,$self->get_epsilon_symbol(),@start1);
553 51         97 $self->add_transition($newstart,$self->get_epsilon_symbol(),@start2);
554             # pinch the final states into a single final state - required for PFA->to_nfa to work properly
555 51         95 $self->pinch();
556 51         106 return;
557             }
558              
559             sub interleave_pfa {
560 54     54 0 59 my $self = shift;
561 54         55 my $PFA1 = shift;
562             # (NOTE: epsilon pinch not used)
563             # ensure unique node names
564 54         813 $self->ensure_unique_nodes($PFA1,crypt(rand 8,join('',[rand 8, rand 8])));
565             # sychronize epsilon symbol
566 54 50       121 if ($PFA1->get_epsilon_symbol() ne $self->get_epsilon_symbol()) {
567 0         0 $PFA1->rename_symbol($PFA1->get_epsilon_symbol(),$self->get_epsilon_symbol());
568             }
569             # sychronize lambda symbol
570 54 50       115 if ($PFA1->get_lambda_symbol() ne $self->get_lambda_symbol()) {
571 0         0 $PFA1->rename_symbol($PFA1->get_lambda_symbol(),$self->get_lambda_symbol());
572             }
573             # add new nodes from PFA1
574 54         95 foreach my $node ($PFA1->get_nodes()) {
575 346         373 $self->add_node($node);
576             }
577             # add new symbols from PFA1
578 54         118 foreach my $symbol ($PFA1->get_symbols()) {
579 129         191 $self->add_symbol($symbol);
580             }
581             # add transitions from PFA1
582 54         72 foreach my $node (keys %{$PFA1->{_TRANSITIONS}}) {
  54         157  
583 292         190 foreach my $symbol (keys %{$PFA1->{_TRANSITIONS}{$node}}) {
  292         460  
584 292         226 $self->add_transition($node,$symbol,@{$PFA1->{_TRANSITIONS}{$node}{$symbol}});
  292         403  
585             }
586             }
587             # save old start nodes
588 54         108 my @start1 = $self->get_start();
589 54         101 my @start2 = $PFA1->get_start();
590             # create new start node
591 54         881 my $newstart = crypt(rand 8,join('',[rand 8, rand 8]));
592 54         108 $self->add_node($newstart);
593             # set this new node as the start
594 54         85 $self->set_start($newstart);
595             # create transitions to old start nodes from new start node
596 54         103 $self->add_transition($newstart,$self->get_lambda_symbol(),@start1);
597 54         95 $self->add_transition($newstart,$self->get_lambda_symbol(),@start2);
598             # create new final node
599             # save final nodes from self and PFA1
600 54         98 my @final_tmp = $self->get_final();
601 54         88 push (@final_tmp,$PFA1->get_final());
602             # reset final node array
603 54         760 my $newfinal = crypt(rand 8,join('',[rand 8, rand 8]));
604 54         98 $self->add_node($newfinal);
605 54         95 $self->{_FINAL_NODES} = [$newfinal];
606             # add a lambda transition from each of the old final nodes to the new final node
607 54         89 foreach my $final_tmp (@final_tmp) {
608 108         166 $self->add_transition($final_tmp,$self->get_lambda_symbol(),$newfinal);
609             }
610 54         154 return;
611             }
612              
613             sub kleene {
614 51     51 0 52 my $self = shift;
615 51         728 my $newstart = crypt(rand 8,join('',[rand 8, rand 8]));
616 51         503 my $newfinal = crypt(rand 8,join('',[rand 8, rand 8]));
617             # pinch off self - ensures a single final node
618 51         107 $self->pinch();
619 51         85 my @oldstart = $self->get_start();
620 51         57 my $oldfinal = pop(@{$self->{_FINAL_NODES}});
  51         66  
621             # add new nodes
622 51         79 $self->add_node($newstart,$newfinal);
623             # set start
624 51         64 $self->set_start($newstart);
625             # set final
626 51         94 $self->add_final($newfinal);
627             # $oldfinal->$oldstart
628 51         138 $self->add_transition($oldfinal,$self->get_epsilon_symbol(),@oldstart);
629             # $newstart->$oldstart
630 51         97 $self->add_transition($newstart,$self->get_epsilon_symbol(),@oldstart);
631             # $oldfinal->$newfinal
632 51         103 $self->add_transition($oldfinal,$self->get_epsilon_symbol(),$newfinal);
633             # $newstart->$newfinal
634 51         113 $self->add_transition($newstart,$self->get_epsilon_symbol(),$newfinal);
635 51         98 return;
636             }
637              
638             sub pinch {
639 441     441 0 453 my $self = shift;
640             # do only if there is more than one final node
641 441         353 my $newfinal = join(',',@{$self->{_FINAL_NODES}});
  441         782  
642 441         521 $self->add_node($newfinal);
643 441         342 while (@{$self->{_FINAL_NODES}}) {
  933         1324  
644             # design decision - remove all final nodes so that the common
645             # one is the only final node and all former final nodes have an
646             # epsilon transition to it - could prove costly for NFA->to_dfa, so
647             # this could change
648 492         394 my $node = pop(@{$self->{_FINAL_NODES}});
  492         492  
649             # add new transition unless it is to the final node itself
650 492 100       818 if ($node ne $newfinal) {
651 102         128 $self->add_transition($node,$self->get_epsilon_symbol(),$newfinal)
652             }
653             }
654 441         564 $self->add_final($newfinal);
655             # FA->number_nodes() could be used here, but the user may not
656             # want the nodes renamed, so it can be used explicitly
657 441         307 return;
658             }
659              
660             sub rename_node {
661 0     0 0 0 my $self = shift;
662 0         0 my $oldname = shift;
663 0         0 my $newname = shift;
664             # make sure $oldname is an actual node in this FA
665 0 0       0 if (!$self->is_node($newname)) {
666 0 0       0 if ($self->is_node($oldname)) {
667             # replace name in _NODES array
668 0         0 my $i = 0;
669 0         0 foreach ($self->get_nodes()) {
670 0 0       0 if ($_ eq $oldname) {
671 0         0 $self->{_NODES}[$i] = $newname;
672 0         0 last;
673             }
674 0         0 $i++;
675             }
676             # replace name if start node
677 0 0       0 if ($self->is_start($oldname)) {
678 0         0 my $i = 0;
679 0         0 foreach my $n ($self->get_start()) {
680 0 0       0 if ($n eq $oldname) {
681 0         0 $self->{_START_NODES}[$i] = $newname;
682             }
683 0         0 $i++;
684             }
685             }
686             # replace transitions
687 0         0 foreach my $node (keys %{$self->{_TRANSITIONS}}) {
  0         0  
688 0         0 foreach my $symbol (keys %{$self->{_TRANSITIONS}{$node}}) {
  0         0  
689 0         0 my $j = 0;
690 0         0 foreach my $next (@{$self->{_TRANSITIONS}{$node}{$symbol}}) {
  0         0  
691             # rename destination nodes
692 0 0       0 if ($self->{_TRANSITIONS}{$node}{$symbol}[$j] eq $oldname) {
693 0         0 $self->{_TRANSITIONS}{$node}{$symbol}[$j] = $newname;
694             }
695 0         0 $j++;
696             }
697             # rename start node
698 0 0       0 if ($node eq $oldname) {
699 0         0 $self->add_transition($newname,$symbol,@{$self->{_TRANSITIONS}{$node}{$symbol}});
  0         0  
700             }
701             }
702 0 0       0 if ($node eq $oldname) {
703             # delete all transitions of old node
704 0         0 delete($self->{_TRANSITIONS}{$node});
705             }
706             }
707             # replace final nodes
708 0         0 $i = 0;
709 0         0 foreach ($self->get_final()) {
710 0 0       0 if ($_ eq $oldname) {
711 0         0 $self->{_FINAL_NODES}[$i] = $newname;
712             }
713 0         0 $i++;
714             }
715             # replace tied nodes
716 0         0 $i = 0;
717 0         0 foreach ($self->get_tied()) {
718 0         0 my $tied = $_;
719 0         0 my $j = 0;
720 0         0 foreach my $node (@{$tied}) {
  0         0  
721 0 0       0 if ($node eq $oldname) {
722 0         0 $self->{_TIED}[$i]->[$j] = $newname;
723             }
724 0         0 $j++;
725             }
726 0         0 $i++;
727             }
728             } else {
729 0         0 print STDERR "Warning: $oldname is not a current node\n";
730             }
731             } else {
732 0         0 print STDERR "Warning: $newname is a current node\n";
733             }
734 0         0 return;
735             }
736              
737             sub ensure_unique_nodes {
738 444     444 0 447 my $self = shift;
739 444         326 my $PFA1 = shift;
740 444         308 my $disambigator = shift;
741 444         491 chomp($disambigator);
742 444         539 foreach ($self->get_nodes()) {
743 2448         1794 my $node1 = $_;
744 2448   33     2657 while ($PFA1->is_node($node1) && !$self->is_node($disambigator)) {
745 0         0 $self->rename_node($node1,$disambigator);
746             # re-assign $node1 with new name
747 0         0 $node1 = $disambigator;
748             # get new disambiguator just incase this is not unique
749 0         0 $disambigator = crypt(rand 8,join('',[rand 8, rand 8]));
750             }
751             }
752 444         469 return;
753             }
754              
755             sub number_nodes {
756 0     0 0   my $self = shift;
757 0           my $number = 0;
758             # generate 5 character string of random numbers
759 0           my $prefix = crypt(rand 8,join('',[rand 8, rand 8]));
760             # add random prefix to node names
761 0           foreach ($self->get_nodes()) {
762 0           $self->rename_node($_,$prefix."_$number");
763 0           $number++;
764             }
765             # rename nodes as actual numbers
766 0           $number = 0;
767 0           foreach ($self->get_nodes()) {
768 0           $self->rename_node($_,$number);
769 0           $number++;
770             }
771 0           return;
772             }
773              
774             sub append_node_names {
775 0     0 0   my $self = shift;
776 0           my $suffix = shift;
777 0 0         if (defined($suffix)) {
778 0           chomp($suffix);
779             } else {
780 0           $suffix = '';
781             }
782 0           foreach ($self->get_nodes()) {
783 0           $self->rename_node($_,"$_".$suffix);
784             }
785 0           return;
786             }
787              
788             sub prepend_node_names {
789 0     0 0   my $self = shift;
790 0           my $prefix = shift;
791 0 0         if (defined($prefix)) {
792 0           chomp($prefix);
793             } else {
794 0           $prefix = '';
795             }
796 0           foreach ($self->get_nodes()) {
797 0           $self->rename_node($_,$prefix."$_");
798             }
799 0           return;
800             }
801              
802             # renames symbol
803             sub rename_symbol {
804 0     0 0   my $self = shift;
805 0           my $oldsymbol = shift;
806 0           my $newsymbol = shift;
807             # make sure $oldsymbol is a symbol and do not bother if
808             # $newsymbol ne $oldsymbol
809 0 0 0       if ($self->is_symbol($oldsymbol) && $newsymbol ne $oldsymbol) {
810             # change in $self->{_SYMBOLS}
811 0           my $i = 0;
812 0           foreach ($self->get_symbols()) {
813 0 0         if ($_ eq $oldsymbol) {
814 0           $self->{_SYMBOLS}[$i] = $newsymbol;
815 0           last;
816             }
817 0           $i++;
818             }
819             # change in $self->{_TRANSITIONS}
820             # replace transition symbols
821 0           foreach my $node (keys %{$self->{_TRANSITIONS}}) {
  0            
822 0           foreach my $symbol (keys %{$self->{_TRANSITIONS}{$node}}) {
  0            
823 0 0         if ($symbol eq $oldsymbol) {
824 0           $self->add_transition($node,$newsymbol,@{$self->{_TRANSITIONS}{$node}{$symbol}});
  0            
825 0           delete($self->{_TRANSITIONS}{$node}{$symbol});
826             }
827             }
828             }
829             # also look at $self->{_EPSILON}
830 0 0         if ($self->get_epsilon_symbol() eq $oldsymbol) {
831 0           $self->set_epsilon($newsymbol);
832             }
833             }
834 0           return;
835             }
836              
837             sub info {
838 0     0 0   my $self = shift;
839 0           my $out = '';
840 0           $out .= sprintf ("Nodes : ");
841 0           foreach ($self->get_nodes()) {
842 0           $out .= sprintf "'$_' ";
843             }
844 0           $out .= sprintf ("\nStart State : '%s'\n",join(',',$self->get_start()));
845 0           $out .= sprintf ("Final State : '%s'\n",join(',',$self->get_final()));
846 0           $out .= sprintf ("Alphabet : ");
847 0           foreach ($self->get_symbols()) {
848 0           $out .= sprintf "'$_' ";
849             }
850 0 0         if (defined($self->get_epsilon_symbol())) {
851 0           $out .= sprintf("\nEPSILON Symbol : '%s'",$self->get_epsilon_symbol());
852             }
853 0 0         if (defined($self->get_lambda_symbol())) {
854 0           $out .= sprintf("\nLAMBDA Symbol : '%s'",$self->get_lambda_symbol());
855             }
856 0           $out .= sprintf ("\nTied Nodes : ");
857 0           foreach my $t ($self->get_tied()) {
858 0           $out .= sprintf(join(',',@{$t}));
  0            
859 0           $out .= '; ';
860             }
861 0           $out .= sprintf ("\nTransitions :\n");
862 0           foreach my $node ($self->get_nodes()) {
863 0           foreach my $symbol (keys %{$self->{_TRANSITIONS}{$node}}) {
  0            
864 0 0 0       if ($symbol ne $self->get_epsilon_symbol() && $symbol ne $self->get_lambda_symbol()) {
    0          
865 0           $out .= sprintf("\t('%s'),'%s' --> '%s'\n",$node,$symbol,join('\',\'',$self->get_transition_on($node,$symbol)));
866             } elsif ($symbol ne $self->get_lambda_symbol()) {
867 0           $out .= sprintf("\t('%s'),'%s' --> '%s'\n",$node,$symbol,join('\',\'',$self->get_epsilon_transitions($node)));
868             } else {
869 0           $out .= sprintf("\t('%s'),'%s' --> '%s'\n",$node,$symbol,join('\',\'',$self->get_lambda_transitions($node)));
870             }
871             }
872             }
873 0           return $out;
874             }
875              
876             sub serialize {
877 0     0 0   my $self = shift;
878 0           my $out = '';
879 0           $out .= sprintf("START :: %s\n",$self->get_start());
880 0           $out .= sprintf("FINAL :: %s\n",join(',',$self->get_final()));
881 0 0         if (defined($self->get_epsilon_symbol())) {
882 0           $out .= sprintf("EPSILON :: %s\n",$self->get_epsilon_symbol());
883             }
884 0 0         if (defined($self->get_lambda_symbol())) {
885 0           $out .= sprintf("LAMBDA :: %s\n",$self->get_lambda_symbol());
886             }
887 0           $out .= "\n";
888 0           foreach my $node ($self->get_nodes()) {
889 0           $out .= sprintf("%s:\n",$node);
890 0           foreach my $symbol (keys %{$self->{_TRANSITIONS}{$node}}) {
  0            
891 0 0 0       if ($symbol ne $self->get_epsilon_symbol() && $symbol ne $self->get_lambda_symbol()) {
    0          
892 0           $out .= sprintf("$symbol %s\n",join(',',$self->get_transition_on($node,$symbol)));
893             } elsif ($symbol ne $self->get_lambda_symbol()) {
894 0           $out .= sprintf("$symbol %s\n",join(',',$self->get_epsilon_transitions($node)));
895             } else {
896 0           $out .= sprintf("$symbol %s\n",join(',',$self->get_lambda_transitions($node)));
897             }
898             }
899 0           $out .= sprintf("\n");
900             }
901 0           return $out;
902             }
903              
904             1;
905              
906             __END__