path: root/lib/FLAT/DFA.pm

package FLAT::DFA;

use strict;
use base 'FLAT::NFA';
use Storable qw(dclone);
use Carp;
$|++;

sub set_starting {
    my $self = shift;
    $self->SUPER::set_starting(@_);
    
    my $num = () = $self->get_starting;
    confess "DFA must have exactly one starting state"
        if $num != 1;
}

sub complement {
    my $self = $_[0]->clone;
    
    for my $s ($self->get_states) {
        $self->is_accepting($s)
            ? $self->unset_accepting($s)
            : $self->set_accepting($s);
    }
    
    return $self;
}

sub _TUPLE_ID { join "\0", @_ }
sub _uniq { my %seen; grep { !$seen{$_}++ } @_; }

## this method still needs more work..
sub intersect {
    my @dfas = map { $_->as_dfa } @_;
    
    my $return = FLAT::DFA->new;
    my %newstates;
    my @alpha = _uniq( map { $_->alphabet } @dfas );
    
    $_->_extend_alphabet(@alpha) for @dfas;

    my @start = map { $_->get_starting } @dfas;
    my $start = $newstates{ _TUPLE_ID(@start) } = $return->add_states(1);
    $return->set_starting($start);
    $return->set_accepting($start)
        if ! grep { ! $dfas[$_]->is_accepting( $start[$_] ) } 0 .. $#dfas;

    my @queue = (\@start);
    while (@queue) {
        my @tuple = @{ shift @queue };

        for my $char (@alpha) {
            my @next = map { $dfas[$_]->successors( $tuple[$_], $char ) }
                        0 .. $#dfas;
            
            #warn "[@tuple] --> [@next] via $char\n";
            
            if (not exists $newstates{ _TUPLE_ID(@next) }) {
                my $s = $newstates{ _TUPLE_ID(@next) } = $return->add_states(1);
                $return->set_accepting($s)
                    if ! grep { ! $dfas[$_]->is_accepting( $next[$_] ) } 0 .. $#dfas;
                push @queue, \@next;
            }
            
            $return->add_transition( $newstates{ _TUPLE_ID(@tuple) },
                                     $newstates{ _TUPLE_ID(@next) },
                                     $char );
        }            
    }

    return $return;    
}

# this is meant to enforce 1 starting state for a DFA, but it is getting us into trouble
# when a DFA object calls unset_starting
sub unset_starting {
    my $self = shift;    
    $self->SUPER::unset_starting(@_);    
    my $num = () = $self->unset_starting;
    croak "DFA must have exactly one starting state"
        if $num != 1;
}

#### transformations

sub trim_sinks {
  my $self = shift;
  my $result = $self->clone();
  foreach my $state ($self->array_complement([$self->get_states()],[$self->get_accepting()])) {
    my @ret = $self->successors($state,[$self->alphabet]);
    if (@ret) {
      if ($ret[0] == $state) {
        $result->delete_states($state) if ($result->is_state($state));    
      }
    }
  }
  return $result;
}

sub as_min_dfa {

    my $self     = shift()->clone;
    my $N        = $self->num_states;
    my @alphabet = $self->alphabet;

    my ($start)  = $self->get_starting;
    my %final    = map { $_ => 1 } $self->get_accepting;

    my @equiv = map [ (0) x ($_+1), (1) x ($N-$_-1) ], 0 .. $N-1;

    while (1) {
        my $changed = 0;
        for my $s1 (0 .. $N-1) {
        for my $s2 (grep { $equiv[$s1][$_] } 0 .. $N-1) {
            
            if ( 1 == grep defined, @final{$s1, $s2} ) {
                $changed = 1;
                $equiv[$s1][$s2] = 0;
                next;
            }
            
            for my $char (@alphabet) {
                my @t = sort { $a <=> $b } $self->successors([$s1,$s2], $char);
                next if @t == 1;
                
                if (not $equiv[ $t[0] ][ $t[1] ]) {
                    $changed = 1;
                    $equiv[$s1][$s2] = 0;
                }
            }
        }}
        
        last if !$changed;
    }
    my $result = (ref $self)->new;
    my %newstate;
    my @classes;
    for my $s (0 .. $N-1) {
        next if exists $newstate{$s};
        
        my @c = ( $s, grep { $equiv[$s][$_] } 0 .. $N-1 );
        push @classes, \@c;

        @newstate{@c} = ( $result->add_states(1) ) x @c;
    }

    for my $c (@classes) {
        my $s = $c->[0];
        for my $char (@alphabet) {
            my ($next) = $self->successors($s, $char);
            $result->add_transition( $newstate{$s}, $newstate{$next}, $char );
        }
    }
    
    $result->set_starting( $newstate{$start} );
    $result->set_accepting( $newstate{$_} )
        for $self->get_accepting;
    
    $result;

}

