summaryrefslogtreecommitdiff
path: root/lib/Kratos/DFADriver/DFA.pm
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Kratos/DFADriver/DFA.pm')
-rw-r--r--lib/Kratos/DFADriver/DFA.pm277
1 files changed, 0 insertions, 277 deletions
diff --git a/lib/Kratos/DFADriver/DFA.pm b/lib/Kratos/DFADriver/DFA.pm
deleted file mode 100644
index 9b581d8..0000000
--- a/lib/Kratos/DFADriver/DFA.pm
+++ /dev/null
@@ -1,277 +0,0 @@
-package Kratos::DFADriver::DFA;
-
-use strict;
-use warnings;
-use 5.020;
-
-use parent 'Class::Accessor';
-
-use Data::Dumper;
-use FLAT::DFA;
-use Math::Cartesian::Product;
-
-Kratos::DFADriver::DFA->mk_ro_accessors(qw(model));
-
-our $VERSION = '0.00';
-
-sub new {
- my ( $class, %opt ) = @_;
-
- my $self = \%opt;
-
- bless( $self, $class );
-
- return $self;
-}
-
-sub set_model {
- my ( $self, $model ) = @_;
-
- $self->{model} = $model;
-
- return $self;
-}
-
-sub reduced_id_to_state {
- my ( $self, $id ) = @_;
-
- if ( not( $self->{excluded_states} and @{ $self->{excluded_states} } ) ) {
- return $self->model->get_state_name($id);
- }
-
- my @excluded
- = map { $self->model->get_state_id($_) } @{ $self->{excluded_states} };
- @excluded = reverse sort { $a <=> $b } @excluded;
- my @state_enum = $self->model->get_state_enum;
-
- for my $state (@excluded) {
- splice( @state_enum, $state, 1 );
- }
-
- return $state_enum[$id];
-}
-
-sub dfa {
- my ($self) = @_;
-
- if ( exists $self->{dfa} ) {
- return $self->{dfa};
- }
-
- my $dfa = FLAT::DFA->new();
- my @state_enum = $self->model->get_state_enum;
-
- $dfa->add_states( scalar @state_enum );
- $dfa->set_starting(0);
- $dfa->set_accepting( $dfa->get_states );
-
- for my $transition ( $self->model->transitions ) {
- print Dumper( $transition->{parameters} );
-
- for my $param ( @{ $transition->{parameters} } ) {
- if ( not defined $param->{values} ) {
- die(
-"argument values for transition $transition->{name} are undefined\n"
- );
- }
- if ( @{ $param->{values} } == 0 ) {
- die(
-"argument-value list for transition $transition->{name} is empty \n"
- );
- }
- }
-
- my @argtuples
- = cartesian { 1 } map { $_->{values} } @{ $transition->{parameters} };
-
- # cartesian will return a one-element list containing a reference to
- # an empty array if @{$transition->{parameters}} is empty
-
- for my $argtuple (@argtuples) {
- for my $transition_pair ( @{ $transition->{transitions} } ) {
- my ( $origin, $destination ) = @{$transition_pair};
- $dfa->add_transition(
- $self->model->get_state_id($origin),
- $self->model->get_state_id($destination),
- ':' . $transition->{name} . '!' . join( '!', @{$argtuple} )
- );
- }
- }
- }
-
- if ( $self->{excluded_states} and @{ $self->{excluded_states} } ) {
- my @to_delete = map { $self->model->get_state_id($_) }
- @{ $self->{excluded_states} };
- $dfa->delete_states(@to_delete);
- }
-
- $self->{dfa} = $dfa;
-
- say $dfa->as_summary;
-
- return $dfa;
-}
-
-sub run_str_to_trace {
- my ( $self, $run_str ) = @_;
- my @trace;
- my $dfa = $self->dfa;
- my %param = $self->model->parameter_hash;
- my $state = 0;
- my $state_duration = $self->{state_duration} // 1000;
- my @state_enum = $self->model->get_state_enum;
- my $prev_transition = {};
- for my $transition_str ( split( qr{ : }x, $run_str ) ) {
- my ( $cmd, @args ) = split( qr{ ! }x, $transition_str );
- my $state_name = $self->reduced_id_to_state($state);
- my $transition = $self->model->get_transition_by_name($cmd);
-
- push(
- @trace,
- {
- isa => 'state',
- name => $state_name,
- plan => {
- time => $prev_transition->{timeout}{static}
- // $state_duration,
- power => $self->model->get_state_power($state_name),
- energy => $self->model->get_state_power($state_name)
- * $state_duration,
- },
- parameter => { map { $_ => $param{$_}{value} } keys %param, },
- },
- {
- isa => 'transition',
- name => $cmd,
- args => [@args],
- code => [ $cmd, @args ],
- plan => {
- level => $transition->{level},
- energy => $transition->{energy}{static},
- timeout => $transition->{timeout}{static},
- },
- parameter => { map { $_ => $param{$_}{value} } keys %param, },
- },
- );
-
- $self->model->update_parameter_hash( \%param, $cmd, @args );
-
- ($state) = $dfa->successors( $state, ":${transition_str}" );
-
- if ( not defined $state ) {
- die("Transition $transition_str is invalid or has no successors\n");
- }
-
- $prev_transition = $transition;
- for my $extra_cmd (
- $self->model->get_state_extra_transitions( $state_enum[$state] ) )
- {
- $state_name = $self->reduced_id_to_state($state);
- $transition = $self->model->get_transition_by_name($extra_cmd);
- push(
- @trace,
- {
- isa => 'state',
- name => $state_name,
- plan => {
- time => $prev_transition->{timeout}{static}
- // $state_duration,
- power => $self->model->get_state_power($state_name),
- energy => $self->model->get_state_power($state_name)
- * $state_duration,
- },
- parameter =>
- { map { $_ => $param{$_}{value} } keys %param, },
- },
- {
- isa => 'transition',
- name => $extra_cmd,
- args => [],
- code => [$extra_cmd],
- plan => {
- level => $transition->{level},
- energy => $transition->{energy}{static},
- timeout => $transition->{timeout}{static},
- },
- parameter =>
- { map { $_ => $param{$_}{value} } keys %param, },
- }
- );
- $prev_transition = $transition;
- }
- }
-
- # required for unscheduled extra states and transitions caused by interrupts
- $trace[-1]{final_parameter}
- = { map { $_ => $param{$_}{value} } keys %param, };
- return @trace;
-}
-
-sub traces {
- my ($self) = @_;
-
- # Warning: This function is not deterministic!
- # Therefore, results are cached. When in doubt, reload traces / execution
- # plan from DriverEval.json
-
- if ( exists $self->{traces} ) {
- return @{ $self->{traces} };
- }
-
- my $max_iter = $self->{trace_revisit} // 2;
- my $next = $self->dfa->new_deepdft_string_generator($max_iter);
- my $trace_id = 1;
-
- my ( @raw_runs, @traces );
- my $filter_re;
-
- if ( $self->{trace_filter} and @{ $self->{trace_filter} } ) {
- my @res;
- for my $filter ( @{ $self->{trace_filter} } ) {
- my $re = $filter;
- $re =~ s{,}{![^:]*:}g;
- $re =~ s{$}{![^:]*)};
- $re =~ s{^}{(^};
- if ( $re =~ m{ \$ }x ) {
- $re =~ s{\$}{};
- $re =~ s{\)$}{\$)};
- }
- push( @res, $re );
- }
- $filter_re = join( q{|}, @res );
- }
-
- while ( my $run = $next->() ) {
- $run = substr( $run, 1 );
- if ( $filter_re and not $run =~ m{$filter_re} ) {
- next;
- }
- @raw_runs = grep { $_ ne substr( $run, 0, length($_) ) } @raw_runs;
- push( @raw_runs, $run );
- }
-
- if ( @raw_runs == 0 ) {
- say STDERR "--trace-filter did not match any run. Aborting.";
- exit 1;
- }
-
- @raw_runs = sort @raw_runs;
-
- for my $run_str (@raw_runs) {
- my @trace = $self->run_str_to_trace($run_str);
- push(
- @traces,
- {
- id => $trace_id,
- trace => [@trace],
- }
- );
- $trace_id++;
- }
-
- $self->{traces} = [@traces];
-
- return @traces;
-}
-
-1;
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-18 05:24:08 +0000