initial commit

1 files changed, 251 insertions, 0 deletions

diff --git a/lib/Kratos/DFADriver/DFA.pm b/lib/Kratos/DFADriver/DFA.pm
new file mode 100644
index 0000000..ef834e0
--- /dev/null
+++ b/lib/Kratos/DFADriver/DFA.pm
@@ -0,0 +1,251 @@
+package Kratos::DFADriver::DFA;
+
+use strict;
+use warnings;
+use 5.020;
+
+use parent 'Class::Accessor';
+
+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 ) {
+		my $destination = $transition->{destination};
+		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 $origin ( @{ $transition->{origins} } ) {
+				$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 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 $dfa            = $self->dfa;
+	my @state_enum     = $self->model->get_state_enum;
+	my $next           = $dfa->new_deepdft_string_generator($max_iter);
+	my $state_duration = $self->{state_duration} // 1000;
+	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{^}{(^};
+			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;
+		my %param           = $self->model->parameter_hash;
+		my $state           = 0;
+		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}" );
+			$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, },
+		  push(
+			@traces,
+			{
+				id    => $trace_id,
+				trace => [@trace],
+			}
+		  );
+		$trace_id++;
+	}
+
+	$self->{traces} = [@traces];
+
+	return @traces;
+}
+
+1;