# the validity of a given string <-- executes symbols over DFA
# if there is not transition for given state and symbol, it fails immediately
# if the current state we're in is not final when symbols are exhausted, then it fails

sub is_valid_string {
  my $self = shift;
  my $string = shift;
  chomp $string;
  my $OK = undef;
  my @stack = split('',$string);
  # this is confusing all funcs return arrays
  my @current = $self->get_starting();
  my $current = pop @current;
  foreach (@stack) {
    my @next = $self->successors($current,$_);    
    if (!@next) {
      return $OK; #<--returns undef bc no transition found
    }
    $current = $next[0];
  }
  $OK++ if ($self->is_accepting($current));
  return $OK;
}

#
# Experimental!!
#

# DFT stuff in preparation for DFA pump stuff;
sub as_node_list {
    my $self = shift;
    my %node = ();
    for my $s1 ($self->get_states) {
      $node{$s1} = {}; # initialize
      for my $s2 ($self->get_states) {
         my $t = $self->get_transition($s1, $s2);
         if (defined $t) {
           # array of symbols that $s1 will go to $s2 on...
	   push(@{$node{$s1}{$s2}},split(',',$t->as_string)); 
         }
      }
    }
  return %node;
}

sub as_acyclic_strings {
    my $self = shift;
    my %dflabel       = (); # lookup table for dflable
    my %backtracked   = (); # lookup table for backtracked edges
    my $lastDFLabel   = 0;
    my @string        = ();
    my %nodes         = $self->as_node_list();
    # output format is the actual PRE followed by all found strings
    $self->acyclic($self->get_starting(),\%dflabel,$lastDFLabel,\%nodes,\@string);
}

sub acyclic {
  my $self = shift;
  my $startNode = shift;
  my $dflabel_ref = shift;
  my $lastDFLabel = shift;
  my $nodes = shift;
  my $string = shift;
  # tree edge detection
  if (!exists($dflabel_ref->{$startNode})) {
    $dflabel_ref->{$startNode} = ++$lastDFLabel;  # the order inwhich this link was explored
    foreach my $adjacent (keys(%{$nodes->{$startNode}})) {
      if (!exists($dflabel_ref->{$adjacent})) {      # initial tree edge
        foreach my $symbol (@{$nodes->{$startNode}{$adjacent}}) {
	  push(@{$string},$symbol);
          $self->acyclic($adjacent,\%{$dflabel_ref},$lastDFLabel,\%{$nodes},\@{$string});
	  if ($self->array_is_subset([$adjacent],[$self->get_accepting()])) { #< proof of concept
            printf("%s\n",join('',@{$string}));
	  }
	  pop(@{$string});
        }
      }
    } 
  }
  # remove startNode entry to facilitate acyclic path determination
  delete($dflabel_ref->{$startNode});
  #$lastDFLabel--;
  return;     
};

sub as_dft_strings {
  my $self = shift;
  my $depth = 1;
  $depth = shift if (1 < $_[0]);
  my %dflabel        = (); # scoped lookup table for dflable
  my %nodes          = $self->as_node_list();
  foreach (keys(%nodes)) {
    $dflabel{$_} = []; # initialize container (array) for multiple dflables for each node
  }
  my $lastDFLabel    =  0;
  my @string         = ();
  $self->dft($self->get_starting(),[$self->get_accepting()],\%dflabel,$lastDFLabel,\%nodes,\@string,$depth); 
}

sub dft {
  my $self = shift;
  my $startNode    = shift;
  my $goals_ref    = shift;
  my $dflabel_ref  = shift;
  my $lastDFLabel  = shift;
  my $nodes        = shift;
  my $string       = shift;
  my $DEPTH        = shift;
  # add start node to path
  my $c1 = @{$dflabel_ref->{$startNode}}; # get number of elements
  if ($DEPTH >= $c1) {  
    push(@{$dflabel_ref->{$startNode}},++$lastDFLabel);
    foreach my $adjacent (keys(%{$nodes->{$startNode}})) {
      my $c2 = @{$dflabel_ref->{$adjacent}};
      if ($DEPTH > $c2) {   # "initial" tree edge
        foreach my $symbol (@{$nodes->{$startNode}{$adjacent}}) {
	  push(@{$string},$symbol);
	  $self->dft($adjacent,[@{$goals_ref}],$dflabel_ref,$lastDFLabel,$nodes,[@{$string}],$DEPTH);
	  # assumes some base path found
          if ($self->array_is_subset([$adjacent],[@{$goals_ref}])) { 
            printf("%s\n",join('',@{$string}));    
  	  } 
          pop(@{$string}); 
        } 
      }
    } # remove startNode entry to facilitate acyclic path determination
    pop(@{$dflabel_ref->{$startNode}});
    $lastDFLabel--;
  }    
};

