Support specification of transitions in AspectC++ annotations

3 files changed, 87 insertions, 38 deletions

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"
 			);
 		}
 	}