view release on metacpan or  search on metacpan

t/03rand.t  view on Meta::CPAN

    my $count = $dfa->compute_some_transitions($max);
    ok $count <= $max, "obeys transition count limit"
      or diag(" $count vs $max ");
    last unless $count;
  }

  return $dfa, $start_id;
}

sub random_element {
  return unless @_;
  [@_]->[ int rand scalar @_ ]
}

sub random_graph {
  my $g = Graph::Directed->random_graph(
    vertices => $max_vertices,
  );

  # workaround for bug in Graph::Directed
  $g->delete_vertex( 0 );

  return Graph::Feather->new(
    vertices => [ $g->vertices ],
    edges => [ $g->edges ],
  )
}

sub random_path_between {
  my ($g, $start, $final, $max_length) = @_;

  my $dbh = $g->{dbh};

  return unless grep {
    $_ eq $final
  } $start, $g->all_successors($start);

  $max_length //= 1_000;

  my $sth = $dbh->prepare(q{
    WITH RECURSIVE random_path(pos, vertex) AS (
      SELECT 0 AS pos, ? AS vertex
      UNION ALL
      SELECT
        random_path.pos + 1 AS pos,
        (SELECT Edge.dst
        FROM Edge
        WHERE Edge.src = random_path.vertex
        ORDER BY RANDOM()
        LIMIT 1) AS next
      FROM random_path
      WHERE next IS NOT NULL
    )
    SELECT vertex
    FROM random_path
    LIMIT ?
  });

  while (1) {

    my @path = map { @$_ } $dbh->selectall_array($sth,
      {}, $start, $max_length);

    my @endpoints = indexes { $_ eq $final } @path;
    my $last_elem = random_element( @endpoints );

    next unless defined $last_elem;

    splice @path, $last_elem + 1;

    return @path;
  }
}

sub random_dfa_path {
  my ($dfa, $start_id, $max_length, @accepting) = @_;

  my $dbh = $dfa->_dbh;

#  return unless grep {
#    $_ eq $final
#  } $start, $g->all_successors($start);

  $max_length //= 1_000;

  my $sth = $dbh->prepare(q{
    WITH RECURSIVE random_dfa_path(pos, state) AS (
      SELECT 0 AS pos, ? AS state
      UNION ALL
      SELECT
        random_dfa_path.pos + 1 AS pos,
        (SELECT Transition.dst
        FROM Transition
        WHERE Transition.src = random_dfa_path.state
        ORDER BY RANDOM()
        LIMIT 1) AS next
      FROM random_dfa_path
      WHERE next IS NOT NULL
    )
    SELECT state
    FROM random_dfa_path
    LIMIT ?
  });

  my %accepting = map { $_ => 1 } @accepting;

  while (1) {

    my @path = map { @$_ } $dbh->selectall_array($sth,
      {}, $start_id, $max_length);

    my @endpoints = indexes { %accepting{$_} } @path;
    my $last_elem = random_element( @endpoints );

    next unless defined $last_elem;

    splice @path, $last_elem + 1;

    return @path;
  }
}

sub inputs_from_vertex_path {
  my ($matches, $nullable, @path) = @_;

  my @inputs = map {
    my $v = $_;

    my @options = grep {
      $matches->{$v}{$_}
    } keys %{ $matches->{$v} };

    random_element( @options );

  } grep {
    not $nullable->{$_}
  } @path[ 0 .. $#path - 1 ];

  return @inputs;  
}

sub path_to_vertex_pos_pairs {
  my ($nullable, @path) = @_;

  my $i = 0;

  return map { $nullable->{$_} ? [$i, $_] : [$i++, $_] } @path;
}

sub simulate_dfa_on_input {
  my ($dfa, $start_id, @inputs) = @_;

  $dfa->_dbh->begin_work();

  $dfa->_dbh->do(q{
    CREATE TEMPORARY TABLE temp_test_input(value);
  });

  my $sth = $dfa->_dbh->prepare(q{
    INSERT INTO temp_test_input(value) VALUES(?)
  });

  $sth->execute($_) for @inputs;

  my @dfa_trail = $dfa->_dbh->selectall_array(q{
    WITH RECURSIVE dfa_trail(pos, src, input, dst) AS (

        SELECT p.rowid AS pos, t.src, t.input, t.dst
        FROM temp_test_input p
          LEFT JOIN Transition t
            ON (t.input = p.value)
        WHERE t.src = ? AND p.rowid = 1

      UNION ALL

        SELECT p.rowid AS pos, t.src, t.input, t.dst
        FROM dfa_trail d
          LEFT JOIN temp_test_input p 
            ON (p.rowid = d.pos + 1)
          LEFT JOIN Transition t
            ON (t.src = d.dst AND t.input = p.value)
        WHERE p.value IS NOT NULL
    )
    SELECT * FROM dfa_trail
  }, {}, $start_id);

  # NOTE: @dfa_trail is empty if no input

  $dfa->_dbh->rollback;

  return @dfa_trail;
}

sub dfa_path_join_5tuple {
  my ($dfa, @dfa_path) = @_;

  $dfa->_dbh->begin_work();

  $dfa->_dbh->do(q{
    CREATE TEMPORARY TABLE temp_dfa_path(state)
  });

  my $sth = $dfa->_dbh->prepare(q{
    INSERT INTO temp_dfa_path(state) VALUES(?)
  });

  $sth->execute($_) for @dfa_path;

  my @result = $dfa->_dbh->selectall_array(q{
    SELECT
      p1.rowid AS src_pos,
      v.src_state, v.src_vertex,
      v.via,
      IFNULL(p2.rowid, p1.rowid) AS dst_pos,
      v.dst_state, v.dst_vertex
    FROM
      temp_dfa_path p1
        LEFT JOIN temp_dfa_path p2
          ON (p1.rowid + 1 = p2.rowid)
        LEFT JOIN view_transitions_as_5tuples v
          ON (v.src_state = p1.state AND
            (v.dst_state = p2.state
               OR (v.via IS NULL AND v.dst_state = v.src_state)))
    WHERE v.dst_state IS NOT NULL
  });

  $dfa->_dbh->rollback();

  return @result;
}

for ( 1 .. 100 ) {
  my $g = random_graph();
  my $start = random_element( $g->vertices );
  my $final = random_element($start, $g->all_successors($start));

  my %nullable;
  $nullable{ $_ } = rand() < $nullable_odds for $g->vertices;

  my %matches;
  for my $v ($g->vertices) {
    next if $nullable{$v};
    for my $ch (@alphabet) {
      $matches{$v}{$ch} = rand() < $matches_odds;
    }
    $matches{$v}{random_element( @alphabet )} = 1;
  }

  my ($dfa, $start_id) = get_dfa($g, $start, $final,
    \%nullable, \%matches);

  my @accepting = $dfa->cleanup_dead_states(sub {
    scalar grep { $_ eq $final } @_;
  });

  my %accepting_id = map { $_ => 1 } @accepting;

  ok scalar(@accepting), 'at least 1 accepting state';

  my $dead_state_id = $dfa->dead_state_id;

  for my $dfa_path_counter ( 1 .. 16 ) {
    my @dfa_path = random_dfa_path($dfa, $start_id, 100, @accepting);

    next unless @dfa_path > 1;

    my @xxx = dfa_path_join_5tuple($dfa, @dfa_path);

    ok((any {