#
# String gen using iterators (still experimental)
#

sub get_acyclic_sub {
  my $self = shift;
  my ($start,$nodelist_ref,$dflabel_ref,$string_ref,$accepting_ref,$lastDFLabel) = @_;
  my @ret = ();
  foreach my $adjacent (keys(%{$nodelist_ref->{$start}})) {
    $lastDFLabel++;
    if (!exists($dflabel_ref->{$adjacent})) {
      $dflabel_ref->{$adjacent} = $lastDFLabel;
      foreach my $symbol (@{$nodelist_ref->{$start}{$adjacent}}) { 
        push(@{$string_ref},$symbol);
      	my $string_clone = dclone($string_ref);
        my $dflabel_clone = dclone($dflabel_ref);
        push(@ret,sub { return $self->get_acyclic_sub($adjacent,$nodelist_ref,$dflabel_clone,$string_clone,$accepting_ref,$lastDFLabel); }); 
        pop @{$string_ref};
      }
    } 
 
  }
  return {substack=>[@ret],
          lastDFLabel=>$lastDFLabel,
          string => ($self->array_is_subset([$start],[@{$accepting_ref}]) ? join('',@{$string_ref}) : undef)};
}
sub init_acyclic_iterator {
  my $self = shift;
  my %dflabel = (); 
  my @string  = (); 
  my $lastDFLabel = 0; 
  my %nodelist = $self->as_node_list(); 
  my @accepting = $self->get_accepting();
  # initialize
  my @substack = ();
  my $r = $self->get_acyclic_sub($self->get_starting(),\%nodelist,\%dflabel,\@string,\@accepting,$lastDFLabel);
  push(@substack,@{$r->{substack}});
  return sub {
    while (1) {
      if (!@substack) {
        return undef;
      }
      my $s = pop @substack;
      my $r = $s->();
      push(@substack,@{$r->{substack}}); 
      if ($r->{string}) {
       return $r->{string};
      }
    }
  }
}

sub new_acyclic_string_generator {
  my $self = shift;
  return $self->init_acyclic_iterator();
}

sub get_deepdft_sub {
  my $self = shift;
  my ($start,$nodelist_ref,$dflabel_ref,$string_ref,$accepting_ref,$lastDFLabel,$max) = @_;
  my @ret = ();
  my $c1 = @{$dflabel_ref->{$start}};
  if ($c1 < $max) {
    push(@{$dflabel_ref->{$start}},++$lastDFLabel);
    foreach my $adjacent (keys(%{$nodelist_ref->{$start}})) {
      my $c2 = @{$dflabel_ref->{$adjacent}};
      if ($c2 < $max) {
        foreach my $symbol (@{$nodelist_ref->{$start}{$adjacent}}) { 
          push(@{$string_ref},$symbol);
          my $string_clone = dclone($string_ref);
          my $dflabel_clone = dclone($dflabel_ref);
          push(@ret,sub { return $self->get_deepdft_sub($adjacent,$nodelist_ref,$dflabel_clone,$string_clone,$accepting_ref,$lastDFLabel,$max); }); 
          pop @{$string_ref};
        }
      }
    }
  }
  return {substack=>[@ret], lastDFLabel=>$lastDFLabel, string => ($self->array_is_subset([$start],[@{$accepting_ref}]) ? join('',@{$string_ref}) : undef)};
}
 
sub init_deepdft_iterator {
  my $self = shift;
  my $MAXLEVEL = shift;
  my %dflabel = (); 
  my @string  = (); 
  my $lastDFLabel = 0; 
  my %nodelist = $self->as_node_list(); 
  foreach my $node (keys(%nodelist)) {
    $dflabel{$node} = []; # initializes anonymous arrays for all nodes
  }
  my @accepting = $self->get_accepting();
  # initialize
  my @substack = ();
  my $r = $self->get_deepdft_sub($self->get_starting(),\%nodelist,\%dflabel,\@string,\@accepting,$lastDFLabel,$MAXLEVEL);
  push(@substack,@{$r->{substack}});
  return sub {
    while (1) {
      if (!@substack) {
        return undef;
      }
      my $s = pop @substack;
      my $r = $s->();
      push(@substack,@{$r->{substack}}); 
      if ($r->{string}) {
       return $r->{string};
      }
    }
  }
}

sub new_deepdft_string_generator {
  my $self = shift;
  my $MAXLEVEL = (@_ ? shift : 1);
  return $self->init_deepdft_iterator($MAXLEVEL);
}

1;

__END__

=head1 NAME

FLAT::DFA - Deterministic finite automata

=head1 SYNOPSIS

