view release on metacpan or  search on metacpan

lib/Algorithm/ConstructDFA/XS.pm  view on Meta::CPAN

sub construct_dfa_xs {
  my (%o) = @_;
  
  die unless ref $o{is_nullable};
  die unless ref $o{is_accepting} or exists $o{final};
  die unless ref $o{successors} or ref $o{edges_from};
  die unless ref $o{get_label} or ref $o{edges_from};
  die unless exists $o{start} or exists $o{many_start};
  die if ref $o{is_accepting} and exists $o{final};
  die if ref $o{successors} and exists $o{edges_from};
  die if ref $o{get_label} and ref $o{edges_from};
  
  my $class = 'Algorithm::ConstructDFA::XS::Synth';
  
  if (exists $o{edges_from}) {

    my $old_accepting = $o{is_accepting};
    $o{is_accepting} = sub {
      my @config = grep { ref $_ ne $class } @_;
      return $old_accepting->(@config);
    };
    
    $o{get_label} = sub {
      my ($src) = @_;
      return unless ref $src eq $class;
      return (Storable::thaw($$src))->[1];
    };

    my $old_nullable = $o{is_nullable};
    $o{is_nullable} = sub {
      my ($src) = @_;
      
      if (ref $src eq $class) {
        my $deref = $$src;
        my $thawed = Storable::thaw $deref;
        return not defined $thawed->[1];
      }
      
      $old_nullable->($src);
    };

    my $old_edges_from = $o{edges_from};

    $o{successors} = sub {
      my ($src) = @_;
      
      if (ref $src eq $class) {
        return (Storable::thaw $$src)->[2];
      }
      
      my @successors;
      
      for my $edge ($old_edges_from->($src)) {
        my ($dst, $label) = @$edge;
        
        # TODO: theoretically there could be name clashes between the
        # artificial vertex created here and vertices in the original
        # unwrapped input which can interfere with the bimaps mapping
        # stringified vertices to numbers.
        push @successors, bless \(Storable::freeze([$src, $label, $dst])),
          $class;
      }
      
      return @successors;
    };

  }

  if (exists $o{final}) {
    my %in_final = map { $_ => 1 } @{ $o{final} };
    $o{is_accepting} = sub {
      grep { $in_final{$_} } @_
    };
  }

  $o{many_start} //= [$o{start}];
  
  my $dfa = _construct_dfa_xs($o{many_start}, $o{get_label},
    $o{is_nullable}, $o{successors}, $o{is_accepting});
    
  if (exists $o{edges_from}) {
    for (values %$dfa) {
      $_->{Combines} = [ grep {
        ref $_ ne $class;
      } @{ $_->{Combines} } ];
    }
  }
  
  return $dfa;
}

sub _construct_dfa_xs {
  my ($roots, $labelf, $nullablef, $successorsf, $acceptingf) = @_;

  my @todo = map { @$_ } @$roots;
  my %seen;
  my @args;
  my $sm = Data::AutoBimap->new;
  my $rm = Data::AutoBimap->new;
  my %is_start;
  
  for (my $ix = 0; $ix < @$roots; ++$ix) {
    for my $v (@{ $roots->[$ix] }) {
      push @{ $is_start{$v} }, $ix + 1;
    }
  }
  
  while (@todo) {
    my $c = pop @todo;
    
    next if $seen{$c}++;
    
    my $is_nullable = !!$nullablef->($c);
    my $label = $labelf->($c);
    my $label_x = defined $label ? $rm->s2n($label) : undef;
    
    # [vertex, label, nullable, start, successors...]
    my @data = ($sm->s2n($c), $label_x, !!$is_nullable, $is_start{$c} // []);

    for ($successorsf->($c)) {