File Coverage

blib/lib/FLAT/FA.pm

Criterion	Covered	Total	%
statement	191	233	81.9
branch	36	46	78.2
condition			n/a
subroutine	36	41	87.8
pod	22	29	75.8
total	285	349	81.6

package FLAT::FA;

use strict;
use warnings;
use parent qw(FLAT);
use Carp;

use FLAT::Transition::Simple;

=head1 NAME

FLAT::FA - Base class for regular finite automata

=head1 SYNOPSIS

A FLAT::FA object is a collection of states and transitions. Each state
may be labeled as starting or accepting. Each transition between states
is labeled with a transition object.

=head1 USAGE

FLAT::FA is a superclass that is not intended to be used directly. However,
it does provide the following methods:

=cut

sub new {
    my $pkg = shift;
    bless {
        STATES        => [],
        TRANS         => [],
        ALPHA         => {},
        ALPHA_BLESSED => {},
    }, $pkg;
}

sub get_states {
    my $self = shift;
    return 0 .. ( $self->num_states - 1 );
}

sub num_states {
    my $self = shift;
    return scalar @{ $self->{STATES} };
}

sub is_state {
    my ( $self, $state ) = @_;
    exists $self->{STATES}->[$state];
}

sub _assert_states {
    my ( $self, @states ) = @_;
    for (@states) {
        croak "'$_' is not a state" if not $self->is_state($_);
    }
}

sub _assert_non_states {
    my ( $self, @states ) = @_;
    for (@states) {
        croak "There is already a state called '$_'" if $self->is_state($_);
    }
}

sub delete_states {
    my ( $self, @states ) = @_;

    $self->_assert_states(@states);

    for my $s ( sort { $b <=> $a } @states ) {
        $self->_decr_alphabet($_) for @{ splice @{ $self->{TRANS} }, $s, 1 };

        $self->_decr_alphabet( splice @$_, $s, 1 ) for @{ $self->{TRANS} };

        splice @{ $self->{STATES} }, $s, 1;
    }
}

sub add_states {
    my ( $self, $num ) = @_;
    my $id = $self->num_states;

    for my $s ( $id .. ( $id + $num - 1 ) ) {
        push @$_, undef for @{ $self->{TRANS} };
        push @{ $self->{TRANS} }, [ (undef) x ( $s + 1 ) ];
        push @{ $self->{STATES} },
          {
            starting  => 0,
            accepting => 0
          };
    }

    return wantarray
      ? ( $id .. ( $id + $num - 1 ) )
      : $id + $num - 1;
}

##############

sub is_starting {
    my ( $self, $state ) = @_;
    $self->_assert_states($state);
    return $self->{STATES}[$state]{starting};
}

sub set_starting {
    my ( $self, @states ) = @_;
    $self->_assert_states(@states);
    $self->{STATES}[$_]{starting} = 1 for @states;
}

sub unset_starting {
    my ( $self, @states ) = @_;
    $self->_assert_states(@states);
    $self->{STATES}[$_]{starting} = 0 for @states;
}

sub get_starting {
    my $self = shift;
    return grep { $self->is_starting($_) } $self->get_states;
}

##############

sub is_accepting {
    my ( $self, $state ) = @_;
    $self->_assert_states($state);
    return $self->{STATES}[$state]{accepting};
}

sub set_accepting {
    my ( $self, @states ) = @_;
    $self->_assert_states(@states);
    $self->{STATES}[$_]{accepting} = 1 for @states;
}

sub unset_accepting {
    my ( $self, @states ) = @_;
    $self->_assert_states(@states);
    $self->{STATES}[$_]{accepting} = 0 for @states;
}

sub get_accepting {
    my $self = shift;
    return grep { $self->is_accepting($_) } $self->get_states;
}

###############

sub _decr_alphabet {
    my ( $self, $t ) = @_;

    return if not defined $t;
    for ( $t->alphabet ) {
        delete $self->{ALPHA}{$_} if not --$self->{ALPHA}{$_};

        # supposed to delete key when _decrement_count returns 0, so need to test this
        delete $self->{ALPHA_BLESSED}{$_} if not $self->{ALPHA_BLESSED}{$_}->_decrement_count;
    }
}

sub _incr_alphabet {
    my ( $self, $t ) = @_;

    return if not defined $t;
    for ( $t->alphabet ) {
        $self->{ALPHA}{$_}++;

        if ( !exists( $self->{ALPHA_BLESSED}{$_} ) ) {
            $self->{ALPHA_BLESSED}{$_} = $self->{ALPHA_CLASS}->new($_);
        }
        else {
            $self->{ALPHA_BLESSED}{$_}->_increment_count;
        }
    }
}

sub set_transition {
    my ( $self, $state1, $state2, @label ) = @_;
    $self->remove_transition( $state1, $state2 );

    @label = grep defined, @label;
    return if not @label;

    my $t = $self->{TRANS_CLASS}->new(@label);
    $self->{TRANS}[$state1][$state2] = $t;
    $self->_incr_alphabet($t);
}

sub add_transition {
    my ( $self, $state1, $state2, @label ) = @_;

    @label = grep defined, @label;
    return if not @label;

    my $t = $self->get_transition( $state1, $state2 );
    $self->_decr_alphabet($t);

    if ( !$t ) {
        $t = $self->{TRANS}[$state1][$state2] = $self->{TRANS_CLASS}->new;
    }

    $t->add(@label);
    $self->_incr_alphabet($t);
}

sub get_transition {
    my ( $self, $state1, $state2 ) = @_;
    $self->_assert_states( $state1, $state2 );

    $self->{TRANS}[$state1][$state2];
}

