view release on metacpan or  search on metacpan

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

my @alphabet = ( 11111, 22222, 33333, 44444, 55555, 66666 );
my $max_vertices = 8;
my $nullable_odds = 0.3;
my $matches_odds = 1 / @alphabet;

sub get_dfa {
  my ($g, $start, $final, $nullable, $matches) = @_;

  my $db_file = ':memory:';
#  unlink $db_file;

  my $dfa = Algorithm::ConstructDFA2->new(
    input_alphabet     => [ @alphabet ],
    input_vertices     => [ $g->vertices ],
    input_edges        => [ $g->edges ],

    vertex_nullable    => sub {
      return $nullable->{ $_[0] };
    },

    vertex_matches     => sub {
      return $matches->{ $_[0] }{ $_[1] };
    },

    storage_dsn        => "dbi:SQLite:dbname=$db_file",
  );

  my $start_id = $dfa->find_or_create_state_id( $start );

  while (1) {
    my $max = 1 + int rand 100;
    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