A FLAT::DFA object is a finite automata whose transitions are labeled
with single characters. Furthermore, each state has exactly one outgoing
transition for each available label/character. 

=head1 USAGE

In addition to implementing the interface specified in L<FLAT> and L<FLAT::NFA>, 
FLAT::DFA objects provide the following DFA-specific methods:

=over

=item $dfa-E<gt>unset_starting

Because a DFA, by definition, must have only ONE starting state, this allows one to unset
the current start state so that a new one may be set.

=item $dfa-E<gt>trim_sinks

This method returns a FLAT::DFA (though in theory an NFA) that is lacking a transition for 
all symbols from all states.  This method eliminates all transitions from all states that lead
to a sink state; it also eliminates the sink state.

This has no affect on testing if a string is valid using C<FLAT::DFA::is_valid_string>, 
discussed below.

=item $dfa-E<gt>as_min_dfa

This method minimizes the number of states and transitions in the given DFA. The modifies
the current/calling DFA object.

=item $dfa-E<gt>is_valid_string($string)

This method tests if the given string is accepted by the DFA.

=item $dfa-E<gt>as_node_list

This method returns a node list in the form of a hash. This node list may be viewed as a 
pure digraph, and is lacking in state names and transition symbols.

=item $dfa-E<gt>as_acyclic_strings

The method is B<deprecated>, and it is suggested that one not use it.  It returns all 
valid strings accepted by the DFA by exploring all acyclic paths that go from the start
state and end in an accepting state.  The issue with this method is that it finds and
returns all strings at once.  The iterator described below is much more ideal for actual
use in an application.

=item $dfa-E<gt>as_dft_strings($depth)

The method is B<deprecated>, and it is suggested that one not use it.  It returns all 
valid strings accepted by the DFA using a depth first traversal.  A valid string is formed
when the traversal detects an accepting state, whether it is a terminal node or a node reached
via a back edge.  The issue with this method is that it finds and returns all strings at once.  
The iterator described below is much more ideal for actual use in an application.

The argument, C<$depth> specifies how many times the traversal may actually pass through
a previously visited node.  It is therefore possible to safely explore DFAs that accept
infinite languages.

=item $dfa-E<gt>new_acyclic_string_generator

This allows one to initialize an iterator that returns a valid string on each successive
call of the sub-ref that is returned. It returns all valid strings accepted by the DFA by 
exploring all acyclic paths that go from the start state and end in an accepting state.

Example:

 #!/usr/bin/env perl
 use strict; 
 use FLAT::DFA;
 use FLAT::NFA;
 use FLAT::PFA;
 use FLAT::Regex::WithExtraOps; 

 my $PRE = "abc&(def)*";
 my $dfa = FLAT::Regex::WithExtraOps->new($PRE)->as_pfa->as_nfa->as_dfa->as_min_dfa->trim_sinks; 
 my $next = $dfa->new_acyclic_string_generator; 
 print "PRE: $PRE\n";
 print "Acyclic:\n";
 while (my $string = $next->()) {
   print "  $string\n";
 }

=item $dfa-E<gt>new_deepdft_string_generator($depth)

This allows one to initialize an iterator that returns a valid string on each successive
call of the sub-ref that is returned. It returns all valid strings accepted by the DFA using a 
depth first traversal.  A valid string is formed when the traversal detects an accepting state, 
whether it is a terminal node or a node reached via a back edge.

The argument, C<$depth> specifies how many times the traversal may actually pass through
a previously visited node.  It is therefore possible to safely explore DFAs that accept
infinite languages.

 #!/usr/bin/env perl
 use strict; 
 use FLAT::DFA;
 use FLAT::NFA;
 use FLAT::PFA;
 use FLAT::Regex::WithExtraOps; 

 my $PRE = "abc&(def)*";
 my $dfa = FLAT::Regex::WithExtraOps->new($PRE)->as_pfa->as_nfa->as_dfa->as_min_dfa->trim_sinks; 
 my $next = $dfa->new_deepdft_string_generator();
 print "Deep DFT (default):\n";
 for (1..10) {
  while (my $string = $next->()) {
    print "  $string\n";
    last;
   }
 }

 $next = $dfa->new_deepdft_string_generator(5);
 print "Deep DFT (5):\n";
 for (1..10) {
   while (my $string = $next->()) {
     print "  $string\n";
     last;
   }
 }

=back

=head1 AUTHORS & ACKNOWLEDGEMENTS

FLAT is written by Mike Rosulek E<lt>mike at mikero dot comE<gt> and 
Brett Estrade E<lt>estradb at gmail dot comE<gt>.

The initial version (FLAT::Legacy) by Brett Estrade was work towards an 
MS thesis at the University of Southern Mississippi.

Please visit the Wiki at http://www.0x743.com/flat

=head1 LICENSE

This module is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.