diff options
Diffstat (limited to 'lib/Kratos/DFADriver/Model.pm')
| -rw-r--r-- | lib/Kratos/DFADriver/Model.pm | 495 |
1 files changed, 0 insertions, 495 deletions
diff --git a/lib/Kratos/DFADriver/Model.pm b/lib/Kratos/DFADriver/Model.pm deleted file mode 100644 index 4a38155..0000000 --- a/lib/Kratos/DFADriver/Model.pm +++ /dev/null @@ -1,495 +0,0 @@ -package Kratos::DFADriver::Model; - -use strict; -use warnings; -use 5.020; - -use parent 'Class::Accessor'; - -use Carp; -use Carp::Assert::More; -use List::Util qw(first uniq); -use File::Slurp qw(read_file write_file); -use JSON; - -Kratos::DFADriver::Model->mk_ro_accessors( - qw(class_name parameter state transition)); - -our $VERSION = '0.00'; - -sub new { - my ( $class, %opt ) = @_; - - my $self = \%opt; - - $self->{custom_code} = {}; - $self->{parameter} = {}; - $self->{state} = {}; - $self->{transition} = {}; - $self->{voltage} = {}; - - bless( $self, $class ); - - my $json = JSON->new->decode( scalar read_file( $self->{model_file} ) ); - for my $key (qw(custom_code parameter state transition)) { - $self->{$key} = $json->{$key}; - } - $self->{class_name} = $json->{class}; - - return $self; -} - -sub new_from_repo { - my ( $class, %opt ) = @_; - my $repo = $opt{repo}; - - my $self = { - class_name => $opt{class_name}, - model_file => $opt{model_file}, - voltage => {}, - }; - - bless( $self, $class ); - - my $class_name = $self->{class_name}; - - my @states; - my %transition; - - if ( not exists $repo->{class}{$class_name} ) { - die("Unknown class: $class_name\n"); - } - my $class_base = $repo->{class}{$class_name}; - - for my $function ( values %{ $class_base->{function} } ) { - my %param_values; - for my $attrib ( @{ $function->{attributes} // [] } ) { - 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'; - } - else { - printf( "wat %s::%s\n", $attrib->{namespace}, $attrib->{name} ); - } - } - if ( exists $transition{ $function->{name} } ) { - for my $i ( 0 .. $#{ $function->{argtypes} } ) { - my $argtype = $function->{argtypes}[$i]; - my $param_name = sprintf( '%s.arg%d', $function->{name}, $i ); - push( - @{ $transition{ $function->{name} }{parameters} }, - { - name => $param_name, - values => $param_values{$i}, - } - ); - $self->{parameter}{$param_name} = { - arg_name => $param_name, - function => $function->{name}, - default => undef, - }; - } - } - } - - if ( exists $repo->{class}{"DriverEvalThread_${class_name}"} ) { - for my $var ( - keys %{ $repo->{class}{"DriverEvalThread_${class_name}"}{variable} } - ) - { - if ( $var - =~ m{ ^ testVal __ (?<fun> [^_]+ ) __ arg (?<index> \d+ ) __ (?<descr> [^_]+ ) $ }x - ) - { - push( - @{ - $transition{ $+{fun} }{parameters}[ $+{index} ]{values} - }, - $var - ); - } - } - } - - @states = uniq @states; - @states = sort @states; - - # by convention, UNINITIALIZED always has ID 0 - @states = grep { $_ ne 'UNINITIALIZED' } @states; - unshift( @states, 'UNINITIALIZED' ); - - for my $i ( 0 .. $#states ) { - $self->{state}{ $states[$i] } = { - id => $i, - power => { - static => 0, - } - }; - } - - my @transition_names = sort keys %transition; - - for my $i ( 0 .. $#transition_names ) { - - 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 => \@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 ( @destinations > 1 ) { - my $dst_str = join( q{, }, @destinations ); - warn( -"Transition ${name} has several destination states ($dst_str). This is only partially supported.\n" - ); - } - } - - write_file( $self->{model_file}, - JSON->new->pretty->encode( $self->TO_JSON ) ); - - return $self; -} - -sub reset_property { - my ( $self, $hash, $name ) = @_; - - delete $hash->{$name}{static}; - if ( exists $hash->{$name}{function} ) { - delete $hash->{$name}{function}{estimate}; - } - if ( exists $hash->{$name}{function}{user} ) { - $hash->{$name}{function}{user}{params} - = [ map { 1 } @{ $hash->{$name}{function}{user}{params} } ]; - } -} - -sub reset { - my ($self) = @_; - - for my $state ( values %{ $self->{state} } ) { - for my $property (qw(power)) { - $self->reset_property( $state, $property ); - } - } - - for my $transition ( $self->transitions ) { - for my $property ( - qw(duration energy rel_energy_prev rel_energy_next timeout)) - { - $self->reset_property( $transition, $property ); - } - } -} - -sub set_state_power { - my ( $self, $state, $power ) = @_; - - $power = sprintf( '%.f', $power ); - - printf( "state %-16s: adjust power %d -> %d µW\n", - $state, $self->{state}{$state}{power}{static}, $power ); - - $self->{state}{$state}{power}{static} = $power; -} - -sub set_transition_property { - my ( $self, $transition_name, $property, $value ) = @_; - - if ( not defined $value ) { - return; - } - - my $transition = $self->get_transition_by_name($transition_name); - - $value = sprintf( '%.f', $value ); - - printf( "transition %-16s: adjust %s %d -> %d\n", - $transition->{name}, $property, $transition->{$property}{static}, - $value ); - - $transition->{$property}{static} = $value; -} - -sub set_state_lut { - my ( $self, $state, $property, $lut ) = @_; - - if ( not defined $lut ) { - return; - } - - ...; -} - -sub set_transition_lut { - my ( $self, $transition_name, $property, $lut ) = @_; - - if ( not defined $lut ) { - return; - } - - ...; -} - -sub set_state_params { - my ( $self, $state, $fun_name, $function, @params ) = @_; - my $old_params = 'None'; - - if ( exists $self->{state}{$state}{power}{function}{$fun_name} ) { - $old_params = join( q{ }, - @{ $self->{state}{$state}{power}{function}{$fun_name}{params} } ); - } - - printf( "state %-16s: adjust %s power function parameters [%s] -> [%s]\n", - $state, $fun_name, $old_params, join( q{ }, @params ) ); - - $self->{state}{$state}{power}{function}{$fun_name}{raw} = $function; - for my $i ( 0 .. $#params ) { - $self->{state}{$state}{power}{function}{$fun_name}{params}[$i] - = $params[$i]; - } -} - -sub set_transition_params { - my ( $self, $transition_name, $fun_type, $fun_name, $function, @params ) - = @_; - my $transition = $self->get_transition_by_name($transition_name); - my $old_params = 'None'; - - if ( exists $transition->{$fun_type}{function}{$fun_name} ) { - $old_params = join( q{ }, - @{ $transition->{$fun_type}{function}{$fun_name}{params} } ); - } - - printf( "transition %-16s: adjust %s %s function parameters [%s] -> [%s]\n", - $transition_name, $fun_name, $fun_type, $old_params, - join( q{ }, @params ) ); - - $transition->{$fun_type}{function}{$fun_name}{raw} = $function; - for my $i ( 0 .. $#params ) { - $transition->{$fun_type}{function}{$fun_name}{params}[$i] = $params[$i]; - } -} - -sub set_voltage { - my ( $self, $min_voltage, $max_voltage ) = @_; - - $self->{voltage} = { - min => $min_voltage, - max => $max_voltage, - }; -} - -sub save { - my ($self) = @_; - - write_file( $self->{model_file}, - JSON->new->pretty->encode( $self->TO_JSON ) ); -} - -sub parameter_hash { - my ($self) = @_; - - for my $param_name ( keys %{ $self->{parameter} } ) { - $self->{parameter}{$param_name}{value} - = $self->{parameter}{$param_name}{default}; - } - - return %{ $self->{parameter} }; -} - -sub update_parameter_hash { - my ( $self, $param_hash, $function, @args ) = @_; - - my $transition = $self->get_transition_by_name($function); - - for my $param ( keys %{ $transition->{affects} } ) { - $param_hash->{$param}{value} = $transition->{affects}{$param}; - } - - for my $i ( 0 .. $#args ) { - my $arg_name = $transition->{parameters}[$i]{name}; - my $arg_value = $args[$i]; - - for my $param_name ( keys %{ $self->{parameter} } ) { - if ( $self->{parameter}{$param_name}{arg_name} eq $arg_name ) { - $param_hash->{$param_name}{value} = $arg_value; - } - } - } -} - -sub startup_code { - my ($self) = @_; - - return $self->{custom_code}{startup} // q{}; -} - -sub heap_code { - my ($self) = @_; - - return $self->{custom_code}{heap} // q{}; -} - -sub after_transition_code { - my ($self) = @_; - - return $self->{custom_code}{after_transition} // q{}; -} - -sub get_state_extra_transitions { - my ( $self, $state ) = @_; - - return @{ $self->{custom_code}{after_transition_by_state}{$state} // [] }; -} - -sub shutdown_code { - my ($self) = @_; - - return $self->{custom_code}{shutdown} // q{}; -} - -sub get_transition_by_name { - my ( $self, $name ) = @_; - - return $self->{transition}{$name}; -} - -sub get_transition_by_id { - my ( $self, $id ) = @_; - - my $transition = first { $_->{id} == $id } $self->transitions; - - return $transition; -} - -sub get_state_id { - my ( $self, $name ) = @_; - - return $self->{state}{$name}{id}; -} - -sub get_state_name { - my ( $self, $id ) = @_; - - return ( $self->get_state_enum )[$id]; -} - -sub get_state_power { - my ( $self, $name ) = @_; - - return $self->{state}{$name}{power}{static}; -} - -sub get_state_power_with_params { - my ( $self, $name, $param_values ) = @_; - - my $hash_str = join( ';', - map { $param_values->{$_} } - sort { $a cmp $b } keys %{$param_values} ); - - if ( $hash_str eq q{} ) { - return $self->get_state_power($name); - } - - if ( exists $self->{state}{$name}{power}{lut}{$hash_str} ) { - return $self->{state}{$name}{power}{lut}{$hash_str}; - } - - say "Note: No matching LUT for state ${name}, using median"; - - return $self->get_state_power($name); -} - -sub get_state_enum { - my ($self) = @_; - - if ( not exists $self->{state_enum} ) { - @{ $self->{state_enum} } - = sort { $self->{state}{$a}{id} <=> $self->{state}{$b}{id} } - keys %{ $self->{state} }; - } - - return @{ $self->{state_enum} }; -} - -sub transitions { - my ($self) = @_; - - my @ret = values %{ $self->{transition} }; - @ret = sort { $a->{id} <=> $b->{id} } @ret; - return @ret; -} - -sub TO_JSON { - my ($self) = @_; - - return { - class => $self->{class_name}, - parameter => $self->{parameter}, - state => $self->{state}, - transition => $self->{transition}, - custom_code => $self->{custom_code}, - voltage => $self->{voltage}, - }; -} - -1; |