sub remove_transition {
    my ( $self, $state1, $state2 ) = @_;

    $self->_decr_alphabet( $self->{TRANS}[$state1][$state2] );
    $self->{TRANS}[$state1][$state2] = undef;
}

# given a state and a symbol, it tells you
# what the next state(s) are; do get successors
# for find the successors for a set of symbols,
# use array refs.  For example:
# @NEXT=$self->successors([@nodes],[@symbols]);
sub successors {
    my ( $self, $state, $symb ) = @_;

    my @states = ref $state eq 'ARRAY' ? @$state : ($state);
    my @symbs =
      defined $symb
      ? ( ref $symb eq 'ARRAY' ? @$symb : ($symb) )
      : ();

    $self->_assert_states(@states);

    my %succ;
    for my $s (@states) {
        $succ{$_}++ for grep {
            my $t = $self->{TRANS}[$s][$_];
            defined $t && ( @symbs ? $t->does(@symbs) : 1 )
        } $self->get_states;
    }

    return keys %succ;
}

sub predecessors {
    my $self = shift;
    $self->clone->reverse->successors(@_);
}

# reverse  - no change from NFA
sub reverse {
    my $self = $_[0]->clone;
    $self->_transpose;

    my @start = $self->get_starting;
    my @final = $self->get_accepting;

    $self->unset_accepting( $self->get_states );
    $self->unset_starting( $self->get_states );

    $self->set_accepting(@start);
    $self->set_starting(@final);

    $self;
}

# get an array of all symbols
sub alphabet {
    my $self = shift;
    grep length, keys %{ $self->{ALPHA} };
}

# give an array of symbols, return the symbols that
# are in the alphabet
#sub is_in_alphabet {
#  my $self = shift;
#  my $
#}

############
sub prune {
    my $self = shift;

    my @queue = $self->get_starting;
    my %seen  = map { $_ => 1 } @queue;

    while (@queue) {
        @queue = grep { !$seen{$_}++ } $self->successors( \@queue );
    }

    my @useless = grep { !$seen{$_} } $self->get_states;
    $self->delete_states(@useless);

    return @useless;
}

############

use Storable 'dclone';

sub clone {
    dclone( $_[0] );
}

sub _transpose {
    my $self = shift;
    my $N    = $self->num_states - 1;

    $self->{TRANS} = [
        map {
            my $row = $_;
            [ map { $_->[$row] } @{ $self->{TRANS} } ]
        } 0 .. $N
    ];
}

# tests to see if set1 is a subset of set2
sub array_is_subset {
    my $self = shift;
    my $set1 = shift;
    my $set2 = shift;
    $set1 = [$set1] if not ref $set1;
    $set2 = [$set2] if not ref $set2;
    my $ok       = 1;
    my %setcount = ();
    foreach ( $self->array_unique( @{$set1} ), $self->array_unique( @{$set2} ) ) {
        $setcount{$_}++;
    }
    foreach ( $self->array_unique( @{$set1} ) ) {
        if ( $setcount{$_} != 2 ) {
            $ok = 0;
            last;
        }
    }
    return $ok;
}

sub array_unique {
    my $self = shift;
    my %ret  = ();
    foreach (@_) {
        $ret{$_}++;
    }
    return keys(%ret);
}

sub array_complement {
    my $self = shift;
    my $set1 = shift;
    my $set2 = shift;
    my @ret  = ();

    # convert set1 to a hash
    my %set1hash = map { $_ => 1 } @{$set1};

    # iterate of set2 and test if $set1
    foreach ( @{$set2} ) {
        if ( !defined $set1hash{$_} ) {
            push( @ret, $_ );
        }
    }
    ## Now do the same using $set2
    # convert set2 to a hash
    my %set2hash = map { $_ => 1 } @{$set2};

    # iterate of set1 and test if $set1
    foreach ( @{$set1} ) {
        if ( !defined $set2hash{$_} ) {
            push( @ret, $_ );
        }
    }

    # now @ret contains all items in $set1 not in $set 2 and all
    # items in $set2 not in $set1
    return @ret;
}

# returns all items that 2 arrays have in common
sub array_intersect {
    my $self     = shift;
    my $set1     = shift;
    my $set2     = shift;
    my %setcount = ();
    my @ret      = ();
    foreach ( $self->array_unique( @{$set1} ) ) {
        $setcount{$_}++;
    }
    foreach ( $self->array_unique( @{$set2} ) ) {
        $setcount{$_}++;
        push( @ret, $_ ) if ( $setcount{$_} > 1 );
    }
    return @ret;
}

# given a set of symbols, returns only the valid ones
sub get_valid_symbols {
    my $self    = shift;
    my $symbols = shift;
    return $self->array_intersect( [ $self->alphabet() ], [ @{$symbols} ] );
}

## add an FA's states & transitions to this FA (as disjoint union)
sub _swallow {
    my ( $self, $other ) = @_;
    my $N1 = $self->num_states;
    my $N2 = $other->num_states;

    push @$_, (undef) x $N2 for @{ $self->{TRANS} };

    push @{ $self->{TRANS} }, [ (undef) x $N1, @{ clone $_ } ] for @{ $other->{TRANS} };

    push @{ $self->{STATES} }, @{ clone $other->{STATES} };

    for ( keys %{ $other->{ALPHA} } ) {
        $self->{ALPHA}{$_} += $other->{ALPHA}{$_};

        # towards objects as symbols
        if ( !exists( $self->{ALPHA_BLESSED}{$_} ) ) {
            $self->{ALPHA_BLESSED}{$_} = $other->{ALPHA_BLESSED}{$_};
        }
        else {
            $self->{ALPHA_BLESSED}{$_}->_increment_count( $other->{ALPHA_BLESSED}{$_}->get_count );
        }
    }

    return map { $_ + $N1 } $other->get_states;
}

1;

__END__