summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/AspectC/Repo.pm42
-rw-r--r--lib/Kratos/DFADriver.pm18
-rw-r--r--lib/Kratos/DFADriver/DFA.pm20
-rw-r--r--lib/Kratos/DFADriver/Model.pm87
4 files changed, 123 insertions, 44 deletions
diff --git a/lib/AspectC/Repo.pm b/lib/AspectC/Repo.pm
index ec5bcd0..a2e94d2 100644
--- a/lib/AspectC/Repo.pm
+++ b/lib/AspectC/Repo.pm
@@ -64,10 +64,23 @@ sub parse_xml {
for my $attr_node ( $aspect->findnodes('./children/Attribute') ) {
my $attr_name = $attr_node->getAttribute('name');
my $attr_id = $attr_node->getAttribute('id');
+ my @args;
+ for my $arg_node ( $attr_node->findnodes('./args/Arg') ) {
+ my $arg_name = $arg_node->getAttribute('name');
+ my $arg_type = $arg_node->getAttribute('type');
+ push(
+ @args,
+ {
+ name => $arg_name,
+ type => $arg_type,
+ }
+ );
+ }
if ( defined $attr_id ) {
$self->{attributes}{$attr_id} = {
namespace => $aspect_name,
name => $attr_name,
+ arguments => \@args,
};
}
}
@@ -104,7 +117,6 @@ sub parse_xml {
my $name = $fnode->getAttribute('name');
my $id = $fnode->getAttribute('id') // q{?};
my $kind = $fnode->getAttribute('kind');
- my $attributes = $fnode->getAttribute('attributes');
my $result_type = q{?};
my @args;
@@ -123,12 +135,30 @@ sub parse_xml {
argtypes => [@args],
};
- if ($attributes) {
- $fun->{attributes} = [
- map { $self->{attributes}{$_}{name} }
- split( qr{ \s+ }x, $attributes )
- ];
+ for my $annotation_node (
+ $fnode->findnodes('./annotations/Annotation') )
+ {
+ my $attr_id = $annotation_node->getAttribute('attribute');
+ my $attribute = {
+ name => $self->{attributes}{$attr_id}{name},
+ namespace => $self->{attributes}{$attr_id}{namespace},
+ };
+ for my $param_node (
+ $annotation_node->findnodes('./parameters/Parameter') )
+ {
+ my $value = $param_node->getAttribute('value');
+ my $expression = $param_node->getAttribute('expression');
+ push(
+ @{ $attribute->{args} },
+ {
+ value => $value,
+ expression => $expression,
+ }
+ );
+ }
+ push( @{ $fun->{attributes} }, $attribute );
}
+
my $hash_key = sprintf( '%s(%s)', $name, join( q{, }, @args ) );
$class->{function}{$hash_key} = $fun;
}
diff --git a/lib/Kratos/DFADriver.pm b/lib/Kratos/DFADriver.pm
index 07f478c..deb758c 100644
--- a/lib/Kratos/DFADriver.pm
+++ b/lib/Kratos/DFADriver.pm
@@ -424,9 +424,9 @@ sub printf_parameterized {
$key, $status, $param, $std_ind_param, $std_this, $ratio,
$fline );
}
- if (exists $r_by_param->{$param}) {
- printf(" %s: spearman_r for global %s is %.3f (p = %.3f)\n",
- $key, $param, $r_by_param->{$param}, -1);
+ if ( exists $r_by_param->{$param} ) {
+ printf( " %s: spearman_r for global %s is %.3f (p = %.3f)\n",
+ $key, $param, $r_by_param->{$param}, -1 );
}
}
@@ -859,18 +859,19 @@ EOF
$buf .= "\n\t\t\\path\n";
for my $transition ( $self->model->transitions ) {
- for my $origin ( @{ $transition->{origins} } ) {
+ for my $transition_elem ( @{ $transition->{transitions} } ) {
+ my ( $origin, $destination ) = @{$transition_elem};
my @edgestyles;
if ( $transition->{level} eq 'epilogue' ) {
push( @edgestyles, 'dashed' );
}
- if ( $origin eq $transition->{destination} ) {
+ if ( $origin eq $destination ) {
push( @edgestyles, 'loop above' );
}
my $edgestyle
= @edgestyles ? '[' . join( q{,}, @edgestyles ) . ']' : q{};
$buf
- .= "\t\t ($origin) edge ${edgestyle} node {$transition->{name}} ($transition->{destination})\n";
+ .= "\t\t ($origin) edge ${edgestyle} node {$transition->{name}} ($destination)\n";
}
}
$buf .= "\t\t;\n";
@@ -992,8 +993,7 @@ sub to_test_h {
my ($self) = @_;
my $class_name = $self->{class_name};
- my $class_prefix
- = $self->repo->get_class_path_prefix( $class_name );
+ my $class_prefix = $self->repo->get_class_path_prefix($class_name);
my $buf = <<"EOF";
@@ -1138,7 +1138,7 @@ sub launchpad_connect {
$self->{port} = Device::SerialPort->new( $self->{port_file} )
or croak("Error openig serial port $self->{port_file}");
- $self->{port}->baudrate($self->{baud_rate} // 115200);
+ $self->{port}->baudrate( $self->{baud_rate} // 115200 );
$self->{port}->databits(8);
$self->{port}->parity('none');
$self->{port}->read_const_time(500);
diff --git a/lib/Kratos/DFADriver/DFA.pm b/lib/Kratos/DFADriver/DFA.pm
index 33d96c3..9b581d8 100644
--- a/lib/Kratos/DFADriver/DFA.pm
+++ b/lib/Kratos/DFADriver/DFA.pm
@@ -6,6 +6,7 @@ use 5.020;
use parent 'Class::Accessor';
+use Data::Dumper;
use FLAT::DFA;
use Math::Cartesian::Product;
@@ -65,7 +66,21 @@ sub dfa {
$dfa->set_accepting( $dfa->get_states );
for my $transition ( $self->model->transitions ) {
- my $destination = $transition->{destination};
+ 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} };
@@ -73,7 +88,8 @@ sub dfa {
# an empty array if @{$transition->{parameters}} is empty
for my $argtuple (@argtuples) {
- for my $origin ( @{ $transition->{origins} } ) {
+ 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),
diff --git a/lib/Kratos/DFADriver/Model.pm b/lib/Kratos/DFADriver/Model.pm
index 216f3b8..264a443 100644
--- a/lib/Kratos/DFADriver/Model.pm
+++ b/lib/Kratos/DFADriver/Model.pm
@@ -74,32 +74,57 @@ sub new_from_repo {
for my $function ( values %{ $class_base->{function} } ) {
my %param_values;
for my $attrib ( @{ $function->{attributes} // [] } ) {
- if ( $attrib =~ s{ ^ src _ }{}x ) {
- push( @states, $attrib );
- push( @{ $transition{ $function->{name} }{src} }, $attrib );
- }
- elsif ( $attrib =~ s{ ^ dst _ }{}x ) {
- push( @states, $attrib );
- push( @{ $transition{ $function->{name} }{dst} }, $attrib );
- }
- elsif ( $attrib =~ s{ ^ required_in_ }{}x ) {
- push(
- @{
- $self->{custom_code}{after_transition_by_state}{$attrib}
- },
- $function->{name}
- );
+ if ( $attrib->{namespace} eq 'Model' ) {
+ if ( $attrib->{name} =~ m{ ^ transition }x
+ and @{ $attrib->{args} } == 2 )
+ {
+ push( @states, $attrib->{args}[0]{expression} );
+ push( @states, $attrib->{args}[1]{expression} );
+ push(
+ @{ $transition{ $function->{name} }{src} },
+ $attrib->{args}[0]{expression}
+ );
+ push(
+ @{ $transition{ $function->{name} }{dst} },
+ $attrib->{args}[1]{expression}
+ );
+ push(
+ @{ $transition{ $function->{name} }{transitions} },
+ [
+ $attrib->{args}[0]{expression},
+ $attrib->{args}[1]{expression}
+ ]
+ );
+ }
+ elsif ( $attrib->{name} =~ m{ ^ testval }x
+ and @{ $attrib->{args} } == 2 )
+ {
+ push(
+ @{ $param_values{ $attrib->{args}[0]{value} } },
+ $attrib->{args}[1]{value}
+ );
+ }
+ elsif (
+ $attrib->{name} =~ m{ ^ required_in_ (?<state> .* ) $ }x )
+ {
+ push(
+ @{
+ $self->{custom_code}{after_transition_by_state}
+ { $+{state} }
+ },
+ $function->{name}
+ );
+ }
+ else {
+ printf( "wat %s::%s\n",
+ $attrib->{namespace}, $attrib->{name} );
+ }
}
elsif ( $attrib =~ m{ ^ epilogue $ }x ) {
$transition{ $function->{name} }{level} = 'epilogue';
}
- elsif ( $attrib
- =~ m{ ^ testarg _ (?<index> [^_]+ ) _ (?<value> [^_]+) $ }x )
- {
- push( @{ $param_values{ $+{index} } }, $+{value} );
- }
else {
- say "wat $attrib";
+ printf( "wat %s::%s\n", $attrib->{namespace}, $attrib->{name} );
}
}
if ( exists $transition{ $function->{name} } ) {
@@ -160,22 +185,30 @@ sub new_from_repo {
my @transition_names = sort keys %transition;
for my $i ( 0 .. $#transition_names ) {
- my $name = $transition_names[$i];
- my $guess_level = ( $name eq 'epilogue' ? 'epilogue' : 'user' );
+
+ my $name = $transition_names[$i];
+ my @origins = uniq @{ $transition{$name}{src} };
+ my @destinations = uniq @{ $transition{$name}{dst} };
+ my $guess_level = ( $name eq 'epilogue' ? 'epilogue' : 'user' );
+
$self->{transition}{$name} = {
name => $name,
id => $i,
- destination => $transition{$name}{dst}[0],
- origins => $transition{$name}{src},
+ destination => \@destinations,
+ origins => \@origins,
+ transitions => $transition{$name}{transitions},
level => $transition{$name}{level} // $guess_level,
parameters => $transition{$name}{parameters} // [],
+ duration => { static => 0 },
energy => { static => 0 },
rel_energy_prev => { static => 0 },
rel_energy_next => { static => 0 },
+ timeout => { static => 0 },
};
- if ( @{ $transition{$name}{dst} } > 1 ) {
+ if ( @destinations > 1 ) {
+ my $dst_str = join( q{, }, @destinations );
warn(
-"Transition ${name} has several destination states. This is not supported yet.\n"
+"Transition ${name} has several destination states ($dst_str). This is only partially supported.\n"
);
}
}
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-27 05:59:03 +0000