diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/AspectC/Repo.pm | 140 | ||||
| -rw-r--r-- | lib/AspectC/Repo/Function.pm | 55 | ||||
| -rw-r--r-- | lib/FLAT.pm | 197 | ||||
| -rw-r--r-- | lib/FLAT/CMD.pm | 533 | ||||
| -rw-r--r-- | lib/FLAT/CMD/AcyclicStrings.pm | 54 | ||||
| -rw-r--r-- | lib/FLAT/CMD/DFTStrings.pm | 55 | ||||
| -rw-r--r-- | lib/FLAT/DFA.pm | 557 | ||||
| -rw-r--r-- | lib/FLAT/FA.pm | 554 | ||||
| -rw-r--r-- | lib/FLAT/NFA.pm | 509 | ||||
| -rw-r--r-- | lib/FLAT/PFA.pm | 293 | ||||
| -rw-r--r-- | lib/FLAT/Regex.pm | 194 | ||||
| -rw-r--r-- | lib/FLAT/Regex/Op.pm | 282 | ||||
| -rw-r--r-- | lib/FLAT/Regex/Parser.pm | 82 | ||||
| -rw-r--r-- | lib/FLAT/Regex/Transform.pm | 18 | ||||
| -rw-r--r-- | lib/FLAT/Regex/Util.pm | 33 | ||||
| -rw-r--r-- | lib/FLAT/Regex/WithExtraOps.pm | 109 | ||||
| -rw-r--r-- | lib/FLAT/Symbol.pm | 98 | ||||
| -rw-r--r-- | lib/FLAT/Transition.pm | 66 | ||||
| -rw-r--r-- | lib/FLAT/XFA.pm | 3 | ||||
| -rw-r--r-- | lib/Kratos/DFADriver.pm | 1334 | ||||
| -rw-r--r-- | lib/Kratos/DFADriver/DFA.pm | 251 | ||||
| -rw-r--r-- | lib/Kratos/DFADriver/Model.pm | 555 | ||||
| -rw-r--r-- | lib/MIMOSA.pm | 177 | ||||
| -rw-r--r-- | lib/MIMOSA/Log.pm | 388 | ||||
| -rwxr-xr-x | lib/dfatool.py | 291 | ||||
| -rwxr-xr-x | lib/plotter.py | 177 |
26 files changed, 7005 insertions, 0 deletions
diff --git a/lib/AspectC/Repo.pm b/lib/AspectC/Repo.pm new file mode 100644 index 0000000..6f59117 --- /dev/null +++ b/lib/AspectC/Repo.pm @@ -0,0 +1,140 @@ +package AspectC::Repo; + +use strict; +use warnings; +use 5.020; +use List::Util qw(first); +use XML::LibXML; + +our $VERSION = '0.00'; + +my @source_loc_kind = (qw(none definition declaration)); +my @function_kind = ( + qw(unknown non_member static_non_member member + static_member virtual_member pure_virtual_member conctructor destructor + virtual_destructor pure_virtual_destructor) +); +my @pointcut_kind = (qw(normal virtual pure_virtual)); +my @variable_kind + = (qw(unknown non_member static_non_member member static_member)); +my @advice_code_kind = (qw(before after around)); +my @advice_code_context + = (qw(none type obj type_obj vars type_vars obj_vars type_obj_vars)); +my @cv_qualifiers = (qw(none const volatile const_volatile)); + +sub new { + my ( $class, %opt ) = @_; + + my $self = \%opt; + + $self->{xml} + = XML::LibXML->load_xml( location => '../kratos/src/repo.acp' ); + + bless( $self, $class ); + $self->parse_xml; + return $self; +} + +sub parse_xml { + my ($self) = @_; + + my $xml = $self->{xml}; + + for my $node ( + $xml->findnodes('/ac-model/files/TUnit | /ac-model/files/Header') ) + { + my $filename = $node->getAttribute('filename'); + my $id = $node->getAttribute('id'); + if ( defined $id ) { + $self->{files}[$id] = $filename; + } + else { + say STDERR "repo.acp: File ${filename} has no ID"; + } + } + + for my $node ( + $xml->findnodes('/ac-model/root/Namespace[@name="::"]/children/Class') ) + { + my $class = {}; + my $class_name = $node->getAttribute('name'); + my $id = $node->getAttribute('id'); + my @bases; + my @functions; + my @sources; + if ( my $base_str = $node->getAttribute('bases') ) { + @bases = split( qr{ }, $base_str ); + } + + for my $source ( $node->findnodes('./source/Source') ) { + push( + @sources, + { + file => $self->{files}[ $source->getAttribute('file') ], + kind => $source_loc_kind[ $source->getAttribute('kind') ], + } + ); + } + + $class->{name} = $class_name; + $class->{id} = $id; + $class->{sources} = [@sources]; + + for my $fnode ( $node->findnodes('./children/Function') ) { + my $name = $fnode->getAttribute('name'); + my $id = $fnode->getAttribute('id') // q{?}; + my $kind = $fnode->getAttribute('kind'); + my $result_type = q{?}; + my @args; + + if ( my $typenode = ( $fnode->findnodes('./result_type/Type') )[0] ) + { + $result_type = $typenode->getAttribute('signature'); + } + + #print "$id $name $kind $result_type <- "; + for my $argnode ( $fnode->findnodes('./arg_types/Type') ) { + push( @args, $argnode->getAttribute('signature') ); + } + + #say join( q{, }, @args ); + } + $self->{class}{$class_name} = $class; + } + + for my $node ( + $xml->findnodes( + '/ac-model/root/Namespace[@name="::"]/children/Variable') + ) + { + my $sig_node = ( $node->findnodes('./type/Type') )[0]; + my $kind = $node->getAttribute('kind'); + my $name = $node->getAttribute('name'); + my $signature = $sig_node->getAttribute('signature'); + + if ( $variable_kind[$kind] eq 'non_member' ) { + $self->{class_instance}{$signature} = $name; + } + } + + return $self; +} + +sub get_class_path_prefix { + my ( $self, $class_name ) = @_; + + my $header = first { $_->{kind} eq 'definition' } + @{ $self->{class}{$class_name}{sources} }; + $header = $header->{file}; + $header =~ s{ \. h $ }{}x; + + return $header; +} + +sub get_class_instance { + my ( $self, $class_name ) = @_; + + return $self->{class_instance}{$class_name}; +} + +1; diff --git a/lib/AspectC/Repo/Function.pm b/lib/AspectC/Repo/Function.pm new file mode 100644 index 0000000..a7edae2 --- /dev/null +++ b/lib/AspectC/Repo/Function.pm @@ -0,0 +1,55 @@ +package AspectC::Repo::Function; + +use strict; +use warnings; +use 5.020; + +our $VERSION = '0.00'; + +sub new { + my ( $class, %opts ) = @_; + + my $self = {}; + + return bless( $self, $class ); +} + +1; + +__END__ + +=head1 NAME + +=head1 SYNOPSIS + +=head1 VERSION + +version + +=head1 DESCRIPTION + +=head1 METHODS + +=over + +=back + +=head1 DIAGNOSTICS + +=head1 DEPENDENCIES + +=over + +=back + +=head1 BUGS AND LIMITATIONS + +=head1 SEE ALSO + +=head1 AUTHOR + +Copyright (C) 2016 by Daniel Friesel E<lt>derf@finalrewind.orgE<gt> + +=head1 LICENSE + + 0. You just DO WHAT THE FUCK YOU WANT TO. diff --git a/lib/FLAT.pm b/lib/FLAT.pm new file mode 100644 index 0000000..ee6af9d --- /dev/null +++ b/lib/FLAT.pm @@ -0,0 +1,197 @@ +package FLAT; +use FLAT::Regex; +use FLAT::NFA; +use FLAT::DFA; +use Carp; + +use vars '$VERSION'; +$VERSION = 0.9.1; + +=head1 NAME + +FLAT - Formal Language & Automata Toolkit + +=head1 SYNOPSIS + +FLAT.pm is the base class of all regular language objects. For more +information, see other POD pages. + +=head1 USAGE + +All regular language objects in FLAT implement the following methods. +Specific regular language representations (regex, NFA, DFA) may implement +additional methods that are outlined in the repsective POD pages. + +=cut + +## let subclasses implement a minimal set of closure properties. +## they can override these with more efficient versions if they like. + +sub as_dfa { + $_[0]->as_nfa->as_dfa; +} + +sub as_min_dfa { + $_[0]->as_dfa->as_min_dfa; +} + +sub is_infinite { + ! $_[0]->is_finite; +} + +sub star { + $_[0]->kleene +} + +sub difference { + $_[0]->intersect( $_[1]->complement ); +} + +sub symdiff { + my $self = shift; + return $self if not @_; + my $next = shift()->symdiff(@_); + ( $self->difference($next) )->union( $next->difference($self) ); +} + +sub equals { + $_[0]->symdiff($_[1])->is_empty +} + +sub is_subset_of { + $_[0]->difference($_[1])->is_empty +} + +BEGIN { + for my $method (qw[ as_nfa as_regex union intersect complement concat + kleene reverse is_empty is_finite ]) + { + no strict 'refs'; + *$method = sub { + my $pkg = ref $_[0] || $_[0]; + carp "$pkg does not (yet) implement $method"; + }; + } +} + +1; + +__END__ + +=head2 Conversions Among Representations + +=over + +=item $lang-E<gt>as_nfa + +=item $lang-E<gt>as_dfa + +=item $lang-E<gt>as_min_dfa + +=item $lang-E<gt>as_regex + +Returns an equivalent regular language to $lang in the desired +representation. Does not modify $lang (even if $lang is already in the +desired representation). + +For more information on the specific algorithms used in these conversions, +see the POD pages for a specific representation. + +=back + +=head2 Closure Properties + +=over + +=item $lang1-E<gt>union($lang2, $lang3, ... ) + +=item $lang1-E<gt>intersect($lang2, $lang3, ... ) + +=item $lang1-E<gt>concat($lang2, $lang3, ... ) + +=item $lang1-E<gt>symdiff($lang2, $lang3, ... ) + +Returns a regular language object that is the union, intersection, +concatenation, or symmetric difference of $lang1 ... $langN, respectively. +The return value will have the same representation (regex, NFA, or DFA) +as $lang1. + +=item $lang1-E<gt>difference($lang2) + +Returns a regular language object that is the set difference of $lang1 and +$lang2. Equivalent to + + $lang1->intersect($lang2->complement) + +The return value will have the same representation (regex, NFA, or DFA) +as $lang1. + +=item $lang-E<gt>kleene + +=item $lang-E<gt>star + +Returns a regular language object for the Kleene star of $lang. The return +value will have the same representation (regex, NFA, or DFA) as $lang. + +=item $lang-E<gt>complement + +Returns a regular language object for the complement of $lang. The return +value will have the same representation (regex, NFA, or DFA) as $lang. + +=item $lang-E<gt>reverse + +Returns a regular language object for the stringwise reversal of $lang. +The return value will have the same representation (regex, NFA, or DFA) +as $lang. + +=back + +=head2 Decision Properties + +=over + +=item $lang-E<gt>is_finite + +=item $lang-E<gt>is_infinite + +Returns a boolean value indicating whether $lang represents a +finite/infinite language. + +=item $lang-E<gt>is_empty + +Returns a boolean value indicating whether $lang represents the empty +language. + +=item $lang1-E<gt>equals($lang2) + +Returns a boolean value indicating whether $lang1 and $lang2 are +representations of the same language. + +=item $lang1-E<gt>is_subset_of($lang2) + +Returns a boolean value indicating whether $lang1 is a subset of +$lang2. + +=item $lang-E<gt>contains($string) + +Returns a boolean value indicating whether $string is in the language +represented by $lang. + +=back + +=head1 AUTHORS & ACKNOWLEDGEMENTS + +FLAT is written by Mike Rosulek E<lt>mike at mikero dot comE<gt> and Brett +Estrade E<lt>estradb at gmail dot comE<gt>. + +The initial version (FLAT::Legacy) by Brett Estrade was work towards an MS +thesis at the University of Southern Mississippi. + +=head1 LICENSE + +This module is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=head1 MORE INFO + +Please visit the Wiki at http://www.0x743.com/flat diff --git a/lib/FLAT/CMD.pm b/lib/FLAT/CMD.pm new file mode 100644 index 0000000..5bd0e2d --- /dev/null +++ b/lib/FLAT/CMD.pm @@ -0,0 +1,533 @@ +package FLAT::CMD; +use FLAT; +use FLAT::Regex; +use FLAT::NFA; +use FLAT::DFA; +use Carp; + +=head1 NAME + +CMD - Commandline interface for the Formal Language & Automata Toolkit + +=head1 SYNOPSIS + +CMD.pm is provides an interface to the C<fash> commandline utility that offers +certain features implemented in FLAT. Consequently, this interface is also +available using the C<perl -MFLAT::CMD -e func> paradigm, but C<fash> makes +things a lot more convenient. + +=head1 USAGE + +All regular language objects in FLAT implement the following methods. +Specific regular language representations (regex, NFA, DFA) may implement +additional methods that are outlined in the repsective POD pages. + +=cut + +# Support for perl one liners - like what CPAN.pm uses #<- should move all to another file +use base 'Exporter'; #instead of: use Exporter (); @ISA = 'Exporter'; +use vars qw(@EXPORT $AUTOLOAD); + +@EXPORT = qw(compare dump dfa2gv nfa2gv pfa2gv dfa2undgv nfa2undgv pfa2undgv dfa2digraph + nfa2digraph pfa2digraph dfa2undirected nfa2undirected pfa2undirected random_pre random_re + savedfa test help + ); + +sub AUTOLOAD { + my($l) = $AUTOLOAD; + $l =~ s/.*:://; + my(%EXPORT); + @EXPORT{@EXPORT} = ''; + if (exists $EXPORT{$l}){ + FLAT::CMD->$l(@_); + } +} + +sub help { +print <<END +__________ .__ ___________.____ ___________ +\______ \ ___________| | \_ _____/| | _____\__ ___/ + | ___// __ \_ __ \ | | __) | | \__ \ | | + | | \ ___/| | \/ |__ | \ | |___ / __ \| | + |____| \___ >__| |____/ \___ / |_______ (____ /____| + \/ \/ \/ \/ + + Everything is wrt parallel regular expressions, i.e., + with the addtional shuffle operator, "&". All this + means is that you can use the ambersand (&) as a symbol + in the regular expressions you submit because it will be + detected as an operator.That said, if you avoid using + the "&" operator, you can forget about all that shuffle + business. + +%perl -MFLAT::CMD -e + "somestrings" 're1' # creates all valid strings via acyclic path, no cycles yet + "compare 're1','re2'" # comares 2 regexs | see note [2] + "dump 're1'" # dumps parse trees | see note[1] + "dfa2gv 're1'" # dumps graphviz digraph desc | see note[1] + "nfa2gv 're1'" # dumps graphviz digraph desc | see note[1] + "pfa2gv 're1'" # dumps graphviz digraph desc | see note[1] + "dfa2undgv 're1'" # dumps graphviz undirected graph desc | see note[1] + "nfa2undgv 're1'" # dumps graphviz undirected graph desc | see note[1] + "pfa2undgv 're1'" # dumps graphviz undirected graph desc | see note[1] + "dfa2digraph 're1'" # dumps directed graph without transitions + "nfa2digraph 're1'" # dumps directed graph without transitions + "pfa2digraph 're1'" # dumps directed graph without transitions + "dfa2undirected 're1'" # dumps undirected graph without transitions + "nfa2undirected 're1'" # dumps undirected graph without transitions + "pfa2undirected 're1'" # dumps undirected graph without transitions + random_pre + random_re + "savedfa 're1'" # converts PRE to min dfa, then serializes to disk + "test 'regex' 'string1'" # give a regex, reports if subsequent strings are valid + help + +NOTES: +[1] This means you could presumably do something like the following: + %perl -MFLAT -e command < text_file_with_1_regex_per_line.txt + ^^^^^^^ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +[2] This command compares the minimal DFAs of each regular expression; + if there exists a exact 1-1 mapping of symbols, states, and + transitions then the DFAs are considered equal. This means that + "abc" will be equal to "def" To make matters more confusing, "ab+ac" + would be equivalent to "xy+xz"; or worse yet, "z(x+y)". So to the + 'compare' command, "ab+ac" == "xy+xz" == "z(x+y)". This however + does not translate into the situation where "ab+ac" will accept + the same LITERAL strings as "z(x+y)" because the symbols are obviously + different. + +CREDITS: +Blockhead, CPAN.pm (for the example of how to implement these one liners), +and #perl on irc.freenode.net for pointing out something I missed when +trying to copy CPAN one liner majik. + +Perl FLAT and all included modules are released under the same terms as Perl +itself. Cheers. + +SEE: +http://www.0x743.com/flat + +END +} + +# save to a dat file +sub savedfa { + my $PRE = shift; + # neat a better way to get input via stdin + if (!$PRE) { + while (<>) { + chomp; + $PRE = $_; + last; + } + } + use FLAT::Regex::WithExtraOps; + use FLAT::PFA; + use FLAT::NFA; + use FLAT::DFA; + use Storable; + # caches results, loads them in if detexted + my $dfa = FLAT::Regex::WithExtraOps->new($PRE)->as_pfa->as_nfa->as_dfa->as_min_dfa->trim_sinks; + store $dfa, "$PRE.dat"; +} + +# dumps directed graph using Kundu notation +# Usage: +# perl -MFLAT -e "pfa2directed('a&b&c&d*e*')" +sub test { + use FLAT::Regex::WithExtraOps; + use FLAT::PFA; + use FLAT::NFA; + use FLAT::DFA; + # handles multiple strings; first is considered the regex + if (@_) + { my $FA = FLAT::Regex::WithExtraOps->new(shift @_)->as_pfa()->as_nfa->as_dfa(); + foreach (@_) + { if ($FA->is_valid_string($_)) { + print "(+): $_\n"; + } else { + print "(-): $_\n"; + } + } + } else { + my $FA; + while (<STDIN>) { + chomp; + if ($. == 1) { #<-- uses first line as regex! + $FA = FLAT::Regex::WithExtraOps->new($_)->as_pfa()->as_nfa->as_dfa(); + } else { + if ($FA->is_valid_string($_)) { + print "(+): $_\n"; + } else { + print "(-): $_\n"; + } + } + } + } +} + +# dumps parse tree +# Usage: +# perl -MFLAT -e "dump('re1','re2',...,'reN')" +# perl -MFLAT -e dump < list_of_regexes.dat +sub dump { + use FLAT::Regex::WithExtraOps; + use Data::Dumper; + if (@_) + { foreach (@_) + { my $PRE = FLAT::Regex::WithExtraOps->new($_); + print Dumper($PRE); }} + else + { while (<STDIN>) + { chomp; + my $PRE = FLAT::Regex::WithExtraOps->new($_); + print Dumper($PRE); } + } +} + +# dumps graphviz notation +# Usage: +# perl -MFLAT -e "dfa2gv('a&b&c&d*e*')" +sub dfa2gv { + use FLAT::Regex::WithExtraOps; + use FLAT::DFA; + use FLAT::NFA; + use FLAT::PFA; + if (@_) + { foreach (@_) + { my $FA = FLAT::Regex::WithExtraOps->new($_)->as_pfa()->as_nfa()->as_dfa()->as_min_dfa()->trim_sinks(); + print $FA->as_graphviz;} } + else + { while (<STDIN>) + { chomp; + my $FA = FLAT::Regex::WithExtraOps->new($_)->as_pfa()->as_nfa()->as_dfa->as_min_dfa()->trim_sinks(); + print $FA->as_graphviz;} + } +} + +# dumps graphviz notation +# Usage: +# perl -MFLAT -e "nfa2gv('a&b&c&d*e*')" +sub nfa2gv { + use FLAT::Regex::WithExtraOps; + use FLAT::DFA; + use FLAT::NFA; + use FLAT::PFA; + if (@_) + { foreach (@_) + { my $FA = FLAT::Regex::WithExtraOps->new($_)->as_pfa()->as_nfa(); + print $FA->as_graphviz;} } + else + { while (<STDIN>) + { chomp; + my $FA = FLAT::Regex::WithExtraOps->new($_)->as_pfa()->as_nfa(); + print $FA->as_graphviz;} + } +} + +# dumps graphviz notation +# Usage: +# perl -MFLAT -e "pfa2gv('a&b&c&d*e*')" +sub pfa2gv { + use FLAT::Regex::WithExtraOps; + use FLAT::PFA; + if (@_) + { foreach (@_) + { my $FA = FLAT::Regex::WithExtraOps->new($_)->as_pfa(); + print $FA->as_graphviz;} } + else + { while (<STDIN>) + { chomp; + my $FA = FLAT::Regex::WithExtraOps->new($_)->as_pfa(); + print $FA->as_graphviz;} + } +} + +#as_undirected_graphviz + +# dumps graphviz notation +# Usage: +# perl -MFLAT -e "dfa2undgv('a&b&c&d*e*')" +sub dfa2undgv { + use FLAT::Regex::WithExtraOps; + use FLAT::DFA; + use FLAT::NFA; + use FLAT::PFA; + if (@_) + { foreach (@_) + { my $FA = FLAT::Regex::WithExtraOps->new($_)->as_pfa()->as_nfa()->as_dfa()->as_min_dfa()->trim_sinks(); + print $FA->as_undirected_graphviz;} } + else + { while (<STDIN>) + { chomp; + my $FA = FLAT::Regex::WithExtraOps->new($_)->as_pfa()->as_nfa()->as_dfa->as_min_dfa()->trim_sinks(); + print $FA->as_undirected_graphviz;} + } +} + +# dumps graphviz notation +# Usage: +# perl -MFLAT -e "nfa2undgv('a&b&c&d*e*')" +sub nfa2undgv { + use FLAT::Regex::WithExtraOps; + use FLAT::DFA; + use FLAT::NFA; + use FLAT::PFA; + if (@_) + { foreach (@_) + { my $FA = FLAT::Regex::WithExtraOps->new($_)->as_pfa()->as_nfa(); + print $FA->as_undirected_graphviz;} } + else + { while (<STDIN>) + { chomp; + my $FA = FLAT::Regex::WithExtraOps->new($_)->as_pfa()->as_nfa(); + print $FA->as_undirected_graphviz;} + } +} + +# dumps graphviz notation +# Usage: +# perl -MFLAT -e "pfa2undgv('a&b&c&d*e*')" +sub pfa2undgv { + use FLAT::Regex::WithExtraOps; + use FLAT::PFA; + if (@_) + { foreach (@_) + { my $FA = FLAT::Regex::WithExtraOps->new($_)->as_pfa(); + print $FA->as_undirected_graphviz;} } + else + { while (<STDIN>) + { chomp; + my $FA = FLAT::Regex::WithExtraOps->new($_)->as_pfa(); + print $FA->as_undirected_graphviz;} + } +} + +# dumps directed graph using Kundu notation +# Usage: +# perl -MFLAT -e "dfa2directed('a&b&c&d*e*')" +sub dfa2digraph { + use FLAT::Regex::WithExtraOps; + use FLAT::DFA; + use FLAT::NFA; + use FLAT::PFA; + # trims sink states from min-dfa since transitions are gone + if (@_) + { foreach (@_) + { my $FA = FLAT::Regex::WithExtraOps->new($_)->as_pfa()->as_nfa()->as_dfa->as_min_dfa->trim_sinks(); + print $FA->as_digraph;} } + else + { while (<STDIN>) + { chomp; + my $FA = FLAT::Regex::WithExtraOps->new($_)->as_pfa()->as_nfa()->as_dfa->as_min_dfa->trim_sinks(); + print $FA->as_digraph;} + } + print "\n"; +} + +# dumps directed graph using Kundu notation +# Usage: +# perl -MFLAT -e "nfa2directed('a&b&c&d*e*')" +sub nfa2digraph { + use FLAT::Regex::WithExtraOps; + use FLAT::DFA; + use FLAT::NFA; + use FLAT::PFA; + if (@_) + { foreach (@_) + { my $FA = FLAT::Regex::WithExtraOps->new($_)->as_pfa()->as_nfa(); + print $FA->as_digraph;} } + else + { while (<STDIN>) + { chomp; + my $FA = FLAT::Regex::WithExtraOps->new($_)->as_pfa()->as_nfa(); + print $FA->as_digraph;} + } + print "\n"; +} + +# dumps directed graph using Kundu notation +# Usage: +# perl -MFLAT -e "pfa2directed('a&b&c&d*e*')" +sub pfa2digraph { + use FLAT::Regex::WithExtraOps; + use FLAT::PFA; + if (@_) + { foreach (@_) + { my $FA = FLAT::Regex::WithExtraOps->new($_)->as_pfa(); + print $FA->as_digraph;} } + else + { while (<STDIN>) + { chomp; + my $FA = FLAT::Regex::WithExtraOps->new($_)->as_pfa(); + print $FA->as_digraph;} + } + print "\n"; +} + +# dumps undirected graph using Kundu notation +# Usage: +# perl -MFLAT -e "dfa2undirected('a&b&c&d*e*')" +sub dfa2undirected { + use FLAT::Regex::WithExtraOps; + use FLAT::DFA; + use FLAT::NFA; + use FLAT::PFA; + # trims sink states from min-dfa since transitions are gone + if (@_) + { foreach (@_) + { my $FA = FLAT::Regex::WithExtraOps->new($_)->as_pfa()->as_nfa()->as_dfa->as_min_dfa->trim_sinks(); + print $FA->as_undirected;} } + else + { while (<STDIN>) + { chomp; + my $FA = FLAT::Regex::WithExtraOps->new($_)->as_pfa()->as_nfa()->as_dfa->as_min_dfa->trim_sinks(); + print $FA->as_undirected;} + } + print "\n"; +} + +# dumps undirected graph using Kundu notation +# Usage: +# perl -MFLAT -e "nfa2undirected('a&b&c&d*e*')" +sub nfa2undirected { + use FLAT::Regex::WithExtraOps; + use FLAT::DFA; + use FLAT::NFA; + use FLAT::PFA; + if (@_) + { foreach (@_) + { my $FA = FLAT::Regex::WithExtraOps->new($_)->as_pfa()->as_nfa(); + print $FA->as_undirected;} } + else + { while (<STDIN>) + { chomp; + my $FA = FLAT::Regex::WithExtraOps->new($_)->as_pfa()->as_nfa(); + print $FA->as_undirected;} + } + print "\n"; +} + +# dumps undirected graph using Kundu notation +# Usage: +# perl -MFLAT -e "pfa2undirected('a&b&c&d*e*')" +sub pfa2undirected { + use FLAT::Regex::WithExtraOps; + use FLAT::PFA; + if (@_) + { foreach (@_) + { my $FA = FLAT::Regex::WithExtraOps->new($_)->as_pfa(); + print $FA->as_undirected;} } + else + { while (<STDIN>) + { chomp; + my $FA = FLAT::Regex::WithExtraOps->new($_)->as_pfa(); + print $FA->as_undirected;} + } + print "\n"; +} + +# compares 2 give PREs +# Usage: +# perl -MFLAT -e "compare('a','a&b&c&d*e*')" #<-- no match, btw +sub compare { + use FLAT::Regex::WithExtraOps; + use FLAT::DFA; + use FLAT::PFA; + my $PFA1 = FLAT::Regex::WithExtraOps->new(shift)->as_pfa(); + my $PFA2 = FLAT::Regex::WithExtraOps->new(shift)->as_pfa(); + my $DFA1 = $PFA1->as_nfa->as_min_dfa; + my $DFA2 = $PFA2->as_nfa->as_min_dfa; + if ($DFA1->equals($DFA2)) { + print "Yes\n"; + } else { + print "No\n"; + } +} + +# prints random PRE +# Usage: +# perl -MFLAT -e random_pre +sub random_pre { + my $and_chance = shift; + # skirt around deep recursion warning annoyance + local $SIG{__WARN__} = sub { $_[0] =~ /^Deep recursion/ or warn $_[0] }; + srand $$; + my %CMDLINEOPTS = (); + # Percent chance of each operator occuring + $CMDLINEOPTS{LENGTH} = 32; + $CMDLINEOPTS{OR} = 6; + $CMDLINEOPTS{STAR} = 10; + $CMDLINEOPTS{OPEN} = 5; + $CMDLINEOPTS{CLOSE} = 0; + $CMDLINEOPTS{n} = 1; + $CMDLINEOPTS{AND} = 10; #<-- default + $CMDLINEOPTS{AND} = $and_chance if ($and_chance == 0); #<-- to make it just an re (no shuffle) + + + my $getRandomChar = sub { + my $ch = ''; + # Get a random character between 0 and 127. + do { + $ch = int(rand 2); + } while ($ch !~ m/[a-zA-Z0-9]/); + return $ch; + }; + + my $getRandomRE = sub { + my $str = ''; + my @closeparens = (); + for (1..$CMDLINEOPTS{LENGTH}) { + $str .= $getRandomChar->(); + # % chance of an "or" + if (int(rand 100) < $CMDLINEOPTS{OR}) { + $str .= "|1"; + } elsif (int(rand 100) < $CMDLINEOPTS{AND}) { + $str .= "&0"; + } elsif (int(rand 100) < $CMDLINEOPTS{STAR}) { + $str .= "*1"; + } elsif (int(rand 100) < $CMDLINEOPTS{OPEN}) { + $str .= "("; + push(@closeparens,'0101)'); + } elsif (int(rand 100) < $CMDLINEOPTS{CLOSE} && @closeparens) { + $str .= pop(@closeparens); + } + } + # empty out @closeparens if there are still some left + if (@closeparens) { + $str .= join('',@closeparens); + } + return $str; + }; + + for (1..$CMDLINEOPTS{n}) { + print $getRandomRE->(),"\n"; + } +} + +# prints random RE (no & operator) +# Usage: +# perl -MFLAT -e random_re +sub random_re { + shift->random_pre(0); +} + +1; + +__END__ + +=head1 AUTHORS & ACKNOWLEDGEMENTS + +FLAT is written by Mike Rosulek E<lt>mike at mikero dot comE<gt> and +Brett Estrade E<lt>estradb at gmail dot comE<gt>. + +The initial version (FLAT::Legacy) by Brett Estrade was work towards an +MS thesis at the University of Southern Mississippi. + +Please visit the Wiki at http://www.0x743.com/flat + +=head1 LICENSE + +This module is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + diff --git a/lib/FLAT/CMD/AcyclicStrings.pm b/lib/FLAT/CMD/AcyclicStrings.pm new file mode 100644 index 0000000..ebc8840 --- /dev/null +++ b/lib/FLAT/CMD/AcyclicStrings.pm @@ -0,0 +1,54 @@ +# all strings available via acyclic path from the DFA start state to any all of the final states + +package FLAT::CMD::AcyclicStrings; +use base 'FLAT::CMD'; +use FLAT; +use FLAT::Regex::WithExtraOps; +use FLAT::PFA; +use FLAT::NFA; +use FLAT::DFA; +use Storable; +use Carp; + +# Support for perl one liners - like what CPAN.pm uses #<- should move all to another file +use base 'Exporter'; #instead of: use Exporter (); @ISA = 'Exporter'; +use vars qw(@EXPORT $AUTOLOAD); + +@EXPORT = qw(as_strings); + +sub AUTOLOAD { + my($l) = $AUTOLOAD; + $l =~ s/.*:://; + my(%EXPORT); + @EXPORT{@EXPORT} = ''; + if (exists $EXPORT{$l}){ + FLAT::CMD->$l(@_); + } +} + +use vars qw(%nodes %dflabel %backtracked %low $lastDFLabel @string $dfa); +# acyclic - no cycles +sub as_strings { + my $PRE = shift; + # neat a better way to get input via stdin + if (!$PRE) { + while (<>) { + chomp; + $PRE = $_; + last; + } + } + # caches results, loads them in if detexted + my $RE = FLAT::Regex::WithExtraOps->new($PRE); + printf("%s\n",$RE->as_string()); + if (!-e "$PRE.dat") { + $dfa = $RE->as_pfa->as_nfa->as_dfa->as_min_dfa->trim_sinks; + #store $dfa, "$PRE.dat"; + } else { + print STDERR "$PRE.dat found.."; + $dfa = retrieve "$PRE.dat"; + } + $dfa->as_acyclic_strings(); +} + +1; diff --git a/lib/FLAT/CMD/DFTStrings.pm b/lib/FLAT/CMD/DFTStrings.pm new file mode 100644 index 0000000..9dc5a59 --- /dev/null +++ b/lib/FLAT/CMD/DFTStrings.pm @@ -0,0 +1,55 @@ +# all strings available via depth first traversal, including back edges that happen to land on an accepting state + +package FLAT::CMD::DFTStrings; +use base 'FLAT::CMD'; +use FLAT; +use FLAT::Regex::WithExtraOps; +use FLAT::PFA; +use FLAT::NFA; +use FLAT::DFA; +use Storable; +use Carp; + +# Support for perl one liners - like what CPAN.pm uses #<- should move all to another file +use base 'Exporter'; #instead of: use Exporter (); @ISA = 'Exporter'; +use vars qw(@EXPORT $AUTOLOAD); + +@EXPORT = qw(as_strings); + +sub AUTOLOAD { + my($l) = $AUTOLOAD; + $l =~ s/.*:://; + my(%EXPORT); + @EXPORT{@EXPORT} = ''; + if (exists $EXPORT{$l}){ + FLAT::CMD->$l(@_); + } +} + +use vars qw(%nodes %dflabel %backtracked %low $lastDFLabel @string $dfa); +# acyclic - no cycles +sub as_strings { + my $PRE = shift; + # neat a better way to get input via stdin + if (!$PRE) { + while (<>) { + chomp; + $PRE = $_; + last; + } + } + # caches results, loads them in if detexted + my $RE = FLAT::Regex::WithExtraOps->new($PRE); + printf("%s\n",$RE->as_string()); + if (!-e "$PRE.dat") { + $dfa = $RE->as_pfa->as_nfa->as_dfa->as_min_dfa->trim_sinks; + #store $dfa, "$PRE.dat"; + } else { + print STDERR "$PRE.dat found.."; + $dfa = retrieve "$PRE.dat"; + } + + $dfa->as_dft_strings(shift); +} + +1; diff --git a/lib/FLAT/DFA.pm b/lib/FLAT/DFA.pm new file mode 100644 index 0000000..f96c9fb --- /dev/null +++ b/lib/FLAT/DFA.pm @@ -0,0 +1,557 @@ +package FLAT::DFA; + +use strict; +use base 'FLAT::NFA'; +use Storable qw(dclone); +use Carp; +$|++; + +sub set_starting { + my $self = shift; + $self->SUPER::set_starting(@_); + + my $num = () = $self->get_starting; + confess "DFA must have exactly one starting state" + if $num != 1; +} + +sub complement { + my $self = $_[0]->clone; + + for my $s ($self->get_states) { + $self->is_accepting($s) + ? $self->unset_accepting($s) + : $self->set_accepting($s); + } + + return $self; +} + +sub _TUPLE_ID { join "\0", @_ } +sub _uniq { my %seen; grep { !$seen{$_}++ } @_; } + +## this method still needs more work.. +sub intersect { + my @dfas = map { $_->as_dfa } @_; + + my $return = FLAT::DFA->new; + my %newstates; + my @alpha = _uniq( map { $_->alphabet } @dfas ); + + $_->_extend_alphabet(@alpha) for @dfas; + + my @start = map { $_->get_starting } @dfas; + my $start = $newstates{ _TUPLE_ID(@start) } = $return->add_states(1); + $return->set_starting($start); + $return->set_accepting($start) + if ! grep { ! $dfas[$_]->is_accepting( $start[$_] ) } 0 .. $#dfas; + + my @queue = (\@start); + while (@queue) { + my @tuple = @{ shift @queue }; + + for my $char (@alpha) { + my @next = map { $dfas[$_]->successors( $tuple[$_], $char ) } + 0 .. $#dfas; + + #warn "[@tuple] --> [@next] via $char\n"; + + if (not exists $newstates{ _TUPLE_ID(@next) }) { + my $s = $newstates{ _TUPLE_ID(@next) } = $return->add_states(1); + $return->set_accepting($s) + if ! grep { ! $dfas[$_]->is_accepting( $next[$_] ) } 0 .. $#dfas; + push @queue, \@next; + } + + $return->add_transition( $newstates{ _TUPLE_ID(@tuple) }, + $newstates{ _TUPLE_ID(@next) }, + $char ); + } + } + + return $return; +} + +# this is meant to enforce 1 starting state for a DFA, but it is getting us into trouble +# when a DFA object calls unset_starting +sub unset_starting { + my $self = shift; + $self->SUPER::unset_starting(@_); + my $num = () = $self->unset_starting; + croak "DFA must have exactly one starting state" + if $num != 1; +} + +#### transformations + +sub trim_sinks { + my $self = shift; + my $result = $self->clone(); + foreach my $state ($self->array_complement([$self->get_states()],[$self->get_accepting()])) { + my @ret = $self->successors($state,[$self->alphabet]); + if (@ret) { + if ($ret[0] == $state) { + $result->delete_states($state) if ($result->is_state($state)); + } + } + } + return $result; +} + +sub as_min_dfa { + + my $self = shift()->clone; + my $N = $self->num_states; + my @alphabet = $self->alphabet; + + my ($start) = $self->get_starting; + my %final = map { $_ => 1 } $self->get_accepting; + + my @equiv = map [ (0) x ($_+1), (1) x ($N-$_-1) ], 0 .. $N-1; + + while (1) { + my $changed = 0; + for my $s1 (0 .. $N-1) { + for my $s2 (grep { $equiv[$s1][$_] } 0 .. $N-1) { + + if ( 1 == grep defined, @final{$s1, $s2} ) { + $changed = 1; + $equiv[$s1][$s2] = 0; + next; + } + + for my $char (@alphabet) { + my @t = sort { $a <=> $b } $self->successors([$s1,$s2], $char); + next if @t == 1; + + if (not $equiv[ $t[0] ][ $t[1] ]) { + $changed = 1; + $equiv[$s1][$s2] = 0; + } + } + }} + + last if !$changed; + } + my $result = (ref $self)->new; + my %newstate; + my @classes; + for my $s (0 .. $N-1) { + next if exists $newstate{$s}; + + my @c = ( $s, grep { $equiv[$s][$_] } 0 .. $N-1 ); + push @classes, \@c; + + @newstate{@c} = ( $result->add_states(1) ) x @c; + } + + for my $c (@classes) { + my $s = $c->[0]; + for my $char (@alphabet) { + my ($next) = $self->successors($s, $char); + $result->add_transition( $newstate{$s}, $newstate{$next}, $char ); + } + } + + $result->set_starting( $newstate{$start} ); + $result->set_accepting( $newstate{$_} ) + for $self->get_accepting; + + $result; + +} + +# the validity of a given string <-- executes symbols over DFA +# if there is not transition for given state and symbol, it fails immediately +# if the current state we're in is not final when symbols are exhausted, then it fails + +sub is_valid_string { + my $self = shift; + my $string = shift; + chomp $string; + my $OK = undef; + my @stack = split('',$string); + # this is confusing all funcs return arrays + my @current = $self->get_starting(); + my $current = pop @current; + foreach (@stack) { + my @next = $self->successors($current,$_); + if (!@next) { + return $OK; #<--returns undef bc no transition found + } + $current = $next[0]; + } + $OK++ if ($self->is_accepting($current)); + return $OK; +} + +# +# Experimental!! +# + +# DFT stuff in preparation for DFA pump stuff; +sub as_node_list { + my $self = shift; + my %node = (); + for my $s1 ($self->get_states) { + $node{$s1} = {}; # initialize + for my $s2 ($self->get_states) { + my $t = $self->get_transition($s1, $s2); + if (defined $t) { + # array of symbols that $s1 will go to $s2 on... + push(@{$node{$s1}{$s2}},split(',',$t->as_string)); + } + } + } + return %node; +} + +sub as_acyclic_strings { + my $self = shift; + my %dflabel = (); # lookup table for dflable + my %backtracked = (); # lookup table for backtracked edges + my $lastDFLabel = 0; + my @string = (); + my %nodes = $self->as_node_list(); + # output format is the actual PRE followed by all found strings + $self->acyclic($self->get_starting(),\%dflabel,$lastDFLabel,\%nodes,\@string); +} + +sub acyclic { + my $self = shift; + my $startNode = shift; + my $dflabel_ref = shift; + my $lastDFLabel = shift; + my $nodes = shift; + my $string = shift; + # tree edge detection + if (!exists($dflabel_ref->{$startNode})) { + $dflabel_ref->{$startNode} = ++$lastDFLabel; # the order inwhich this link was explored + foreach my $adjacent (keys(%{$nodes->{$startNode}})) { + if (!exists($dflabel_ref->{$adjacent})) { # initial tree edge + foreach my $symbol (@{$nodes->{$startNode}{$adjacent}}) { + push(@{$string},$symbol); + $self->acyclic($adjacent,\%{$dflabel_ref},$lastDFLabel,\%{$nodes},\@{$string}); + if ($self->array_is_subset([$adjacent],[$self->get_accepting()])) { #< proof of concept + printf("%s\n",join('',@{$string})); + } + pop(@{$string}); + } + } + } + } + # remove startNode entry to facilitate acyclic path determination + delete($dflabel_ref->{$startNode}); + #$lastDFLabel--; + return; +}; + +sub as_dft_strings { + my $self = shift; + my $depth = 1; + $depth = shift if (1 < $_[0]); + my %dflabel = (); # scoped lookup table for dflable + my %nodes = $self->as_node_list(); + foreach (keys(%nodes)) { + $dflabel{$_} = []; # initialize container (array) for multiple dflables for each node + } + my $lastDFLabel = 0; + my @string = (); + $self->dft($self->get_starting(),[$self->get_accepting()],\%dflabel,$lastDFLabel,\%nodes,\@string,$depth); +} + +sub dft { + my $self = shift; + my $startNode = shift; + my $goals_ref = shift; + my $dflabel_ref = shift; + my $lastDFLabel = shift; + my $nodes = shift; + my $string = shift; + my $DEPTH = shift; + # add start node to path + my $c1 = @{$dflabel_ref->{$startNode}}; # get number of elements + if ($DEPTH >= $c1) { + push(@{$dflabel_ref->{$startNode}},++$lastDFLabel); + foreach my $adjacent (keys(%{$nodes->{$startNode}})) { + my $c2 = @{$dflabel_ref->{$adjacent}}; + if ($DEPTH > $c2) { # "initial" tree edge + foreach my $symbol (@{$nodes->{$startNode}{$adjacent}}) { + push(@{$string},$symbol); + $self->dft($adjacent,[@{$goals_ref}],$dflabel_ref,$lastDFLabel,$nodes,[@{$string}],$DEPTH); + # assumes some base path found + if ($self->array_is_subset([$adjacent],[@{$goals_ref}])) { + printf("%s\n",join('',@{$string})); + } + pop(@{$string}); + } + } + } # remove startNode entry to facilitate acyclic path determination + pop(@{$dflabel_ref->{$startNode}}); + $lastDFLabel--; + } +}; + +# +# String gen using iterators (still experimental) +# + +sub get_acyclic_sub { + my $self = shift; + my ($start,$nodelist_ref,$dflabel_ref,$string_ref,$accepting_ref,$lastDFLabel) = @_; + my @ret = (); + foreach my $adjacent (keys(%{$nodelist_ref->{$start}})) { + $lastDFLabel++; + if (!exists($dflabel_ref->{$adjacent})) { + $dflabel_ref->{$adjacent} = $lastDFLabel; + foreach my $symbol (@{$nodelist_ref->{$start}{$adjacent}}) { + push(@{$string_ref},$symbol); + my $string_clone = dclone($string_ref); + my $dflabel_clone = dclone($dflabel_ref); + push(@ret,sub { return $self->get_acyclic_sub($adjacent,$nodelist_ref,$dflabel_clone,$string_clone,$accepting_ref,$lastDFLabel); }); + pop @{$string_ref}; + } + } + + } + return {substack=>[@ret], + lastDFLabel=>$lastDFLabel, + string => ($self->array_is_subset([$start],[@{$accepting_ref}]) ? join('',@{$string_ref}) : undef)}; +} +sub init_acyclic_iterator { + my $self = shift; + my %dflabel = (); + my @string = (); + my $lastDFLabel = 0; + my %nodelist = $self->as_node_list(); + my @accepting = $self->get_accepting(); + # initialize + my @substack = (); + my $r = $self->get_acyclic_sub($self->get_starting(),\%nodelist,\%dflabel,\@string,\@accepting,$lastDFLabel); + push(@substack,@{$r->{substack}}); + return sub { + while (1) { + if (!@substack) { + return undef; + } + my $s = pop @substack; + my $r = $s->(); + push(@substack,@{$r->{substack}}); + if ($r->{string}) { + return $r->{string}; + } + } + } +} + +sub new_acyclic_string_generator { + my $self = shift; + return $self->init_acyclic_iterator(); +} + +sub get_deepdft_sub { + my $self = shift; + my ($start,$nodelist_ref,$dflabel_ref,$string_ref,$accepting_ref,$lastDFLabel,$max) = @_; + my @ret = (); + my $c1 = @{$dflabel_ref->{$start}}; + if ($c1 < $max) { + push(@{$dflabel_ref->{$start}},++$lastDFLabel); + foreach my $adjacent (keys(%{$nodelist_ref->{$start}})) { + my $c2 = @{$dflabel_ref->{$adjacent}}; + if ($c2 < $max) { + foreach my $symbol (@{$nodelist_ref->{$start}{$adjacent}}) { + push(@{$string_ref},$symbol); + my $string_clone = dclone($string_ref); + my $dflabel_clone = dclone($dflabel_ref); + push(@ret,sub { return $self->get_deepdft_sub($adjacent,$nodelist_ref,$dflabel_clone,$string_clone,$accepting_ref,$lastDFLabel,$max); }); + pop @{$string_ref}; + } + } + } + } + return {substack=>[@ret], lastDFLabel=>$lastDFLabel, string => ($self->array_is_subset([$start],[@{$accepting_ref}]) ? join('',@{$string_ref}) : undef)}; +} + +sub init_deepdft_iterator { + my $self = shift; + my $MAXLEVEL = shift; + my %dflabel = (); + my @string = (); + my $lastDFLabel = 0; + my %nodelist = $self->as_node_list(); + foreach my $node (keys(%nodelist)) { + $dflabel{$node} = []; # initializes anonymous arrays for all nodes + } + my @accepting = $self->get_accepting(); + # initialize + my @substack = (); + my $r = $self->get_deepdft_sub($self->get_starting(),\%nodelist,\%dflabel,\@string,\@accepting,$lastDFLabel,$MAXLEVEL); + push(@substack,@{$r->{substack}}); + return sub { + while (1) { + if (!@substack) { + return undef; + } + my $s = pop @substack; + my $r = $s->(); + push(@substack,@{$r->{substack}}); + if ($r->{string}) { + return $r->{string}; + } + } + } +} + +sub new_deepdft_string_generator { + my $self = shift; + my $MAXLEVEL = (@_ ? shift : 1); + return $self->init_deepdft_iterator($MAXLEVEL); +} + +1; + +__END__ + +=head1 NAME + +FLAT::DFA - Deterministic finite automata + +=head1 SYNOPSIS + +A FLAT::DFA object is a finite automata whose transitions are labeled +with single characters. Furthermore, each state has exactly one outgoing +transition for each available label/character. + +=head1 USAGE + +In addition to implementing the interface specified in L<FLAT> and L<FLAT::NFA>, +FLAT::DFA objects provide the following DFA-specific methods: + +=over + +=item $dfa-E<gt>unset_starting + +Because a DFA, by definition, must have only ONE starting state, this allows one to unset +the current start state so that a new one may be set. + +=item $dfa-E<gt>trim_sinks + +This method returns a FLAT::DFA (though in theory an NFA) that is lacking a transition for +all symbols from all states. This method eliminates all transitions from all states that lead +to a sink state; it also eliminates the sink state. + +This has no affect on testing if a string is valid using C<FLAT::DFA::is_valid_string>, +discussed below. + +=item $dfa-E<gt>as_min_dfa + +This method minimizes the number of states and transitions in the given DFA. The modifies +the current/calling DFA object. + +=item $dfa-E<gt>is_valid_string($string) + +This method tests if the given string is accepted by the DFA. + +=item $dfa-E<gt>as_node_list + +This method returns a node list in the form of a hash. This node list may be viewed as a +pure digraph, and is lacking in state names and transition symbols. + +=item $dfa-E<gt>as_acyclic_strings + +The method is B<deprecated>, and it is suggested that one not use it. It returns all +valid strings accepted by the DFA by exploring all acyclic paths that go from the start +state and end in an accepting state. The issue with this method is that it finds and +returns all strings at once. The iterator described below is much more ideal for actual +use in an application. + +=item $dfa-E<gt>as_dft_strings($depth) + +The method is B<deprecated>, and it is suggested that one not use it. It returns all +valid strings accepted by the DFA using a depth first traversal. A valid string is formed +when the traversal detects an accepting state, whether it is a terminal node or a node reached +via a back edge. The issue with this method is that it finds and returns all strings at once. +The iterator described below is much more ideal for actual use in an application. + +The argument, C<$depth> specifies how many times the traversal may actually pass through +a previously visited node. It is therefore possible to safely explore DFAs that accept +infinite languages. + +=item $dfa-E<gt>new_acyclic_string_generator + +This allows one to initialize an iterator that returns a valid string on each successive +call of the sub-ref that is returned. It returns all valid strings accepted by the DFA by +exploring all acyclic paths that go from the start state and end in an accepting state. + +Example: + + #!/usr/bin/env perl + use strict; + use FLAT::DFA; + use FLAT::NFA; + use FLAT::PFA; + use FLAT::Regex::WithExtraOps; + + my $PRE = "abc&(def)*"; + my $dfa = FLAT::Regex::WithExtraOps->new($PRE)->as_pfa->as_nfa->as_dfa->as_min_dfa->trim_sinks; + my $next = $dfa->new_acyclic_string_generator; + print "PRE: $PRE\n"; + print "Acyclic:\n"; + while (my $string = $next->()) { + print " $string\n"; + } + +=item $dfa-E<gt>new_deepdft_string_generator($depth) + +This allows one to initialize an iterator that returns a valid string on each successive +call of the sub-ref that is returned. It returns all valid strings accepted by the DFA using a +depth first traversal. A valid string is formed when the traversal detects an accepting state, +whether it is a terminal node or a node reached via a back edge. + +The argument, C<$depth> specifies how many times the traversal may actually pass through +a previously visited node. It is therefore possible to safely explore DFAs that accept +infinite languages. + + #!/usr/bin/env perl + use strict; + use FLAT::DFA; + use FLAT::NFA; + use FLAT::PFA; + use FLAT::Regex::WithExtraOps; + + my $PRE = "abc&(def)*"; + my $dfa = FLAT::Regex::WithExtraOps->new($PRE)->as_pfa->as_nfa->as_dfa->as_min_dfa->trim_sinks; + my $next = $dfa->new_deepdft_string_generator(); + print "Deep DFT (default):\n"; + for (1..10) { + while (my $string = $next->()) { + print " $string\n"; + last; + } + } + + $next = $dfa->new_deepdft_string_generator(5); + print "Deep DFT (5):\n"; + for (1..10) { + while (my $string = $next->()) { + print " $string\n"; + last; + } + } + +=back + +=head1 AUTHORS & ACKNOWLEDGEMENTS + +FLAT is written by Mike Rosulek E<lt>mike at mikero dot comE<gt> and +Brett Estrade E<lt>estradb at gmail dot comE<gt>. + +The initial version (FLAT::Legacy) by Brett Estrade was work towards an +MS thesis at the University of Southern Mississippi. + +Please visit the Wiki at http://www.0x743.com/flat + +=head1 LICENSE + +This module is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. diff --git a/lib/FLAT/FA.pm b/lib/FLAT/FA.pm new file mode 100644 index 0000000..dd77f50 --- /dev/null +++ b/lib/FLAT/FA.pm @@ -0,0 +1,554 @@ +package FLAT::FA; + +use strict; +use base 'FLAT'; +use Carp; + +use FLAT::Transition; + +=head1 NAME + +FLAT::FA - Base class for regular finite automata + +=head1 SYNOPSIS + +A FLAT::FA object is a collection of states and transitions. Each state +may be labeled as starting or accepting. Each transition between states +is labeled with a transition object. + +=head1 USAGE + +FLAT::FA is a superclass that is not intended to be used directly. However, +it does provide the following methods: + +=cut + +sub new { + my $pkg = shift; + bless { + STATES => [], + TRANS => [], + ALPHA => {} + }, $pkg; +} + +sub get_states { + my $self = shift; + return 0 .. ($self->num_states - 1); +} + +sub num_states { + my $self = shift; + return scalar @{ $self->{STATES} }; +} + +sub is_state { + my ($self, $state) = @_; + exists $self->{STATES}->[$state]; +} + +sub _assert_states { + my ($self, @states) = @_; + for (@states) { + croak "'$_' is not a state" if not $self->is_state($_); + } +} +sub _assert_non_states { + my ($self, @states) = @_; + for (@states) { + croak "There is already a state called '$_'" if $self->is_state($_); + } +} + +sub delete_states { + my ($self, @states) = @_; + + $self->_assert_states(@states); + + for my $s ( sort { $b <=> $a } @states ) { + $self->_decr_alphabet($_) + for @{ splice @{ $self->{TRANS} }, $s, 1 }; + + $self->_decr_alphabet( splice @$_, $s, 1 ) + for @{ $self->{TRANS} }; + + splice @{ $self->{STATES} }, $s, 1; + } +} + +sub add_states { + my ($self, $num) = @_; + my $id = $self->num_states; + + for my $s ( $id .. ($id+$num-1) ) { + push @$_, undef for @{ $self->{TRANS} }; + push @{ $self->{TRANS} }, [ (undef) x ($s+1) ]; + push @{ $self->{STATES} }, { + starting => 0, + accepting => 0 + }; + } + + return wantarray ? ($id .. ($id+$num-1)) + : $id+$num-1; +} + +############## + +sub is_starting { + my ($self, $state) = @_; + $self->_assert_states($state); + return $self->{STATES}[$state]{starting}; +} +sub set_starting { + my ($self, @states) = @_; + $self->_assert_states(@states); + $self->{STATES}[$_]{starting} = 1 for @states; +} +sub unset_starting { + my ($self, @states) = @_; + $self->_assert_states(@states); + $self->{STATES}[$_]{starting} = 0 for @states; +} +sub get_starting { + my $self = shift; + return grep { $self->is_starting($_) } $self->get_states; +} + +############## + +sub is_accepting { + my ($self, $state) = @_; + $self->_assert_states($state); + return $self->{STATES}[$state]{accepting}; +} +sub set_accepting { + my ($self, @states) = @_; + $self->_assert_states(@states); + $self->{STATES}[$_]{accepting} = 1 for @states; +} +sub unset_accepting { + my ($self, @states) = @_; + $self->_assert_states(@states); + $self->{STATES}[$_]{accepting} = 0 for @states; +} +sub get_accepting { + my $self = shift; + return grep { $self->is_accepting($_) } $self->get_states; +} + +############### + +sub _decr_alphabet { + my ($self, $t) = @_; + return if not defined $t; + for ($t->alphabet) { + delete $self->{ALPHA}{$_} if not --$self->{ALPHA}{$_}; + } +} +sub _incr_alphabet { + my ($self, $t) = @_; + return if not defined $t; + $self->{ALPHA}{$_}++ for $t->alphabet; +} + +sub set_transition { + my ($self, $state1, $state2, @label) = @_; + $self->remove_transition($state1, $state2); + + @label = grep defined, @label; + return if not @label; + + my $t = $self->{TRANS_CLASS}->new(@label); + $self->_incr_alphabet($t); + + $self->{TRANS}[$state1][$state2] = $t; +} + +sub add_transition { + my ($self, $state1, $state2, @label) = @_; + + @label = grep defined, @label; + return if not @label; + + my $t = $self->get_transition($state1, $state2); + $self->_decr_alphabet($t); + + if (!$t) { + $t = $self->{TRANS}[$state1][$state2] = $self->{TRANS_CLASS}->new; + } + + $t->add(@label); + $self->_incr_alphabet($t); +} + +sub get_transition { + my ($self, $state1, $state2) = @_; + $self->_assert_states($state1, $state2); + + $self->{TRANS}[$state1][$state2]; +} + +sub remove_transition { + my ($self, $state1, $state2) = @_; + + $self->_decr_alphabet( $self->{TRANS}[$state1][$state2] ); + $self->{TRANS}[$state1][$state2] = undef; +} + +# given a state and a symbol, it tells you +# what the next state(s) are; do get successors +# for find the successors for a set of symbols, +# use array refs. For example: +# @NEXT=$self->successors([@nodes],[@symbols]); +sub successors { + my ($self, $state, $symb) = @_; + + my @states = ref $state eq 'ARRAY' ? @$state : ($state); + my @symbs = defined $symb + ? (ref $symb eq 'ARRAY' ? @$symb : ($symb)) + : (); + + $self->_assert_states(@states); + + my %succ; + for my $s (@states) { + $succ{$_}++ + for grep { my $t = $self->{TRANS}[$s][$_]; + defined $t && (@symbs ? $t->does(@symbs) : 1) } $self->get_states; + } + + return keys %succ; +} + +sub predecessors { + my $self = shift; + $self->clone->reverse->successors(@_); +} + +# reverse - no change from NFA +sub reverse { + my $self = $_[0]->clone; + $self->_transpose; + + my @start = $self->get_starting; + my @final = $self->get_accepting; + + $self->unset_accepting( $self->get_states ); + $self->unset_starting( $self->get_states ); + + $self->set_accepting( @start ); + $self->set_starting( @final ); + + $self; +} + +# get an array of all symbols +sub alphabet { + my $self = shift; + grep length, keys %{ $self->{ALPHA} }; +} + +# give an array of symbols, return the symbols that +# are in the alphabet +#sub is_in_alphabet { +# my $self = shift; +# my $ +#} + +############ +sub prune { + my $self = shift; + + my @queue = $self->get_starting; + my %seen = map { $_ => 1 } @queue; + + while (@queue) { + @queue = grep { ! $seen{$_}++ } $self->successors(\@queue); + } + + my @useless = grep { !$seen{$_} } $self->get_states; + $self->delete_states(@useless); + + return @useless; +} + + +############ + +use Storable 'dclone'; +sub clone { + dclone( $_[0] ); +} + +sub _transpose { + my $self = shift; + my $N = $self->num_states - 1; + + $self->{TRANS} = [ + map { + my $row = $_; + [ map { $_->[$row] } @{$self->{TRANS}} ] + } 0 .. $N + ]; +} + +# tests to see if set1 is a subset of set2 +sub array_is_subset { + my $self = shift; + my $set1 = shift; + my $set2 = shift; + my $ok = 1; + my %setcount = (); + foreach ($self->array_unique(@{$set1}),$self->array_unique(@{$set2})) { + $setcount{$_}++; + } + foreach ($self->array_unique(@{$set1})) { + if ($setcount{$_} != 2) { + $ok = 0; + last; + } + } + return $ok; +} + +sub array_unique { + my $self = shift; + my %ret = (); + foreach (@_) { + $ret{$_}++; + } + return keys(%ret); +} + +sub array_complement { + my $self = shift; + my $set1 = shift; + my $set2 = shift; + my @ret = (); + # convert set1 to a hash + my %set1hash = map {$_ => 1} @{$set1}; + # iterate of set2 and test if $set1 + foreach (@{$set2}) { + if (!defined $set1hash{$_}) { + push(@ret,$_); + } + } + ## Now do the same using $set2 + # convert set2 to a hash + my %set2hash = map {$_ => 1} @{$set2}; + # iterate of set1 and test if $set1 + foreach (@{$set1}) { + if (!defined $set2hash{$_}) { + push(@ret,$_); + } + } + # now @ret contains all items in $set1 not in $set 2 and all + # items in $set2 not in $set1 + return @ret; +} + +# returns all items that 2 arrays have in common +sub array_intersect { + my $self = shift; + my $set1 = shift; + my $set2 = shift; + my %setcount = (); + my @ret = (); + foreach ($self->array_unique(@{$set1})) { + $setcount{$_}++; + } + foreach ($self->array_unique(@{$set2})) { + $setcount{$_}++; + push(@ret,$_) if ($setcount{$_} > 1); + } + return @ret; +} + +# given a set of symbols, returns only the valid ones +sub get_valid_symbols { + my $self = shift; + my $symbols = shift; + return $self->array_intersect([$self->alphabet()],[@{$symbols}]) +} + +## add an FA's states & transitions to this FA (as disjoint union) +sub _swallow { + my ($self, $other) = @_; + my $N1 = $self->num_states; + my $N2 = $other->num_states; + + push @$_, (undef) x $N2 + for @{ $self->{TRANS} }; + + push @{ $self->{TRANS} }, [ (undef) x $N1, @{ clone $_ } ] + for @{ $other->{TRANS} }; + + push @{ $self->{STATES} }, @{ clone $other->{STATES} }; + + $self->{ALPHA}{$_} += $other->{ALPHA}{$_} + for keys %{ $other->{ALPHA} }; + + return map { $_ + $N1 } $other->get_states; +} + +1; + +__END__ + + +=head2 Manipulation & Inspection Of States + +=over + +=item $fa-E<gt>get_states + +Returns a list of all the state "names" in $fa. + +=item $fa-E<gt>num_states + +Returns the number of states in $fa. + +=item $fa-E<gt>is_state($state_id) + +Returns a boolean indicating whether $state_id is a recognized state "name." + +=item $fa-E<gt>delete_states(@states) + +Deletes the states given in @states and their corresponding transitions. The +remaining states in the FA may be "renamed" (renumbered)! Return value not +used. + +=item $fa-E<gt>add_states($num) + +Adds $num states to $fa, and returns a list of the new state "names." + +=item $fa-E<gt>get_starting + +=item $fa-E<gt>get_accepting + +Returns a list of all the states which are labeled as starting/accepting, +respectively. + +=item $fa-E<gt>set_accepting(@states) + +=item $fa-E<gt>unset_accepting(@states) + +=item $fa-E<gt>set_starting(@states) + +=item $fa-E<gt>unset_starting(@states) + +Sets/unsets a list of states as being labeled starting/accepting, +respectively. + +=item $fa-E<gt>is_starting($state) + +=item $fa-E<gt>is_accepting($state) + +Returns a boolean indicating whether $state is labeled as starting/accepting, +respectively. + +=item $fa-E<gt>prune + +Deletes the states which are not reachable (via zero or more transitions) +from starting states. Returns a list of the "names" of states that were +deleted. + +=back + +=head2 Manipulation & Inspection Of Transitions + +Each transition between states is a transition object, which knows how +to organize several "labels." Think of this as the mechanism by which +multiple arrows in the state diagram between the same states are collapsed +to a single arrow. This interface is abstracted away into the following +public methods: + +=over + +=item $fa-E<gt>set_transition($state1, $state2, @labels) + +Resets the transition between $state1 and $state2 to a transition +initialized using data @labels. If @labels is omitted or contains +only undefined elements, then the call is equivalent to C<remove_transition>. + +=item $fa-E<gt>add_transition($state1, $state2, @labels) + +Adds @labels to the transition between $state1 and $state2. + +=item $fa-E<gt>get_transition($state1, $state2) + +Returns the transition object stored between $state1 and $state2, or +undef if there is no transition. + +=item $fa-E<gt>remove_transition($state1, $state2) + +Removes the transition object between $state1 and $state2. + +=item $fa-E<gt>successors(\@states) + +=item $fa-E<gt>successors($state) + +=item $fa-E<gt>successors(\@states, $label) + +=item $fa-E<gt>successors($state, $label) + +=item $fa-E<gt>successors(\@states, \@labels) + +=item $fa-E<gt>successors($state, \@labels) + +Given a state/set of states, and one or more labels, returns a list of +the states (without duplicates) reachable from the states via a single +transition having any of the given labels. If no labels are given, returns +the states reachable by any (single) transition. + +Note that this method makes no distinction for epsilon transitions, these +are only special in FLAT::NFA objects. + +=item $fa-E<gt>alphabet + +Returns the list of characters (without duplicates) used among all +transition labels in the automaton. + +=back + +=head2 Conversions To External Formats + +=over + +=item $fa-E<gt>as_graphviz + +Returns a string containing a GraphViz (dot) description of the automaton, +suitable for rendering with your favorite GraphViz layout engine. + +=item $fa-E<gt>as_summary + +Returns a string containing a plaintext description of the automaton, +suitable for debugging purposes. + +=back + +=head2 Miscellaneous + +=over + +=item $fa-E<gt>clone + +Returns an identical copy of $fa. + +=back + +=head1 AUTHORS & ACKNOWLEDGEMENTS + +FLAT is written by Mike Rosulek E<lt>mike at mikero dot comE<gt> and +Brett Estrade E<lt>estradb at gmail dot comE<gt>. + +The initial version (FLAT::Legacy) by Brett Estrade was work towards an +MS thesis at the University of Southern Mississippi. + +Please visit the Wiki at http://www.0x743.com/flat + +=head1 LICENSE + +This module is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. diff --git a/lib/FLAT/NFA.pm b/lib/FLAT/NFA.pm new file mode 100644 index 0000000..344ea76 --- /dev/null +++ b/lib/FLAT/NFA.pm @@ -0,0 +1,509 @@ +package FLAT::NFA; + +use strict; +use base 'FLAT::FA'; + +use FLAT::Transition; + +=head1 NAME + +FLAT::NFA - Nondeterministic finite automata + +=head1 SYNOPSIS + +A FLAT::NFA object is a finite automata whose transitions are labeled +either with characters or the empty string (epsilon). + +=cut + +sub new { + my $pkg = shift; + my $self = $pkg->SUPER::new(@_); + $self->{TRANS_CLASS} = "FLAT::Transition"; + return $self; +} + +sub singleton { + my ($class, $char) = @_; + my $nfa = $class->new; + + if (not defined $char) { + $nfa->add_states(1); + $nfa->set_starting(0); + } elsif ($char eq "") { + $nfa->add_states(1); + $nfa->set_starting(0); + $nfa->set_accepting(0); + } else { + $nfa->add_states(2); + $nfa->set_starting(0); + $nfa->set_accepting(1); + $nfa->set_transition(0, 1, $char); + } + return $nfa; +} + +sub as_nfa { $_[0]->clone } + +sub union { + my @nfas = map { $_->as_nfa } @_; + my $result = $nfas[0]->clone; + $result->_swallow($_) for @nfas[1 .. $#nfas]; + $result; +} + +sub concat { + my @nfas = map { $_->as_nfa } @_; + + my $result = $nfas[0]->clone; + my @newstate = ([ $result->get_states ]); + my @start = $result->get_starting; + + for (1 .. $#nfas) { + push @newstate, [ $result->_swallow( $nfas[$_] ) ]; + } + + $result->unset_accepting($result->get_states); + $result->unset_starting($result->get_states); + $result->set_starting(@start); + + for my $nfa_id (1 .. $#nfas) { + for my $s1 ($nfas[$nfa_id-1]->get_accepting) { + for my $s2 ($nfas[$nfa_id]->get_starting) { + $result->set_transition( + $newstate[$nfa_id-1][$s1], + $newstate[$nfa_id][$s2], "" ); + }} + } + + $result->set_accepting( + @{$newstate[-1]}[ $nfas[-1]->get_accepting ] ); + + $result; +} + +sub kleene { + my $result = $_[0]->clone; + + my ($newstart, $newfinal) = $result->add_states(2); + + $result->set_transition($newstart, $_, "") + for $result->get_starting; + $result->unset_starting( $result->get_starting ); + $result->set_starting($newstart); + + $result->set_transition($_, $newfinal, "") + for $result->get_accepting; + $result->unset_accepting( $result->get_accepting ); + $result->set_accepting($newfinal); + + $result->set_transition($newstart, $newfinal, ""); + $result->set_transition($newfinal, $newstart, ""); + + $result; +} + +sub reverse { + my $self = $_[0]->clone; + $self->_transpose; + + my @start = $self->get_starting; + my @final = $self->get_accepting; + + $self->unset_accepting( $self->get_states ); + $self->unset_starting( $self->get_states ); + + $self->set_accepting( @start ); + $self->set_starting( @final ); + + $self; +} + +########### + +sub is_empty { + my $self = shift; + + my @queue = $self->get_starting; + my %seen = map { $_ => 1 } @queue; + + while (@queue) { + return 0 if grep { $self->is_accepting($_) } @queue; + @queue = grep { !$seen{$_}++ } $self->successors(\@queue); + } + return 1; +} + +sub is_finite { + my $self = shift; + + my @alphabet = $self->alphabet; + return 1 if @alphabet == 0; + + my @queue = $self->get_starting; + my %seen = map { $_ => 1 } @queue; + + while (@queue) { + @queue = grep { !$seen{$_}++ } $self->successors(\@queue); + } + + for my $s ( grep { $self->is_accepting($_) } keys %seen ) { + @queue = $self->epsilon_closure($s); + %seen = map { $_ => 1 } @queue; + + while (@queue) { + my @next = $self->epsilon_closure( + $self->successors(\@queue, \@alphabet) ); + + return 0 if grep { $s eq $_ } @next; + @queue = grep { !$seen{$_}++ } @next; + } + } + return 1; +} + +sub epsilon_closure { + my ($self, @states) = @_; + my %seen = map { $_ => 1 } @states; + my @queue = @states; + + while (@queue) { + @queue = grep { ! $seen{$_}++ } $self->successors( \@queue, "" ); + } + + keys %seen; +} + + +sub contains { + my ($self, $string) = @_; + + my @active = $self->epsilon_closure( $self->get_starting ); + for my $char (split //, $string) { + return 0 if ! @active; + @active = $self->epsilon_closure( $self->successors(\@active, $char) ); + } + return !! grep { $self->is_accepting($_) } @active; +} + +sub trace { + my ($self, $string) = @_; + + my @trace = ([ $self->epsilon_closure( $self->get_starting ) ]); + + for my $char (split //, $string) { + push @trace, + [ $self->epsilon_closure( $self->successors($trace[-1], $char) ) ]; + } + return @trace; +} +############ + +sub _extend_alphabet { + my ($self, @alpha) = @_; + + my %alpha = map { $_ => 1 } @alpha; + delete $alpha{$_} for $self->alphabet; + + return if not keys %alpha; + + my $trash = $self->add_states(1); + for my $state ($self->get_states) { + next if $state eq $trash; + for my $char (keys %alpha) { + $self->add_transition($state, $trash, $char); + } + } + $self->add_transition($trash, $trash, $self->alphabet); +} + +######## transformations + +# subset construction +sub as_dfa { + my $self = shift; + + my $result = FLAT::DFA->new; + my %subset; + + my %final = map { $_ => 1 } $self->get_accepting; + my @start = sort { $a <=> $b } $self->epsilon_closure( $self->get_starting ); + + my $start = $subset{ _SET_ID(@start) } = $result->add_states(1); + $result->set_starting($start); + + $result->set_accepting( $start ) + if grep $_, @final{@start}; + + my @queue = (\@start); + while (@queue) { + my @states = @{ shift @queue }; + my $S = $subset{ _SET_ID(@states) }; + + for my $symb ($self->alphabet) { + my @to = $self->epsilon_closure( + $self->successors(\@states, $symb) ); + + if ( not exists $subset{_SET_ID(@to)} ) { + push @queue, \@to; + my $T = $subset{_SET_ID(@to)} = $result->add_states(1); + $result->set_accepting($T) + if grep $_, @final{@to}; + } + + $result->add_transition($S, $subset{ _SET_ID(@to) }, $symb); + } + } + + $result; +} + +############ Formatted output + +# Format that Dr. Sukhamay KUNDU likes to use in his assignments :) +# This format is just a undirected graph - so transition and state info is lost + +sub as_undirected { + my $self = shift; + my @symbols = $self->alphabet(); + my @states = $self->get_states(); + my %edges = (); + foreach (@states) { + my $s = $_; + foreach (@symbols) { + my $a = $_; + # foreach state, get all nodes connected to it; ignore symbols and + # treat transitions simply as directed + push(@{$edges{$s}},$self->successors($s,$a)); + foreach ($self->successors($s,$a)) { + push(@{$edges{$_}},$s); + } + } + } + my @lines = (($#states+1)); + foreach (sort{$a <=> $b;}(keys(%edges))) { #<-- iterate over numerically sorted list of keys + @{$edges{$_}} = sort {$a <=> $b;} $self->array_unique(@{$edges{$_}}); #<- make items unique and sort numerically + push(@lines,sprintf("%s(%s):%s",$_,($#{$edges{$_}}+1),join(' ',@{$edges{$_}}))); + } + return join("\n",@lines); + } + +# Format that Dr. Sukhamay KUNDU likes to use in his assignments :) +# This format is just a directed graph - so transition and state info is lost + +sub as_digraph { + my $self = shift; + my @symbols = $self->alphabet(); + my @states = $self->get_states(); + my @lines = (); + foreach (@states) { + my $s = $_; + my @edges = (); + foreach (@symbols) { + my $a = $_; + # foreach state, get all nodes connected to it; ignore symbols and + # treat transitions simply as directed + push(@edges,$self->successors($s,$a)); + } + @edges = sort {$a <=> $b;} $self->array_unique(@edges); #<- make items unique and sort numerically + push(@lines,sprintf("%s(%s): %s",$s,($#edges+1),join(' ',@edges))); + } + return sprintf("%s\n%s",($#states+1),join("\n",@lines)); +} + + +# Graph Description Language, aiSee, etc +sub as_gdl { + my $self = shift; + + my @states = map { + sprintf qq{node: { title:"%s" shape:circle borderstyle: %s}\n}, + $_, + ($self->is_accepting($_) ? "double bordercolor: red" : "solid") + } $self->get_states; + + my @trans; + for my $s1 ($self->get_states) { + for my $s2 ($self->get_states) { + my $t = $self->get_transition($s1, $s2); + + if (defined $t) { + push @trans, sprintf qq[edge: { source: "%s" target: "%s" label: "%s" arrowstyle: line }\n], + $s1, $s2, $t->as_string; + } + }} + + return sprintf "graph: {\ndisplay_edge_labels: yes\n\n%s\n%s}\n", + join("", @states), + join("", @trans); +} + +# Graphviz: dot, etc +## digraph, directed +sub as_graphviz { + my $self = shift; + + my @states = map { + sprintf qq{%s [label="%s",shape=%s]\n}, + $_, + ($self->is_starting($_) ? "start ($_)" : "$_"), + ($self->is_accepting($_) ? "doublecircle" : "circle") + } $self->get_states; + + my @trans; + for my $s1 ($self->get_states) { + for my $s2 ($self->get_states) { + my $t = $self->get_transition($s1, $s2); + + if (defined $t) { + push @trans, sprintf qq[%s -> %s [label="%s"]\n], + $s1, $s2, $t->as_string; + } + }} + + return sprintf "digraph G {\ngraph [rankdir=LR]\n\n%s\n%s}\n", + join("", @states), + join("", @trans); +} +## undirected +sub as_undirected_graphviz { + my $self = shift; + + my @states = map { + sprintf qq{%s [label="%s",shape=%s]\n}, + $_, + ("$_"), + ("circle") + } $self->get_states; + + my @trans; + for my $s1 ($self->get_states) { + for my $s2 ($self->get_states) { + my $t = $self->get_transition($s1, $s2); + + if (defined $t) { + push @trans, sprintf qq[%s -- %s\n], + $s1, $s2, $t->as_string; + } + }} + + return sprintf "graph G {\ngraph [rankdir=LR]\n\n%s\n%s}\n", + join("", @states), + join("", @trans); +} + +sub _SET_ID { return join "\0", sort { $a <=> $b } @_; } + +sub as_summary { + my $self = shift; + my $out = ''; + $out .= sprintf ("States : "); + my @start; + my @final; + foreach ($self->get_states()) { + $out .= sprintf "'$_' "; + if ($self->is_starting($_)) { + push(@start,$_); + } + if ($self->is_accepting($_)) { + push(@final,$_); + } + } + $out .= sprintf ("\nStart State : '%s'\n",join('',@start)); + $out .= sprintf ("Final State(s) : "); + foreach (@final) { + $out .= sprintf "'$_' "; + } + $out .= sprintf ("\nAlphabet : "); + foreach ($self->alphabet()) { + $out .= sprintf "'$_' "; + } + $out .= sprintf ("\nTransitions :\n"); + my @trans; + for my $s1 ($self->get_states) { + for my $s2 ($self->get_states) { + my $t = $self->get_transition($s1, $s2); + if (defined $t) { + push @trans, sprintf qq[%s -> %s on "%s"\n], + $s1, $s2, $t->as_string; + } + }} + $out .= join('',@trans); + return $out; +} + +1; + +__END__ + +=head1 USAGE + +In addition to implementing the interface specified in L<FLAT>, FLAT::NFA +objects provide the following NFA-specific methods: + +=over + +=item $nfa-E<gt>epsilon_closure(@states) + +Returns the set of states (without duplicates) which are reachable from +@states via zero or more epsilon-labeled transitions. + +=item $nfa-E<gt>trace($string) + +Returns a list of N+1 arrayrefs, where N is the length of $string. The +I-th arrayref contains the states which are reachable from the starting +state(s) of $nfa after reading I characters of $string. Correctly accounts +for epsilon transitions. + +=item $nfa-E<gt>as_undirected + +Outputs FA in a format that may be easily read into an external program as +a description of an undirected graph. + +=item $nfa-E<gt>as_digraph + +Outputs FA in a format that may be easily read into an external program as +a description of an directed graph. + +=item $nfa-E<gt>as_gdl + +Outputs FA in Graph Description Language (GDL), including directed transitions +with symbols and state names labeled. + +=item $nfa-E<gt>as_graphviz + +Outputs FA in Graphviz format, including directed transitions with symbols and +and state names labeled. This output may be directly piped into any of the +Graphviz layout programs, and in turn one may output an image using a single +commandline instruction. C<fash> uses this function to implement its "nfa2gv" +command: + + fash nfa2gv "a*b" | dot -Tpng > nfa.png + +=item $nfa-E<gt>as_undirected_graphviz + +Outputs FA in Graphviz format, with out the directed transitions or labels. +The output is suitable for any of the Graphvize layout programs, as discussed +above. + +=item $nfa-E<gt>as_summary + +Outputs a summary of the FA, including its states, symbols, and transition matrix. +It is useful for manually validating what the FA looks like. + +=back + +=head1 AUTHORS & ACKNOWLEDGEMENTS + +FLAT is written by Mike Rosulek E<lt>mike at mikero dot comE<gt> and +Brett Estrade E<lt>estradb at gmail dot comE<gt>. + +The initial version (FLAT::Legacy) by Brett Estrade was work towards an +MS thesis at the University of Southern Mississippi. + +Please visit the Wiki at http://www.0x743.com/flat + +=head1 LICENSE + +This module is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. diff --git a/lib/FLAT/PFA.pm b/lib/FLAT/PFA.pm new file mode 100644 index 0000000..5557525 --- /dev/null +++ b/lib/FLAT/PFA.pm @@ -0,0 +1,293 @@ +package FLAT::PFA; +use strict; +use base 'FLAT::NFA'; +use Carp; + +use FLAT::Transition; + +use constant LAMBDA => '#lambda'; + +# Note: in a PFA, states are made up of active nodes. In this implementation, we have +# decided to retain the functionality of the state functions in FA.pm, although the entities +# being manipulated are technically nodes, not states. States are only explicitly tracked +# once the PFA is serialized into an NFA. Therefore, the TRANS member of the PFA object is +# the nodal transition function, gamma. The state transition function, delta, is not used +# in anyway, but is derived out of the PFA->NFA conversion process. + + +# The new way of doing things eliminated from PFA.pm of FLAT::Legacy is the +# need to explicitly track: start nodes, final nodes, symbols, and lambda & epsilon symbols, + +sub new { + my $pkg = shift; + my $self = $pkg->SUPER::new(@_); # <-- SUPER is FLAT::NFA + return $self; +} + +# Singleton is no different than the NFA singleton +sub singleton { + my ($class, $char) = @_; + my $pfa = $class->new; + if (not defined $char) { + $pfa->add_states(1); + $pfa->set_starting(0); + } elsif ($char eq "") { + $pfa->add_states(1); + $pfa->set_starting(0); + $pfa->set_accepting(0); + } else { + $pfa->add_states(2); + $pfa->set_starting(0); + $pfa->set_accepting(1); + $pfa->set_transition(0, 1, $char); + } + return $pfa; +} + +# attack of the clones +sub as_pfa { $_[0]->clone() } + +sub set_starting { + my ($self, @states) = @_; + $self->_assert_states(@states); + $self->{STATES}[$_]{starting} = 1 for @states; +} + +# Creates a single start state with epsilon transitions from +# the former start states; +# Creates a single final state with epsilon transitions from +# the former accepting states +sub pinch { + my $self = shift; + my $symbol = shift; + my @starting = $self->get_starting; + if (@starting > 1) { + my $newstart = $self->add_states(1); + map {$self->add_transition($newstart,$_,$symbol)} @starting; + $self->unset_starting(@starting); + $self->set_starting($newstart); + } + # + my @accepting = $self->get_accepting; + if (@accepting > 1) { + my $newfinal = $self->add_states(1); + map {$self->add_transition($_,$newfinal,$symbol)} @accepting; + $self->unset_accepting(@accepting); + $self->set_accepting($newfinal); + } + return; +} + +# Implement the joining of two PFAs with lambda transitions +# Note: using epsilon pinches for simplicity +sub shuffle { + my @pfas = map { $_->as_pfa } @_; + my $result = $pfas[0]->clone; + $result->_swallow($_) for @pfas[1 .. $#pfas]; + $result->pinch(LAMBDA); + $result; +} + +############## + +sub is_tied { + my ($self, $state) = @_; + $self->_assert_states($state); + return $self->{STATES}[$state]{tied}; +} + +sub set_tied { + my ($self, @states) = @_; + $self->_assert_states(@states); + $self->{STATES}[$_]{tied} = 1 for @states; +} + +sub unset_tied { + my ($self, @states) = @_; + $self->_assert_states(@states); + $self->{STATES}[$_]{tied} = 0 for @states; +} + +sub get_tied { + my $self = shift; + return grep { $self->is_tied($_) } $self->get_states; +} + +############## + +# joins two PFAs in a union (or) - no change from NFA +sub union { + my @pfas = map { $_->as_pfa } @_; + my $result = $pfas[0]->clone; + $result->_swallow($_) for @pfas[1 .. $#pfas]; + $result->pinch(''); + $result; +} + +# joins two PFAs via concatenation - no change from NFA +sub concat { + my @pfas = map { $_->as_pfa } @_; + + my $result = $pfas[0]->clone; + my @newstate = ([ $result->get_states ]); + my @start = $result->get_starting; + + for (1 .. $#pfas) { + push @newstate, [ $result->_swallow( $pfas[$_] ) ]; + } + + $result->unset_accepting($result->get_states); + $result->unset_starting($result->get_states); + $result->set_starting(@start); + + for my $pfa_id (1 .. $#pfas) { + for my $s1 ($pfas[$pfa_id-1]->get_accepting) { + for my $s2 ($pfas[$pfa_id]->get_starting) { + $result->set_transition( + $newstate[$pfa_id-1][$s1], + $newstate[$pfa_id][$s2], "" ); + }} + } + + $result->set_accepting( + @{$newstate[-1]}[ $pfas[-1]->get_accepting ] ); + + $result; +} + +# forms closure around a the given PFA - no change from NFA +sub kleene { + my $result = $_[0]->clone; + + my ($newstart, $newfinal) = $result->add_states(2); + + $result->set_transition($newstart, $_, "") + for $result->get_starting; + $result->unset_starting( $result->get_starting ); + $result->set_starting($newstart); + + $result->set_transition($_, $newfinal, "") + for $result->get_accepting; + $result->unset_accepting( $result->get_accepting ); + $result->set_accepting($newfinal); + + $result->set_transition($newstart, $newfinal, ""); + $result->set_transition($newfinal, $newstart, ""); + + $result; +} + +sub as_nfa { + my $self = shift; + my $result = FLAT::NFA->new(); + # Dstates is initially populated with the start state, which + # is exactly the set of all nodes marked as a starting node + my @Dstates = [sort($self->get_starting())]; # I suppose all start states are considered 'tied' + my %DONE = (); # |- what about all accepting states? I think so... + # the main while loop that ends when @Dstates becomes exhausted + my %NEW = (); + while (@Dstates) { + my $current = pop(@Dstates); + my $currentid = join(',',@{$current}); + $DONE{$currentid}++; # mark done + foreach my $symbol ($self->alphabet(),'') { # Sigma UNION epsilon + if (LAMBDA eq $symbol) { + my @NEXT = (); + my @tmp = $self->successors([@{$current}],$symbol); + if (@tmp) { + my @pred = $self->predecessors([@tmp],LAMBDA); + if ($self->array_is_subset([@pred],[@{$current}])) { + push(@NEXT,@tmp,$self->array_complement([@{$current}],[@pred])); + @NEXT = sort($self->array_unique(@NEXT)); + my $nextid = join(',',@NEXT); + push(@Dstates,[@NEXT]) if (!exists($DONE{$nextid})); + # make new states if none exist and track + if (!exists($NEW{$currentid})) {$NEW{$currentid} = $result->add_states(1)}; + if (!exists($NEW{$nextid})) {$NEW{$nextid} = $result->add_states(1) }; + $result->add_transition($NEW{$currentid},$NEW{$nextid},''); + } + } + } else { + foreach my $node (@{$current}) { + my @tmp = $self->successors([$node],$symbol); + foreach my $new (@tmp) { + my @NEXT = (); + push(@NEXT,$new,$self->array_complement([@{$current}],[$node])); + @NEXT = sort($self->array_unique(@NEXT)); + my $nextid = join(',',@NEXT); + push(@Dstates,[@NEXT]) if (!exists($DONE{$nextid})); + # make new states if none exist and track + if (!exists($NEW{$currentid})) {$NEW{$currentid} = $result->add_states(1)}; + if (!exists($NEW{$nextid})) {$NEW{$nextid} = $result->add_states(1) }; + $result->add_transition($NEW{$currentid},$NEW{$nextid},$symbol); + } + } + } + } + } + $result->set_starting($NEW{join(",",sort $self->get_starting())}); + $result->set_accepting($NEW{join(",",sort $self->get_accepting())}); + return $result; + } + +1; + +__END__ + +=head1 NAME + +FLAT::PFA - Parallel finite automata + +=head1 SYNOPSIS + +A FLAT::PFA object is a finite automata whose transitions are labeled either +with characters, the empty string (epsilon), or a concurrent line of execution +(lambda). It essentially models two FSA in a non-deterministic way such that +a string is valid it puts the FSA of the shuffled languages both into a final, +or accepting, state. A PFA is an NFA, and as such exactly describes a regular +language. + +A PFA contains nodes and states. A state is made up of whatever nodes happen +to be active. There are two transition functions, nodal transitions and state +transitions. When a PFA is converted into a NFA, there is no longer a need for +nodes or nodal transitions, so they go are eliminated. PFA model state spaces +much more compactly than NFA, and an N state PFA may represent 2**N non-deterministic +states. This also means that a PFA may represent up to 2^(2^N) deterministic states. + +=head1 USAGE + +(not implemented yet) + +In addition to implementing the interface specified in L<FLAT> and L<FLAT::NFA>, +FLAT::PFA objects provide the following PFA-specific methods: + +=over + +=item $pfa-E<gt>shuffle + +Shuffle construct for building a PFA out of a PRE (i.e., a regular expression with +the shuffle operator) + +=item $pfa-E<gt>as_nfa + +Converts a PFA to an NFA by enumerating all states; similar to the Subset Construction +Algorithm, it does not implement e-closure. Instead it treats epsilon transitions +normally, and joins any states resulting from a lambda (concurrent) transition +using an epsilon transition. + +=back + +=head1 AUTHORS & ACKNOWLEDGEMENTS + +FLAT is written by Mike Rosulek E<lt>mike at mikero dot comE<gt> and +Brett Estrade E<lt>estradb at gmail dot comE<gt>. + +The initial version (FLAT::Legacy) by Brett Estrade was work towards an +MS thesis at the University of Southern Mississippi. + +Please visit the Wiki at http://www.0x743.com/flat + +=head1 LICENSE + +This module is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. diff --git a/lib/FLAT/Regex.pm b/lib/FLAT/Regex.pm new file mode 100644 index 0000000..2c5c243 --- /dev/null +++ b/lib/FLAT/Regex.pm @@ -0,0 +1,194 @@ +package FLAT::Regex; +use base 'FLAT'; +use strict; +use Carp; + +use FLAT::Regex::Parser; +use FLAT::Regex::Op; + +my $PARSER = FLAT::Regex::Parser->new(qw[ alt concat star ]); +#### TODO: error checking in the parse + +sub _parser { $PARSER } + +sub new { + my ($pkg, $string) = @_; + my $result = $pkg->_parser->parse($string) + or croak qq[``$string'' is not a valid regular expression]; + + $pkg->_from_op( $result ); +} + +sub _from_op { + my ($proto, $op) = @_; + $proto = ref $proto || $proto; ## I really do want this + + bless [ $op ], $proto; +} + +sub op { + $_[0][0]; +} + +use overload '""' => 'as_string'; +sub as_string { + $_[0]->op->as_string(0); +} + +sub as_perl_regex { + my ($self, %opts) = @_; + + my $fmt = $opts{anchored} ? '(?:\A%s\z)' : '(?:%s)'; + return sprintf $fmt, $self->op->as_perl_regex(0); +} + +sub contains { + my ($self, $string) = @_; + $string =~ $self->as_perl_regex(anchored => 1); +} + +sub as_nfa { + $_[0]->op->as_nfa; +} + +sub as_pfa { + $_[0]->op->as_pfa; +} + +#### regular language standard interface implementation: +#### TODO: parameter checking? + +sub as_regex { + $_[0]; +} + +sub union { + my $self = $_[0]; + my $op = FLAT::Regex::op::alt->new( map { $_->as_regex->op } @_ ); + $self->_from_op($op); +} + +sub intersect { + my @dfas = map { $_->as_dfa } @_; + my $self = shift @dfas; + $self->intersect(@dfas)->as_regex; +} + +sub complement { + my $self = shift; + $self->as_dfa->complement->as_regex; +} + +sub concat { + my $self = $_[0]; + my $op = FLAT::Regex::op::concat->new( map { $_->as_regex->op } @_ ); + $self->_from_op($op); +} + +sub kleene { + my $self = shift; + my $op = FLAT::Regex::op::star->new( $self->op ); + $self->_from_op($op); +} + +sub reverse { + my $self = shift; + my $op = $self->op->reverse; + $self->_from_op($op); +} + +sub is_empty { + $_[0]->op->is_empty; +} + +sub is_finite { + $_[0]->op->is_finite; +} + +1; + +__END__ + +=head1 NAME + +FLAT::Regex - Regular expressions + +=head1 SYNOPSIS + +A FLAT::Regex object is a regular expression. + +=head1 USAGE + +In addition to implementing the interface specified in L<FLAT>, FLAT::Regex +objects provide the following regex-specific methods: + +=over + +=item FLAT::Regex-E<gt>new($string) + +Returns a regex object representing the expression given in $string. C<|> +and C<+> can both be used to denote alternation. C<*> denotes Kleene star, and +parentheses can be used for grouping. No other features or shortcut notation +is currently supported (character classes, {n,m} repetition, etc). + +Whitespaces is ignored. To specify a literal space, use C<[ ]>. This syntax +can also be used to specify atomic "characters" longer than a single +character. For example, the expression: + + [foo]abc[bar]* + +is treated as a regular expression over the symbols "a", "b", "c", "foo", +and "bar". In particular, this means that when the regular expression is +reversed, "foo" and "bar" remain the same (i.e, they do not become "oof" and +"rab"). + +The empty regular expression (epsilon) is written as C<[]>, and the null +regular expression (sometimes called phi) is specified with the C<#> +character. To specify a literal hash-character, use C<[#]>. Including +literal square bracket characters is currently not supported. + +The expression "" (or any string containing only whitespace) is not a valid +FLAT regex expression. Either C<[]> or C<#> are probably what was intended. + +=item $regex-E<gt>as_string + +Returns the string representation of the regex, in the same format as above. +It is NOT necessarily true that + + FLAT::Regex->new($string)->as_string + +is identical to $string, especially if $string contains whitespace or +redundant parentheses. + +=item $regex-E<gt>as_perl_regex + +=item $regex-E<gt>as_perl_regex(anchored => $bool); + +Returns an equivalent Perl regular expression. If the "anchored" option +is set to a true value, the regular expression will be anchored with +C<\A> and C<\z>. The default behavior is to omit the anchors. + +The Perl regex will not contain capturing parentheses. "Extended" characters +that are written as "[char]" in FLAT regexes will be written without the +square brackets in the corresponding Perl regex. So the following: + + FLAT::Regex->new("[foo][bar]*")->as_perl_regex + +will be equal to "(?:foo(?:bar)*)". + +=back + +=head1 AUTHORS & ACKNOWLEDGEMENTS + +FLAT is written by Mike Rosulek E<lt>mike at mikero dot comE<gt> and +Brett Estrade E<lt>estradb at gmail dot comE<gt>. + +The initial version (FLAT::Legacy) by Brett Estrade was work towards an +MS thesis at the University of Southern Mississippi. + +Please visit the Wiki at http://www.0x743.com/flat + +=head1 LICENSE + +This module is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. diff --git a/lib/FLAT/Regex/Op.pm b/lib/FLAT/Regex/Op.pm new file mode 100644 index 0000000..76e796c --- /dev/null +++ b/lib/FLAT/Regex/Op.pm @@ -0,0 +1,282 @@ +package FLAT::Regex::Op; +use strict; + +sub new { + my $pkg = shift; + ## flatten alike operations, i.e, "a+(b+c)" into "a+b+c" + my @flat = map { UNIVERSAL::isa($_, $pkg) ? $_->members : $_ } @_; + + bless \@flat, $pkg; +} + +sub members { + my $self = shift; + wantarray ? @$self[0 .. $#$self] : $self->[0]; +} + + +################################# +#### regex operators / components + +package FLAT::Regex::Op::atomic; +use base 'FLAT::Regex::Op'; + +sub as_string { + my $t = $_[0]->members; + + return "#" if not defined $t; + return $t =~ /^\w$/ + ? $t + : "[$t]"; +} + +sub as_perl_regex { + my $r = $_[0]->members; + + return "(?!)" if not defined $r; + + $r = quotemeta $r; + return $r =~ /^\w$/ ? $r : "(?:$r)"; +} + +sub as_nfa { + FLAT::NFA->singleton( $_[0]->members ); +} + +sub as_pfa { + FLAT::PFA->singleton( $_[0]->members ); +} + +sub from_parse { + my ($pkg, @item) = @_; + my $i = $item[1]; + + return $pkg->new("") if $i eq "[]"; + return $pkg->new(undef) if $i eq "#"; + + $i =~ s/^\[|\]$//g; + + return $pkg->new($i); +} + +sub reverse { + $_[0]; +} + +sub is_empty { + not defined $_[0]->members; +} + +sub has_nonempty_string { + my $self = shift; + defined $self->members and length $self->members; +} + +sub is_finite { + 1 +} + +############################## +package FLAT::Regex::Op::star; +use base 'FLAT::Regex::Op'; + +sub parse_spec { "%s '*'" } +sub precedence { 30 } + +sub as_string { + my ($self, $prec) = @_; + my $result = $self->members->as_string($self->precedence) . "*"; + return $prec > $self->precedence ? "($result)" : $result; +} + +sub as_perl_regex { + my ($self, $prec) = @_; + my $result = $self->members->as_perl_regex($self->precedence) . "*"; + return $prec > $self->precedence ? "(?:$result)" : $result; +} + +sub as_nfa { + my $self = shift; + $self->members->as_nfa->kleene; +} + +sub as_pfa { + my $self = shift; + $self->members->as_pfa->kleene; +} + +sub from_parse { + my ($pkg, @item) = @_; + $pkg->new( $item[1] ); +} + +sub reverse { + my $self = shift; + my $op = $self->members->reverse; + __PACKAGE__->new($op); +} + +sub is_empty { + 0 +} + +sub has_nonempty_string { + $_[0]->members->has_nonempty_string; +} + +sub is_finite { + ! $_[0]->members->has_nonempty_string; +} + + +################################ +package FLAT::Regex::Op::concat; +use base 'FLAT::Regex::Op'; + +sub parse_spec { "%s(2..)"; } +sub precedence { 20 } + +sub as_string { + my ($self, $prec) = @_; + my $result = join "", + map { $_->as_string($self->precedence) } + $self->members; + return $prec > $self->precedence ? "($result)" : $result; +} + +sub as_perl_regex { + my ($self, $prec) = @_; + my $result = join "", + map { $_->as_perl_regex($self->precedence) } + $self->members; + return $prec > $self->precedence ? "(?:$result)" : $result; +} + +sub as_nfa { + my $self = shift; + my @parts = map { $_->as_nfa } $self->members; + $parts[0]->concat( @parts[1..$#parts] ); +} + +sub as_pfa { + my $self = shift; + my @parts = map { $_->as_pfa } $self->members; + $parts[0]->concat( @parts[1..$#parts] ); +} + +sub from_parse { + my ($pkg, @item) = @_; + $pkg->new( @{ $item[1] } ); +} + +## note: "reverse" conflicts with perl builtin +sub reverse { + my $self = shift; + my @ops = CORE::reverse map { $_->reverse } $self->members; + __PACKAGE__->new(@ops); +} + +sub is_empty { + my $self = shift; + my @members = $self->members; + for (@members) { + return 1 if $_->is_empty; + } + return 0; +} + +sub has_nonempty_string { + my $self = shift; + return 0 if $self->is_empty; + + my @members = $self->members; + for (@members) { + return 1 if $_->has_nonempty_string; + } + return 0; +} + +sub is_finite { + my $self = shift; + return 1 if $self->is_empty; + + my @members = $self->members; + for (@members) { + return 0 if not $_->is_finite; + } + return 1; +} + +############################# +package FLAT::Regex::Op::alt; +use base 'FLAT::Regex::Op'; + +sub parse_spec { "%s(2.. /[+|]/)" } +sub precedence { 10 } + +sub as_string { + my ($self, $prec) = @_; + my $result = join "+", + map { $_->as_string($self->precedence) } + $self->members; + return $prec > $self->precedence ? "($result)" : $result; +} + +sub as_perl_regex { + my ($self, $prec) = @_; + my $result = join "|", + map { $_->as_perl_regex($self->precedence) } + $self->members; + return $prec > $self->precedence ? "(?:$result)" : $result; +} + +sub as_nfa { + my $self = shift; + my @parts = map { $_->as_nfa } $self->members; + $parts[0]->union( @parts[1..$#parts] ); +} + +sub as_pfa { + my $self = shift; + my @parts = map { $_->as_pfa } $self->members; + $parts[0]->union( @parts[1..$#parts] ); +} + +sub from_parse { + my ($pkg, @item) = @_; + $pkg->new( @{ $item[1] } ); +} + +sub reverse { + my $self = shift; + my @ops = map { $_->reverse } $self->members; + __PACKAGE__->new(@ops); +} + +sub is_empty { + my $self = shift; + my @members = $self->members; + for (@members) { + return 0 if not $_->is_empty; + } + return 1; +} + +sub has_nonempty_string { + my $self = shift; + my @members = $self->members; + for (@members) { + return 1 if $_->has_nonempty_string; + } + return 0; +} + +sub is_finite { + my $self = shift; + my @members = $self->members; + for (@members) { + return 0 if not $_->is_finite; + } + return 1; +} +1; diff --git a/lib/FLAT/Regex/Parser.pm b/lib/FLAT/Regex/Parser.pm new file mode 100644 index 0000000..deb73f1 --- /dev/null +++ b/lib/FLAT/Regex/Parser.pm @@ -0,0 +1,82 @@ +package FLAT::Regex::Parser; +use strict; + +#### Is this one level of abstraction too far? Parser generator generators.. + +#### TODO: try YAPP, since recursive descent is SLOOOW +use Parse::RecDescent; +use FLAT::Regex::Op; + +use vars '$CHAR'; +$CHAR = qr{ [A-Za-z0-9_\$\#] | \[[^\]]*\] }x; + +sub new { + my $pkg = shift; + my @ops = sort { $a->{prec} <=> $b->{prec} } + map {{ + pkg => "FLAT::Regex::Op::$_", + prec => "FLAT::Regex::Op::$_"->precedence, + spec => "FLAT::Regex::Op::$_"->parse_spec, + short => $_ + }} @_; + + my $lowest = shift @ops; + my $grammar = qq! + parse: + $lowest->{short} /^\\Z/ { \$item[1] } + !; + + my $prev = $lowest; + for (@ops) { + my $spec = sprintf $prev->{spec}, $_->{short}; + + $grammar .= qq! + $prev->{short}: + $spec { $prev->{pkg}\->from_parse(\@item) } + | $_->{short} { \$item[1] } + !; + + $prev = $_; + } + + my $spec = sprintf $prev->{spec}, "atomic"; + $grammar .= qq! + $prev->{short}: + $spec { $prev->{pkg}\->from_parse(\@item) } + | atomic { \$item[1] } + + atomic: + "(" $lowest->{short} ")" { \$item[2] } + | /\$FLAT::Regex::Parser::CHAR/ + { FLAT::Regex::Op::atomic->from_parse(\@item) } + !; + + Parse::RecDescent->new($grammar); +} + +1; + + +__END__ + +original parser: + +use vars '$CHAR'; +$CHAR = qr{ [A-Za-z0-9_\!\@\#\$\%\&] | \[[^\]]*\] }x; + +my $PARSER = Parse::RecDescent->new(<<'__EOG__') or die; + parse: + alt /^\Z/ { $item[1] } + alt: + concat(2.. /[+|]/) { FLAT::Regex::Op::alt->from_parse(@item) } + | concat { $item[1] } + concat: + star(2..) { FLAT::Regex::Op::concat->from_parse(@item) } + | star { $item[1] } + star : + atomic '*' { FLAT::Regex::Op::star->from_parse(@item) } + | atomic { $item[1] } + atomic: + "(" alt ")" { $item[2] } + | /$FLAT::Regex::CHAR/ { FLAT::Regex::Op::atomic->from_parse(@item) } +__EOG__ diff --git a/lib/FLAT/Regex/Transform.pm b/lib/FLAT/Regex/Transform.pm new file mode 100644 index 0000000..cd0cf56 --- /dev/null +++ b/lib/FLAT/Regex/Transform.pm @@ -0,0 +1,18 @@ +package FLAT::Regex::Transform; + +# Extends FLAT::Regex::WithExtraOps with PRegex transformations +# (i.e., reductions based on: w*v & a*b + +use base 'FLAT::Regex::WithExtraOps'; + +sub new { + my $pkg = shift; + my $self = $pkg->SUPER::new(@_); + return $self; +} + +# Ideally, the transformation should be implemented as an iterator. This +# approach will be finite for shuffles with NO closed strings, but will carry on +# indefinitely for the shuffle of strings where at least one of the strings is closed + +1; diff --git a/lib/FLAT/Regex/Util.pm b/lib/FLAT/Regex/Util.pm new file mode 100644 index 0000000..516ad9f --- /dev/null +++ b/lib/FLAT/Regex/Util.pm @@ -0,0 +1,33 @@ +package FLAT::Regex::Util; +use base 'FLAT::Regex'; + +use strict; +use Carp; + +sub get_symbol { + my @symbols = qw/0 1/; + return $symbols[rand(2)]; +} + +sub get_op { + my @ops = ('*','+','&','','','','','','',''); + return $ops[rand(10)]; +} + +sub get_random { + my $length = shift; + my $string = ''; + if (1 < $length) { + $string = get_symbol().get_op().get_random(--$length); + } else { + $string = get_symbol(); + } + return $string; +} + +sub random_pre { + my $length = ( $_[0] ? $_[0] : 32 ); + return FLAT::Regex::WithExtraOps->new(get_random($length)); +} + +1; diff --git a/lib/FLAT/Regex/WithExtraOps.pm b/lib/FLAT/Regex/WithExtraOps.pm new file mode 100644 index 0000000..b366d7c --- /dev/null +++ b/lib/FLAT/Regex/WithExtraOps.pm @@ -0,0 +1,109 @@ +package FLAT::Regex::WithExtraOps; +use base 'FLAT::Regex'; + +use strict; +use Carp; + +my $PARSER = FLAT::Regex::Parser->new(qw[ alt concat star negate shuffle ]); +sub _parser { $PARSER } + +sub members { + my $self = shift; + wantarray ? @$self[0 .. $#$self] : $self->[0]; +} + +#### Precedence +# 30 ::star +# 20 ::concat +# 15 ::negate <---<< WithExtraOps +# 12 ::shuffle <---<< WithExtraOps +# 10 ::alt +# 0 ::atomic + +############################### +package FLAT::Regex::Op::negate; +use base "FLAT::Regex::Op"; +use Carp; + +sub parse_spec { "'~' %s"; } +sub precedence { 15 } # between concat and alternation + +sub as_string { + my ($self, $prec) = @_; + my $result = "~" . $self->members->as_string($self->precedence); + return $prec > $self->precedence ? "($result)" : $result; +} + +sub from_parse { + my ($pkg, @item) = @_; + $pkg->new( $item[2] ); +} + +## note: "reverse" conflicts with perl builtin +sub reverse { + my $self = shift; + my $op = $self->members->reverse; + __PACKAGE__->new($op); +} + +sub is_empty { + croak "Not implemented for negated regexes"; +} + +sub has_nonempty_string { + croak "Not implemented for negated regexes"; +} + +sub is_finite { + croak "Not implemented for negated regexes"; +} + +############################### +package FLAT::Regex::Op::shuffle; +use base 'FLAT::Regex::Op'; +use Carp; + +sub parse_spec { "%s(2.. /[&]/)" } +sub precedence { 12 } + +sub as_string { + my ($self, $prec) = @_; + my $result = join "&", + map { $_->as_string($self->precedence) } + $self->members; + return $prec > $self->precedence ? "($result)" : $result; +} + +sub as_perl_regex { + my $self = shift; + croak "Not implemented for shuffled regexes"; +} + +sub from_parse { + my ($pkg, @item) = @_; + $pkg->new( @{ $item[1] } ); +} + +sub as_pfa { + my $self = shift; + my @parts = map { $_->as_pfa } $self->members; + $parts[0]->shuffle( @parts[1..$#parts] ); +} + +# Implement? +sub reverse { + my $self = shift; + croak "Not implemented for shuffled regexes"; +} + +sub is_empty { + croak "Not implemented for shuffled regexes"; +} + +sub has_nonempty_string { + croak "Not implemented for shuffled regexes"; +} + +sub is_finite { + croak "Not implemented for shuffled regexes"; +} diff --git a/lib/FLAT/Symbol.pm b/lib/FLAT/Symbol.pm new file mode 100644 index 0000000..aaadccc --- /dev/null +++ b/lib/FLAT/Symbol.pm @@ -0,0 +1,98 @@ +# +# Conceptual Experiment - not currently implemented anywhere... +# + +package FLAT::Symbol + +use strict; +use Carp; + +sub new { + my ($pkg, $string, $type) = @_; + bless { + STRING => $string, + TYPE => $type, + }, $pkg; +} + +sub as_string { + return $_[0]->{STRING}; +} + +sub get_type } + return $_[0]->{TYPE}; +} + +sub set_type { + $_[0]->{TYPE} = $_[1]; +} + +1; + +################## + +package FLAT::Symbol::Regular; +use base 'FLAT::Symbol'; + +sub new { + my $pkg = shift; + my $self = $pkg->SUPER::new($_[0],'Regular'); + return $self; +} + +sub get_type { + return 'Regular'; +} + +sub set_type { + croak("Sorry, can't change type for this symbol"); +} + +1; + +################## + +package FLAT::Symbol::Special; +use base 'FLAT::Symbol'; + +sub new { + my $pkg = shift; + my $self = $pkg->SUPER::new($_[0],'Special'); + return $self; +} + +sub get_type { + return 'Special'; +} + +sub set_type { + croak("Sorry, can't change type for this symbol");} + +1; + +__END__ + +=head1 NAME + +FLAT::Symbol - Base class for transition symbol. + +=head1 SYNOPSIS + +A super class that is intended to provide a simple mechanism for storing a symbol that might be +in conflict with another symbol in string form. TYPE is used to distinguish. Currenly this neither +this, nor its current sub classes, FLAT::Symbol::Regular and FLAT::Symbol::Special, are used. + +=head1 AUTHORS & ACKNOWLEDGEMENTS + +FLAT is written by Mike Rosulek E<lt>mike at mikero dot comE<gt> and +Brett Estrade E<lt>estradb at gmail dot comE<gt>. + +The initial version (FLAT::Legacy) by Brett Estrade was work towards an +MS thesis at the University of Southern Mississippi. + +Please visit the Wiki at http://www.0x743.com/flat + +=head1 LICENSE + +This module is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. diff --git a/lib/FLAT/Transition.pm b/lib/FLAT/Transition.pm new file mode 100644 index 0000000..fc385f3 --- /dev/null +++ b/lib/FLAT/Transition.pm @@ -0,0 +1,66 @@ +package FLAT::Transition; +use strict; +use Carp; + +sub new { + my ($pkg, @things) = @_; + bless { map { $_ => 1 } @things }, $pkg; +} + +sub does { + my ($self, @things) = @_; + return 1 if @things == 0; + return !! grep $self->{$_}, @things; +} + +sub add { + my ($self, @things) = @_; + @$self{@things} = (1) x @things; +} + +sub delete { + my ($self, @things) = @_; + delete $self->{$_} for @things; +} + +sub alphabet { + my $self = shift; + sort { $a cmp $b } keys %$self; +} + +sub as_string { + my $self = shift; + join ",", map { length $_ ? $_ : "epsilon" } $self->alphabet; +} + +1; + +__END__ + +=head1 NAME + +FLAT::Transition - a transition base class. + +=head1 SYNOPSIS + +Default implementation of the Transition class, used to manage transitions +from one state to others. This class is meant for internal use. + +=head1 USAGE + +used internally; + +=head1 AUTHORS & ACKNOWLEDGEMENTS + +FLAT is written by Mike Rosulek E<lt>mike at mikero dot comE<gt> and +Brett Estrade E<lt>estradb at gmail dot comE<gt>. + +The initial version (FLAT::Legacy) by Brett Estrade was work towards an +MS thesis at the University of Southern Mississippi. + +Please visit the Wiki at http://www.0x743.com/flat + +=head1 LICENSE + +This module is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. diff --git a/lib/FLAT/XFA.pm b/lib/FLAT/XFA.pm new file mode 100644 index 0000000..67e073c --- /dev/null +++ b/lib/FLAT/XFA.pm @@ -0,0 +1,3 @@ +package FLAT::XFA; + +1; diff --git a/lib/Kratos/DFADriver.pm b/lib/Kratos/DFADriver.pm new file mode 100644 index 0000000..a3473f7 --- /dev/null +++ b/lib/Kratos/DFADriver.pm @@ -0,0 +1,1334 @@ +package Kratos::DFADriver; + +use strict; +use warnings; +use 5.020; + +use parent 'Class::Accessor'; + +use Archive::Tar; +use AspectC::Repo; +use Carp; +use Carp::Assert::More; +use Cwd; +use DateTime; +use Device::SerialPort; +use File::Slurp qw(read_dir read_file write_file); +use IPC::Run qw(harness); +use JSON; +use Kratos::DFADriver::DFA; +use Kratos::DFADriver::Model; +use List::Util qw(first); +use List::MoreUtils qw(pairwise); +use MIMOSA; +use MIMOSA::Log; + +Kratos::DFADriver->mk_ro_accessors(qw(class_name dfa mimosa model repo)); + +our $VERSION = '0.00'; + +sub new { + my ( $class, %opt ) = @_; + + my $self = \%opt; + + $self->{dfa} = Kratos::DFADriver::DFA->new(%opt); + $self->{mimosa} = MIMOSA->new(%opt); + $self->{model} = Kratos::DFADriver::Model->new(%opt); + $self->{repo} = AspectC::Repo->new; + $self->{class_name} = $self->{model}->class_name; + $self->{lp}{iteration} = 1; + + bless( $self, $class ); + + $self->set_paths; + $self->dfa->set_model( $self->model ); + + return $self; +} + +sub set_paths { + my ($self) = @_; + + my $xml_path = $self->{xml_file}; + $xml_path =~ s{ /?+dfa-driver/[^/]+[.]xml $ }{}x; + + my $prefix = $self->{prefix} = cwd() . "/${xml_path}/src"; + my $class_prefix + = $self->repo->get_class_path_prefix( $self->{class_name} ); + $self->{ah_file} = "${prefix}/${class_prefix}_dfa.ah"; + $self->{cc_file} = "${prefix}/${class_prefix}_dfa.cc.inc"; + $self->{h_file} = "${prefix}/${class_prefix}_dfa.h.inc"; +} + +sub set_output { + my ($self, $mode) = @_; + + if ($mode eq 'tex') { + $self->{tex} = 1; + } + + return $self; +} + +sub preprocess { + my ( $self, @files ) = @_; + my @logs; + my @json_files; + + for my $i ( 0 .. $#files ) { + push( + @logs, + MIMOSA::Log->new( + data_file => $files[$i], + fast_analysis => $self->{fast_analysis}, + model => $self->model, + merge_args => $self->{merge_args}, + tmpsuffix => $i, + ) + ); + } + + for my $log (@logs) { + if ( not $self->{cache} or not $log->load_cache ) { + $log->load_archive; + $log->preprocess; + $log->save_cache; + } + push( @json_files, $log->json_name ); + } + + $self->{log} = $logs[0]; + return ( \@logs, \@json_files ); +} + +sub analyze { + my ( $self, @files ) = @_; + my ( $logs, $json_files ) = $self->preprocess(@files); + $self->log->analyze( @{$json_files} ); +} + +sub validate_model { + my ( $self, @files ) = @_; + my ( $logs, $json_files ) = $self->preprocess(@files); + $self->log->validate( @{$json_files} ); + $self->assess_validation; +} + +sub crossvalidate_model { + my ( $self, @files ) = @_; + my ( $logs, $json_files ) = $self->preprocess(@files); + $self->log->crossvalidate( @{$json_files} ); +} + +sub log { + my ( $self, $file ) = @_; + + if ($file) { + $self->{log} = undef; + } + + $self->{log} //= MIMOSA::Log->new( + data_file => $file // $self->{data_file}, + fast_analysis => $self->{fast_analysis}, + model => $self->model, + merge_args => $self->{merge_args} + ); + + return $self->{log}; +} + +sub assess_fits { + my ( $self, $hash, $param ) = @_; + my $errmap = $hash->{fit_guess}{$param}; + my @errors = map { [ $_, $errmap->{$_} ] } keys %{$errmap}; + @errors = sort { $a->[1]{rmsd} <=> $b->[1]{rmsd} } @errors; + + my $min_err = $errors[0][1]{rmsd}; + @errors = grep { $_->[1]{rmsd} <= 2 * $min_err } @errors; + my @function_types = map { + sprintf( '%s (%.f / %.2f%%)', $_->[0], $_->[1]{rmsd}, $_->[1]{smape} ) + } @errors; + + return @function_types; +} + +sub printf_aggr { + my ( $self, $hash, $key, $unit ) = @_; + + $hash = $hash->{$key}; + + if ( exists $hash->{median_goodness}{smape} ) { + printf( + " %s: static error: %.2f%% / %.f %s (σ = %.f)\n", + $key, + $hash->{median_goodness}{smape}, + $hash->{median_goodness}{mae}, + $unit, $hash->{std_inner} + ); + +#printf(" %s: median %.f (%.2f / %.2f%%), mean %.f (%.2f / %.2f%%), σ %.f %s\n", +# $key, +# $hash->{median}, +# $hash->{median_goodness}{mae} // -1, +# $hash->{median_goodness}{smape} // -1, +# $hash->{mean}, +# $hash->{mean_goodness}{mae} // -1, +# $hash->{mean_goodness}{smape} // -1, +# $hash->{std_inner}, +# $unit +#); + } + else { + printf( + " %s: static error: %.f %s (σ = %.f)\n", + $key, $hash->{median_goodness}{mae}, + $unit, $hash->{std_inner} + ); + + #printf( + # " %s: median %.f (%.2f), mean %.f (%.2f), σ %.f %s\n", + # $key, $hash->{median}, $hash->{median_goodness}{mae}, + # $hash->{mean}, $hash->{mean_goodness}{mae}, + # $hash->{std_inner}, $unit + #); + } +} + +sub printf_aggr_tex { + my ( $self, $hash, $key, $unit, $divisor) = @_; + + $hash = $hash->{$key}; + + if ($unit eq 'ms' and $hash->{median} < 1e3) { + $unit = '\us'; + $divisor = 1; + } + elsif ($unit eq '\uJ' and $hash->{median} < 1e6) { + $unit = 'nJ'; + $divisor = 1e3; + } + elsif ($unit eq '\uW' and $hash->{median} >= 1e3) { + $unit = 'mW'; + $divisor = 1e3; + } + + use locale; + + printf(' & & \unit[%.3g]{%s}', $hash->{median} / $divisor, $unit); +} + +sub printf_count_tex { + my ( $self, $hash, $key ) = @_; + + if ($hash) { + $hash = $hash->{$key}; + + printf(' & %d', $hash->{count}); + } + else { + printf(' & '); + } +} + +sub printf_eval_tex { + my ( $self, $hash, $key, $unit, $divisor) = @_; + + $hash = $hash->{$key}; + + if ($unit eq 'ms' and $hash->{median_goodness}{mae} < 1e3) { + $unit = '\us'; + $divisor = 1; + } + if ($unit eq '\uJ' and $hash->{median_goodness}{mae} < 1e6) { + $unit = 'nJ'; + $divisor = 1e3; + } + + use locale; + + printf("\n%20s & \\unit[%.3g]{%s} & \\unit[%.2g]{\\%%}", + q{}, + $hash->{median_goodness}{mae} / $divisor, $unit, + $hash->{median_goodness}{smape} // -1 + ); +} + +sub printf_goodness { + my ( $self, $modval, $hash, $key, $unit ) = @_; + + $hash = $hash->{$key}; + + if ( exists $hash->{goodness}->{smape} ) { + printf( +" %s: model %.f %s, log ~=%.f / µ=%.f %s, mean absolute error %.2f %s (%.2f%%)\n", + $key, $modval, + $unit, $hash->{median}, + $hash->{mean}, $unit, + $hash->{goodness}->{mae}, $unit, + $hash->{goodness}{smape} + ); + } + else { + printf( +" %s: model %.f %s, log ~=%.f / µ=%.f %s, mean absolute error %.2f %s\n", + $key, $modval, $unit, $hash->{median}, $hash->{mean}, $unit, + $hash->{goodness}->{mae}, $unit ); + } +} + +sub printf_online_goodness { + my ( $self, $hash, $key, $unit ) = @_; + + $hash = $hash->{$key}; + + if ( exists $hash->{goodness}->{smape} ) { + printf( +" %s: ~=%.f / µ=%.f %s, mean absolute error %.2f %s (%.2f%%)\n", + $key, $hash->{median}, + $hash->{mean}, $unit, + $hash->{goodness}->{mae}, $unit, + $hash->{goodness}{smape} + ); + } + else { + printf( +" %s: ~=%.f / µ=%.f %s, mean absolute error %.2f %s\n", + $key, $hash->{median}, $hash->{mean}, $unit, + $hash->{goodness}->{mae}, $unit ); + } +} + +sub printf_clip { + my ( $self, $hash ) = @_; + + if ( $hash->{clip}{max} > 0.01 ) { + printf( + " WARNING: Up to %.f%% clipping in power measurements (avg %.f%%)" + . ", results are unreliable\n", + $hash->{clip}{max} * 100, + $hash->{clip}{mean} * 100 + ); + } +} + +sub printf_parameterized { + my ( $self, $hash, $key ) = @_; + $hash = $hash->{$key}; + + my $std_global = $hash->{std_inner}; + my $std_ind_param = $hash->{std_param}; + my $std_ind_trace = $hash->{std_trace}; + my $std_by_param = $hash->{std_by_param}; + my $std_by_trace = $hash->{std_by_trace} // {}; + my $param_ratio; + my $trace_ratio; + + if ( $std_global > 0 ) { + $param_ratio = $std_ind_param / $std_global; + } + if ( $std_ind_param > 0) { + $trace_ratio = $std_ind_trace / $std_ind_param; + } + + if ( $std_global > 10 + and $param_ratio < 0.5 + and not exists $hash->{function}{user} ) + { + printf( " %s: should be parameterized (%.2f / %.2f = %.3f)\n", + $key, $std_ind_param, $std_global, $param_ratio ); + } + if ( + ( + $std_global < 10 + or $param_ratio > 0.5 + ) + and exists $hash->{function}{user} + ) + { + printf( " %s: should not be parameterized (%.2f / %.2f = %.3f)\n", + $key, $std_ind_param, $std_global, + $param_ratio ? $param_ratio : 0 ); + } + + if ( $std_global > 10 and $trace_ratio < 0.5 ) { + printf( + " %s: model insufficient, depends on trace (%.2f / %.2f = %.3f)\n", + $key, $std_ind_trace, $std_ind_param, $trace_ratio ); + } + + if ( $std_global < 10 ) { + return; + } + + for my $param ( sort keys %{$std_by_param} ) { + my $std_this = $std_by_param->{$param}; + my $ratio = $std_ind_param / $std_this; + my $status = 'does not depend'; + my $fline = q{}; + if ( $ratio < 0.6 ) { + $status = 'might depend'; + $fline = q{, probably }; + $fline .= join( ' or ', $self->assess_fits( $hash, $param ) ); + } + if ( $ratio < 0.3 ) { + $status = 'depends'; + } + if ($fline) { + printf( " %s: %s on %s (%.2f / %.2f = %.3f%s)\n", + $key, $status, $param, $std_ind_param, $std_this, $ratio, + $fline ); + } + } + + for my $transition ( sort keys %{$std_by_trace} ) { + my $std_this = $std_by_trace->{$transition}; + my $ratio = $std_ind_trace / $std_this; + if ($ratio < 0.4) { + printf( +" %s: depends on presence of %s in trace (%.2f / %.2f = %.3f)\n", + $key, $transition, $std_ind_trace, $std_this, $ratio ); + } + } +} + +sub printf_fit { + my ( $self, $hash, $key, $unit ) = @_; + $hash = $hash->{$key}; + + if ( exists $hash->{function}{user} ) { + if ( exists $hash->{function}{user}{error} ) { + printf( " user-specifed %s function could not be fitted: %s\n", + $key, $hash->{function}{user}{error} ); + } + else { + printf( + " user-specifed %s function fit error: %.2f%% / %.f %s\n", + $key, + $hash->{function}{user}{fit}{smape} // -1, + $hash->{function}{user}{fit}{mae}, $unit + ); + } + } + if ( exists $hash->{function}{estimate} ) { + if ( exists $hash->{function}{estimate}{error} ) { + printf( " estimated %s function could not be fitted: %s\n", + $key, $hash->{function}{estimate}{error} ); + } + else { + printf( + " estimated %s function fit error: %.2f%% / %.f %s\n", + $key, + $hash->{function}{estimate}{fit}{smape} // -1, + $hash->{function}{estimate}{fit}{mae}, $unit + ); + } + } + if ( exists $hash->{param_mean_goodness} ) { + printf( + " %s: mean/ssr-fit LUT error: %.2f%% / %.f %s / %.f\n", + $key, + $hash->{param_mean_goodness}{smape} // -1, + $hash->{param_mean_goodness}{mae}, $unit, + $hash->{param_mean_goodness}{rmsd} + ); + } + if ( exists $hash->{param_median_goodness} ) { + printf( + " %s: median/static LUT error: %.2f%% / %.f %s / %.f\n", + $key, + $hash->{param_median_goodness}{smape} // -1, + $hash->{param_median_goodness}{mae}, $unit, + $hash->{param_mean_goodness}{rmsd} + ); + } +} + +sub assess_model { + my ($self) = @_; + + for my $name ( sort keys %{ $self->{log}{aggregate}{state} } ) { + my $state = $self->{log}{aggregate}{state}{$name}; + + printf( "Assessing %s:\n", $name ); + + $self->printf_clip($state); + $self->printf_aggr( $state, 'power', 'µW' ); + $self->printf_parameterized( $state, 'power' ); + $self->printf_fit( $state, 'power', 'µW' ); + } + for my $name ( sort keys %{ $self->{log}{aggregate}{transition} } ) { + my $transition = $self->{log}{aggregate}{transition}{$name}; + + printf( "Assessing %s:\n", $name ); + + $self->printf_clip($transition); + $self->printf_aggr( $transition, 'duration', 'µs' ); + $self->printf_parameterized( $transition, 'duration' ); + $self->printf_fit( $transition, 'duration', 'µs' ); + $self->printf_aggr( $transition, 'energy', 'pJ' ); + $self->printf_parameterized( $transition, 'energy' ); + $self->printf_fit( $transition, 'energy', 'pJ' ); + $self->printf_aggr( $transition, 'rel_energy', 'pJ' ); + $self->printf_parameterized( $transition, 'rel_energy' ); + $self->printf_fit( $transition, 'rel_energy', 'pJ' ); + + if ( exists $transition->{timeout}{median} ) { + $self->printf_aggr( $transition, 'timeout', 'µs' ); + $self->printf_parameterized( $transition, 'timeout' ); + $self->printf_fit( $transition, 'timeout', 'µs' ); + } + } + +} + +sub assess_model_tex { + my ($self) = @_; + say '\begin{tabular}{|c|rrr|r|}\\hline'; + say 'Zustand & $\MmedP$ & & & $n$ \\\\\\hline'; + for my $name ( sort keys %{ $self->{log}{aggregate}{state} } ) { + my $state = $self->{log}{aggregate}{state}{$name}; + + printf("\n%20s", $name); + + $self->printf_aggr_tex( $state, 'power', '\uW', 1 ); + $self->printf_eval_tex( $state, 'power', '\uW', 1 ); + $self->printf_count_tex( $state, 'power' ); + print " \\\\"; + } + say '\end{tabular}\\\\'; + say '\vspace{0.5cm}'; + say '\begin{tabular}{|c|rr|rr|rr|r|}\\hline'; + say 'Transition & & $\MmedE$ & & $\MmedF$ & & $\Mmeddur$ & $n$ \\\\\\hline'; + for my $name ( sort keys %{ $self->{log}{aggregate}{transition} } ) { + my $transition = $self->{log}{aggregate}{transition}{$name}; + + printf("\n%20s", $name); + + $self->printf_aggr_tex( $transition, 'energy', '\uJ', 1e6 ); + $self->printf_aggr_tex( $transition, 'rel_energy', '\uJ', 1e6 ); + $self->printf_aggr_tex( $transition, 'duration', 'ms', 1e3 ); + $self->printf_count_tex( $transition, 'energy' ); + print " \\\\"; + $self->printf_eval_tex( $transition, 'energy', '\uJ', 1e6 ); + $self->printf_eval_tex( $transition, 'rel_energy', '\uJ', 1e6 ); + $self->printf_eval_tex( $transition, 'duration', 'ms', 1e3 ); + $self->printf_count_tex; + print " \\\\"; + } + print "\\hline\n"; + say '\end{tabular}'; +} + +sub assess_validation { + my ($self) = @_; + + for my $name ( sort keys %{ $self->{log}{aggregate}{state} } ) { + my $state = $self->{log}{aggregate}{state}{$name}; + + printf( "Validating %s:\n", $name ); + $self->printf_clip($state); + $self->printf_goodness( $self->model->get_state_power($name), + $state, 'power', 'µW' ); + $self->printf_fit( $state, 'power', 'µW' ); + $self->printf_online_goodness( + $state, 'online_power', 'µW' ); + $self->printf_online_goodness( + $state, 'online_duration', 'µs' ); + } + for my $name ( sort keys %{ $self->{log}{aggregate}{transition} } ) { + my $transition = $self->{log}{aggregate}{transition}{$name}; + + printf( "Validating %s:\n", $name ); + $self->printf_clip($transition); + $self->printf_goodness( + $self->model->get_transition_by_name($name)->{duration}{static}, + $transition, 'duration', 'µs' ); + $self->printf_goodness( + $self->model->get_transition_by_name($name)->{energy}{static}, + $transition, 'energy', 'pJ' ); + $self->printf_goodness( + $self->model->get_transition_by_name($name)->{rel_energy}{static}, + $transition, 'rel_energy', 'pJ' ); + if ( exists $transition->{timeout}{median} ) { + + #$self->printf_goodness('?', $transition, 'timeout', 'µs'); + $self->printf_fit( $transition, 'timeout', 'µs' ); + } + } +} + +sub update_model { + my ($self) = @_; + + while ( my ( $name, $state ) = each %{ $self->{log}{aggregate}{state} } ) { + $self->model->set_state_power( $name, $state->{power}{median} ); + for my $fname ( keys %{ $state->{power}{function} } ) { + $self->model->set_state_params( + $name, $fname, + $state->{power}{function}{$fname}{raw}, + @{ $state->{power}{function}{$fname}{params} } + ); + } + } + while ( my ( $name, $transition ) + = each %{ $self->{log}{aggregate}{transition} } ) + { + $self->model->set_transition_data( + $name, + $transition->{duration}{median}, + $transition->{energy}{median}, + $transition->{rel_energy}{median} + ); + for my $key (qw(duration energy rel_energy timeout)) { + for my $fname ( keys %{ $transition->{$key}{function} } ) { + $self->model->set_transition_params( + $name, $key, $fname, + $transition->{$key}{function}{$fname}{raw}, + @{ $transition->{$key}{function}{$fname}{params} } + ); + } + } + } + + $self->model->save; +} + +sub reset_model { + my ($self) = @_; + + $self->model->reset; + $self->model->save; +} + +sub to_ah { + my ($self) = @_; + my $class_name = $self->{class_name}; + my $repo = $self->repo; + my $class_header = $repo->{class}{$class_name}{sources}[0]{file}; + + my @transition_names + = grep { $_ ne q{?} } map { $_->{name} } $self->model->transitions; + + my $trigger_port = $self->{trigger_port}; + my $trigger_pin = $self->{trigger_pin}; + + my $ignore_nested = q{}; + my $adv_type = 'execution'; + + if ( $self->{ignore_nested} ) { + $adv_type = 'call'; + $ignore_nested = "&& !within(\"${class_name}\")"; + } + + my $ah_buf = <<"EOF"; + +#ifndef ${class_name}_DFA_AH +#define ${class_name}_DFA_AH + +#include "drivers/dfa_driver.h" +#include "drivers/gpio.h" +#include "drivers/eUSCI_A/uart/prototype_uart.h" +#include "${class_header}" + +pointcut InnerTransition() = execution("% ${class_name}::%(...)"); + +EOF + + if ( defined $trigger_port and defined $trigger_pin ) { + + $ah_buf .= "aspect ${class_name}_Trigger {\n\n"; + + $ah_buf .= 'pointcut Transition() = "' + . join( q{" || "}, + map { "% ${class_name}::$_(...)" } @transition_names ) + . "\";\n\n"; + $ah_buf .= <<"EOF"; + + advice execution("void initialize_devices()") : after() { + setOutput(${trigger_port}, ${trigger_pin}); + } + + advice ${adv_type}(Transition()) ${ignore_nested} : before() { + pinHigh(${trigger_port}, ${trigger_pin}); + } + advice ${adv_type}(Transition()) ${ignore_nested} : after() { + /* 22 = 10.2us delay @ 16MHz */ + /* 32 = 14.6us delay @ 16MHz */ + /* 64 = 28.6us delay @ 16MHz */ + /* 160 = 50.6us delay @ 16MHz */ + for (unsigned int i = 0; i < 64; i++) + asm volatile("nop"); + pinLow(${trigger_port}, ${trigger_pin}); + } + + advice execution(Transition()) : order("${class_name}_DFA", "${class_name}_Trigger"); + +EOF + + if ( $self->{ignore_nested} ) { + for my $transition ( $self->model->transitions ) { + if ( $transition->{level} eq 'epilogue' ) { + $ah_buf .= <<"EOF"; + + advice execution("% ${class_name}::$transition->{name}(...)") : before() { + pinHigh(${trigger_port}, ${trigger_pin}); + } + advice execution("% ${class_name}::$transition->{name}(...)") : after() { + for (unsigned int i = 0; i < 64; i++) + asm volatile("nop"); + pinLow(${trigger_port}, ${trigger_pin}); + } + +EOF + } + } + } + $ah_buf .= "};\n\n"; + } + + $ah_buf .= "aspect ${class_name}_DFA {\n\n"; + + for my $transition ( $self->model->transitions ) { + if ( $transition->{name} ne q{?} ) { + my $dest_state_id + = $self->model->get_state_id( $transition->{destination} ); + if ( $transition->{level} eq 'user' ) { + $ah_buf .= <<"EOF"; + + advice ${adv_type}("% ${class_name}::$transition->{name}(...)") ${ignore_nested} : after() { + tjp->target()->passTransition(${class_name}::statepower[tjp->target()->state], + $transition->{rel_energy}{static}, $transition->{id}, + ${dest_state_id}); + }; + +EOF + } + else { + $ah_buf .= <<"EOF"; + + advice execution("% ${class_name}::$transition->{name}(...)") : after() { + tjp->target()->passTransition(${class_name}::statepower[tjp->target()->state], + $transition->{rel_energy}{static}, $transition->{id}, + ${dest_state_id}); + }; + +EOF + } + } + } + + $ah_buf .= <<"EOF"; + +}; +#endif + +EOF + + return $ah_buf; +} + +sub to_cc { + my ($self) = @_; + my $class_name = $self->{class_name}; + + my @state_enum = $self->model->get_state_enum; + + my $buf + = "DFA_Driver::power_uW_t ${class_name}::statepower[] = {" + . join( ', ', map { $self->model->get_state_power($_) } @state_enum ) + . "};\n"; + + return $buf; +} + +sub to_h { + my ($self) = @_; + + my @state_enum = $self->model->get_state_enum; + + my $buf + = "public:\n" + . "static power_uW_t statepower[];\n" + . "enum State : uint8_t {" + . join( ', ', @state_enum ) . "};\n"; + + return $buf; +} + +sub to_tikz { + my ($self) = @_; + + my $buf = <<'EOF'; + + \begin{tikzpicture}[node distance=3cm,>=stealth',bend angle=45,auto,->] + \tikzstyle{state}=[ellipse,thick,draw=black!75,minimum size=1cm,inner sep=2pt] + +EOF + + my @state_enum = $self->model->get_state_enum; + my $initial = shift(@state_enum); + my $prev = $initial; + my $ini_name = $initial; + + if ( $ini_name eq 'UNINITIALIZED' ) { + $ini_name = '?'; + } + + $buf + .= "\t\t\\node [state,initial,initial text={},initial where=left] ($initial) {\\small $ini_name};\n"; + for my $state (@state_enum) { + $buf + .= "\t\t\\node [state,right of=${prev}] ($state) {\\small $state};\n"; + $prev = $state; + } + + $buf .= "\n\t\t\\path\n"; + + for my $transition ( $self->model->transitions ) { + for my $origin ( @{ $transition->{origins} } ) { + my @edgestyles; + if ( $transition->{level} eq 'epilogue' ) { + push( @edgestyles, 'dashed' ); + } + if ( $origin eq $transition->{destination} ) { + push( @edgestyles, 'loop above' ); + } + my $edgestyle + = @edgestyles ? '[' . join( q{,}, @edgestyles ) . ']' : q{}; + $buf + .= "\t\t ($origin) edge ${edgestyle} node {$transition->{name}} ($transition->{destination})\n"; + } + } + $buf .= "\t\t;\n"; + $buf .= "\t\\end{tikzpicture}\n"; + + return $buf; +} + +sub to_test_ah { + my ($self) = @_; + + my $buf = <<'EOF'; + +/* + * Autogenerated code -- Manual changes are not preserved + * vim:readonly + */ + +#ifndef DRIVEREVAL_AH +#define DRIVEREVAL_AH + +#include "DriverEval.h" +#include "syscall/guarded_scheduler.h" + +aspect StartDFADriverEvalThread { + advice execution("void ready_threads()") : after() { + organizer.Scheduler::ready(driverEvalThread); + } +}; + +#endif + +EOF + + return $buf; +} + +sub to_test_cc { + my ($self) = @_; + + my @runs = $self->dfa->traces; + my @state_enum = $self->model->get_state_enum; + my $dfa = $self->dfa->dfa; + my $num_runs = @runs; + my $instance = $self->repo->get_class_instance( $self->{class_name} ); + + my $state_duration = $self->{state_duration} // 1000; + + my $buf = <<"EOF"; + +/* + * Autogenerated code - Manual changes are not preserved. + * vim:readonly + */ + +#include "DriverEval.h" +#include "syscall/guarded_buzzer.h" + +DeclareThread(DriverEvalThread, driverEvalThread, 256); + +void DriverEvalThread::action() +{ + Guarded_Buzzer buzzer; + + while (1) { + + /* wait for MIMOSA calibration */ + buzzer.sleep(12000); + buzzer.set(${state_duration}); + + +EOF + + $buf .= $self->model->startup_code; + $buf .= "${instance}.startIteration(${num_runs});\n"; + + for my $run (@runs) { + $buf .= "\t\t/* test run $run->{id} start */\n"; + $buf .= "\t\t${instance}.resetLogging();\n"; + # $buf .= "\t\t${instance}.resetAccounting();\n"; # TODO sinnvoll? + my $state = 0; + for my $transition ( grep { $_->{isa} eq 'transition' } + @{ $run->{trace} } ) + { + my ( $cmd, @args ) = @{ $transition->{code} }; + my ($new_state) + = $dfa->successors( $state, ":${cmd}!" . join( '!', @args ) ); + my $state_name = $self->dfa->reduced_id_to_state($state); + my $new_state_name = $self->dfa->reduced_id_to_state($new_state); + $buf .= "\t\t/* Transition $state_name -> $new_state_name */\n"; + + if ( $self->model->get_transition_by_name($cmd)->{level} eq + 'epilogue' ) + { + $buf .= "\t\t/* wait for $cmd interrupt */\n"; + $buf .= "\t\tbuzzer.sleep();\n"; + } + else { + $buf .= sprintf( "\t\t%s.%s(%s);\n", + $instance, $cmd, join( ', ', @args ) ); + $buf .= "\t\tbuzzer.sleep();\n"; + } + $buf .= $self->model->after_transition_code; + $state = $new_state; + } + $buf .= "\t\t${instance}.dumpLog();\n\n"; + } + + $buf .= $self->model->shutdown_code; + $buf .= "${instance}.stopIteration(); }}\n"; + + return $buf; +} + +sub to_test_h { + my ($self) = @_; + + my $class_prefix + = $self->repo->get_class_path_prefix( $self->{class_name} ); + + my $buf = <<"EOF"; + +/* + * Autogenerated code -- Manual changes are not preserved + * vim:readonly + */ + +#ifndef DRIVEREVAL_H +#define DRIVEREVAL_H + +#include "${class_prefix}.h" +#include "syscall/thread.h" + +class DriverEvalThread : public Thread { + public: + DriverEvalThread(void* tos) : Thread(tos) { } + void action(); +}; + +extern DriverEvalThread driverEvalThread; + +#endif + +EOF + + return $buf; +} + +sub to_test_json { + my ($self) = @_; + + return JSON->new->encode( [ $self->dfa->traces ] ); +} + +sub rm_acc_files { + my ($self) = @_; + + for my $file ( $self->{ah_file}, $self->{cc_file}, $self->{h_file} ) { + if ( -e $file ) { + unlink($file); + } + } + + return $self; +} + +sub write_test_files { + my ($self) = @_; + + my $prefix = $self->{prefix} . '/apps/DriverEval'; + + if ( not -d $prefix ) { + mkdir($prefix); + } + + write_file( "${prefix}/DriverEval.ah", $self->to_test_ah ); + write_file( "${prefix}/DriverEval.cc", $self->to_test_cc ); + write_file( "${prefix}/DriverEval.h", $self->to_test_h ); + write_file( "${prefix}/DriverEval.json", $self->to_test_json ); + + # Old log may no longer apply to new test files + unlink("${prefix}/DriverLog.txt"); + + return $self; +} + +sub rm_test_files { + my ($self) = @_; + + my $prefix = $self->{prefix} . '/apps/DriverEval/DriverEval'; + + for my $file ( "${prefix}.ah", "${prefix}.cc", "${prefix}.h" ) { + if ( -e $file ) { + unlink($file); + } + } + + return $self; +} + +sub archive_files { + my ($self) = @_; + + $self->{lp}{timestamp} //= DateTime->now( time_zone => 'Europe/Berlin' ) + ->strftime('%Y%m%d_%H%M%S'); + + my $tar = Archive::Tar->new; + + my @eval_files = ( + ( map { "src/apps/DriverEval/DriverEval.$_" } (qw(ah cc h json)) ), + ( map { "src/apps/DriverEval/DriverLog.$_" } (qw(json txt)) ), + ); + + my @mim_files = grep { m{ \. mim }x } read_dir('.'); + + $tar->add_files( $self->{xml_file}, @eval_files, @mim_files ); + + $tar->add_data( + 'setup.json', + JSON->new->encode( + { + excluded_states => $self->{excluded_states}, + ignore_nested => $self->{ignore_nested}, + mimosa_offset => $self->{mimosa_offset}, + mimosa_shunt => $self->{mimosa_shunt}, + mimosa_voltage => $self->{mimosa_voltage}, + state_duration => $self->{state_duration}, + trace_filter => $self->{trace_filter}, + trace_revisit => $self->{trace_revisit}, + trigger_pin => $self->{trigger_pin}, + trigger_port => $self->{trigger_port}, + } + ) + ); + + $tar->write("../data/$self->{lp}{timestamp}_$self->{class_name}.tar"); + + return $self; +} + +sub write_acc_files { + my ($self) = @_; + + write_file( $self->{ah_file}, $self->to_ah ); + write_file( $self->{cc_file}, $self->to_cc ); + write_file( $self->{h_file}, $self->to_h ); + + return $self; +} + +sub launchpad_connect { + my ($self) = @_; + + $self->{port_file} //= '/dev/ttyACM1'; + $self->{port} = Device::SerialPort->new( $self->{port_file} ) + or croak("Error openig serial port $self->{port_file}"); + + $self->{port}->baudrate(115200); + $self->{port}->databits(8); + $self->{port}->parity('none'); + $self->{port}->read_const_time(500); + + return $self; +} + +sub launchpad_flash { + my ($self) = @_; + + my ( $make_buf, $prog_buf ); + + my $remake = harness( + [ 'make', '-B' ], + '<' => \undef, + '>&' => \$make_buf, + ); + + my $make_program = harness( + [ 'make', 'program' ], + '<' => \undef, + '>&' => \$prog_buf, + ); + + $remake->run + or croak( 'make -B returned ' . $remake->full_result ); + $make_program->run + or croak( 'make program returned ' . $remake->full_result ); + + return $self; +} + +sub launchpad_reset { + my ($self) = @_; + + my $output_buffer; + my $make_reset = harness( + [ 'make', 'reset' ], + '<' => \undef, + '>&' => \$output_buffer, + ); + + $make_reset->run + or croak( 'make reset returned ' . $make_reset->full_result ); + + return $self; +} + +sub launchpad_log_clean { + my ($self) = @_; + + for my $file ( read_dir('.') ) { + if ( $file =~ m{ \. mim $ }x ) { + unlink($file); + } + } +} + +sub launchpad_log_init { + my ($self) = @_; + + $self->{lp}{run_id} = 0; + $self->{lp}{sync} = 0; + $self->{lp}{calibrating} = 0; + $self->{lp}{run_done} = 0; + $self->{lp}{run} = []; + $self->{lp}{log} = []; + $self->{lp}{errors} = []; + $self->{lp}{log_buf} = q{}; + + $self->{lp}{re}{iter_start} = qr{ + ^ \[ EP \] \s iteration \s start, \s (?<runs> \d+ ) \s runs $ + }x; + $self->{lp}{re}{iter_stop} = qr{ + ^ \[ EP \] \s iteration \s stop $ + }x; + $self->{lp}{re}{run_start} = qr{ + ^ \[ EP \] \s run \s start $ + }x; + $self->{lp}{re}{run_stop} = qr{ + ^ \[ EP \] \s run \s stop, \s energyUsed = (?<total_e> \S+) $ + }x; + $self->{lp}{re}{transition} = qr{ + ^ \[ EP \] \s dt = (?<delta_t> \S+) \s de = (?<delta_e> \S+) \s + oldst = (?<old_state> \S+ ) \s trid = (?<transition_id> \S+ ) $ + }x; + + $self->launchpad_connect; + + return $self; +} + +sub launchpad_run_done { + my ($self) = @_; + + if ( $self->{lp}{run_done} ) { + $self->{lp}{run_done} = 0; + return 1; + } + return 0; +} + +sub launchpad_get_errors { + my ($self) = @_; + + my @errors = @{ $self->{lp}{errors} }; + $self->{lp}{errors} = []; + return @errors; +} + +sub launchpad_log_is_synced { + my ($self) = @_; + + return $self->{lp}{sync}; +} + +sub launchpad_log_status { + my ($self) = @_; + + return ( $self->{lp}{iteration}, $self->{lp}{run_id}, + $self->{lp}{num_runs} ); +} + +sub launchpad_log_read { + my ($self) = @_; + + my $port = $self->{port}; + + my ( $count, $chars ) = $port->read(1024); + + $self->{lp}{log_buf} .= $chars; + + if ( not defined $count ) { + $port->close; + croak("Serial port was disconnected"); + } + if ( $count > 0 ) { + my @lines = split( /\n\r/, $chars ); + for my $line (@lines) { + $self->launchpad_parse_line($line); + } + } +} + +sub merged_json { + my ($self) = @_; + + my @traces = $self->dfa->traces; + + for my $run ( @{ $self->{lp}{log} } ) { + my $trace_idx = $run->{id} - 1; + my $idx = 0; + + assert_is( $traces[$trace_idx]{id}, $run->{id} ); + push(@{$traces[$trace_idx]{total_energy}}, $run->{total_energy}); + for my $online_obj ( @{ $run->{trace} } ) { + my $plan_obj = $traces[$trace_idx]{trace}[$idx]; + + #printf("%-15s %-15s\n", $plan_obj->{name}, $online_obj->{name}); + + if ( not defined $plan_obj->{name} ) { + + # The planned test run is done, but the hardware reported an + # epilogue-level transition before the next run was started. + + $traces[$trace_idx]{trace}[$idx] = { + isa => $online_obj->{isa}, + name => $online_obj->{name}, + parameter => + $traces[$trace_idx]{trace}[ $idx - 1 ]{parameter}, + }; + if ( + exists $traces[$trace_idx]{trace}[ $idx - 1 ] + {final_parameter} ) + { + $traces[$trace_idx]{trace}[$idx]{parameter} + = $traces[$trace_idx]{trace}[ $idx - 1 ]{final_parameter}; + } + } + else { + if ($online_obj->{isa} ne $plan_obj->{isa}) { + printf("Log merge: ISA mismatch (should be %s, is %s) at index %d#%d\n", + $plan_obj->{isa}, $online_obj->{isa}, $trace_idx, $idx); + exit(1); + } + if ( $plan_obj->{name} ne 'UNINITIALIZED' ) { + if ($online_obj->{name} ne $plan_obj->{name}) { + printf("Log merge: name mismatch (should be %s, is %s) at index %d#%d\n", + $plan_obj->{name}, $online_obj->{name}, $trace_idx, $idx); + exit(1); + } + } + } + + push( + @{ $traces[$trace_idx]{trace}[$idx]{online} }, + $online_obj->{online} + ); + + $idx++; + } + } + + $self->{lp}{log} = []; + + return @traces; +} + +sub launchpad_parse_line { + my ( $self, $line ) = @_; + + if ( $line =~ $self->{lp}{re}{iter_start} ) { + $self->{lp}{sync} = 1; + $self->{lp}{run_id} = 0; + $self->{lp}{num_runs} = $+{runs}; + $self->{lp}{calibrating} = 0; + } + elsif ( not $self->{lp}{sync} ) { + return; + } + elsif ( $line =~ $self->{lp}{re}{iter_stop} ) { + $self->{lp}{iteration}++; + $self->{lp}{calibrating} = 1; + write_file( '../kratos/src/apps/DriverEval/DriverLog.txt', + $self->{lp}{log_buf} ); + write_file( + '../kratos/src/apps/DriverEval/DriverLog.json', + JSON->new->encode( [ $self->merged_json ] ) + ); + } + elsif ( $line =~ $self->{lp}{re}{run_start} ) { + $self->{lp}{run_id}++; + $self->{lp}{run} = []; + } + elsif ( $line =~ $self->{lp}{re}{run_stop} ) { + $self->{lp}{run_done} = 1; + push( + @{ $self->{lp}{log} }, + { + id => $self->{lp}{run_id}, + trace => [ @{ $self->{lp}{run} } ], + total_energy => 0 + $+{total_e}, + } + ); + } + elsif ( $line =~ $self->{lp}{re}{transition} ) { + push( + @{ $self->{lp}{run} }, + { + isa => 'state', + name => ( $self->model->get_state_enum )[ $+{old_state} ], + online => { + time => 0 + $+{delta_t}, + energy => 0 + $+{delta_e}, + power => 0 + $+{delta_e} / $+{delta_t}, + }, + }, + { + isa => 'transition', + name => + $self->model->get_transition_by_id( $+{transition_id} ) + ->{name}, + online => { + timeout => 0 + $+{delta_t}, + }, + }, + ); + } + else { + $self->{lp}{sync} = 0; + push( @{ $self->{lp}{errors} }, "Cannot parse $line" ); + } + +} + +1; 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; diff --git a/lib/Kratos/DFADriver/Model.pm b/lib/Kratos/DFADriver/Model.pm new file mode 100644 index 0000000..67fb318 --- /dev/null +++ b/lib/Kratos/DFADriver/Model.pm @@ -0,0 +1,555 @@ +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); +use XML::LibXML; + +Kratos::DFADriver::Model->mk_ro_accessors(qw(class_name xml)); + +our $VERSION = '0.00'; + +sub new { + my ( $class, %opt ) = @_; + + my $self = \%opt; + + $self->{parameter} = {}; + $self->{states} = {}; + $self->{transitions} = []; + $self->{xml} = XML::LibXML->load_xml( location => $self->{xml_file} ); + + bless( $self, $class ); + + $self->parse_xml; + + return $self; +} + +sub parse_xml { + my ($self) = @_; + + my $xml = $self->{xml}; + my ($driver_node) = $xml->findnodes('/data/driver'); + my $class_name = $self->{class_name} = $driver_node->getAttribute('name'); + my $state_index = 0; + my $transition_index = 0; + + for my $state_node ( $xml->findnodes('/data/driver/states/state') ) { + my $name = $state_node->getAttribute('name'); + my $power = $state_node->getAttribute('power') // 0; + $self->{states}{$name} = { + power => { static => 0+$power }, + id => $state_index, + node => $state_node, + }; + + for my $fun_node ( $state_node->findnodes('./powerfunction/*') ) { + my $fname = $fun_node->nodeName; + my $powerfunction = $fun_node->textContent; + $powerfunction =~ s{^ \n* \s* }{}x; + $powerfunction =~ s{\s* \n* $}{}x; + $powerfunction =~ s{ [\n\t]+ }{}gx; + $self->{states}{$name}{power}{function}{$fname}{raw} + = $powerfunction; + $self->{states}{$name}{power}{function}{$fname}{node} = $fun_node; + my $attrindex = 0; + + while ( $fun_node->hasAttribute("param${attrindex}") ) { + push( + @{ + $self->{states}{$name}{power}{function}{$fname}{params} + }, + $fun_node->getAttribute("param${attrindex}") + ); + $attrindex++; + } + } + + $state_index++; + } + + for my $param_node ( $xml->findnodes('/data/driver/parameters/param') ) { + my $param_name = $param_node->getAttribute('name'); + my $function_name = $param_node->getAttribute('functionname'); + my $function_arg = $param_node->getAttribute('functionparam'); + my $default = $param_node->textContent; + + $self->{parameter}{$param_name} = { + function => $function_name, + arg_name => $function_arg, + default => $default, + }; + } + + for my $transition_node ( + $xml->findnodes('/data/driver/transitions/transition') ) + { + my @src_nodes = $transition_node->findnodes('./src'); + my ($dst_node) = $transition_node->findnodes('./dst'); + my ($level_node) = $transition_node->findnodes('./level'); + my @param_nodes = $transition_node->findnodes('./param'); + my @affected_nodes = $transition_node->findnodes('./affects/param'); + my @parameters; + my %affects; + + my @source_states = map { $_->textContent } @src_nodes; + + for my $param_node (@param_nodes) { + my @value_nodes = $param_node->findnodes('./value'); + my $param = { + name => $param_node->getAttribute('name'), + values => [ map { $_->textContent } @value_nodes ], + }; + push( @parameters, $param ); + } + + for my $param_node (@affected_nodes) { + my $param_name = $param_node->getAttribute('name'); + my $param_value = $param_node->getAttribute('value'); + $affects{$param_name} = $param_value; + } + + my $transition = { + name => $transition_node->getAttribute('name'), + duration => { static => 0+($transition_node->getAttribute('duration') // 0) }, + energy => { static => 0+($transition_node->getAttribute('energy') // 0) }, + rel_energy => { static => 0+($transition_node->getAttribute('rel_energy') // 0) }, + parameters => [@parameters], + origins => [@source_states], + destination => $dst_node->textContent, + level => $level_node->textContent, + id => $transition_index, + affects => {%affects}, + node => $transition_node, + }; + + for my $fun_node ( $transition_node->findnodes('./timeoutfunction/*') ) + { + my $name = $fun_node->nodeName; + my $function = $fun_node->textContent; + $function =~ s{^ \n* \s* }{}x; + $function =~ s{\s* \n* $}{}x; + $transition->{timeout}{function}{$name}{raw} = $function; + $transition->{timeout}{function}{$name}{node} = $fun_node; + my $attrindex = 0; + while ( $fun_node->hasAttribute("param${attrindex}") ) { + push( + @{ $transition->{timeout}{function}{$name}{params} }, + $fun_node->getAttribute("param${attrindex}") + ); + $attrindex++; + } + } + + for my $fun_node ( $transition_node->findnodes('./durationfunction/*') ) + { + my $name = $fun_node->nodeName; + my $function = $fun_node->textContent; + $function =~ s{^ \n* \s* }{}x; + $function =~ s{\s* \n* $}{}x; + $transition->{duration}{function}{$name}{raw} = $function; + $transition->{duration}{function}{$name}{node} = $fun_node; + my $attrindex = 0; + while ( $fun_node->hasAttribute("param${attrindex}") ) { + push( + @{ $transition->{duration}{function}{$name}{params} }, + $fun_node->getAttribute("param${attrindex}") + ); + $attrindex++; + } + } + + for my $fun_node ( $transition_node->findnodes('./energyfunction/*') ) + { + my $name = $fun_node->nodeName; + my $function = $fun_node->textContent; + $function =~ s{^ \n* \s* }{}x; + $function =~ s{\s* \n* $}{}x; + $transition->{energy}{function}{$name}{raw} = $function; + $transition->{energy}{function}{$name}{node} = $fun_node; + my $attrindex = 0; + while ( $fun_node->hasAttribute("param${attrindex}") ) { + push( + @{ $transition->{energy}{function}{$name}{params} }, + $fun_node->getAttribute("param${attrindex}") + ); + $attrindex++; + } + } + + for my $fun_node ( $transition_node->findnodes('./rel_energyfunction/*') ) + { + my $name = $fun_node->nodeName; + my $function = $fun_node->textContent; + $function =~ s{^ \n* \s* }{}x; + $function =~ s{\s* \n* $}{}x; + $transition->{rel_energy}{function}{$name}{raw} = $function; + $transition->{rel_energy}{function}{$name}{node} = $fun_node; + my $attrindex = 0; + while ( $fun_node->hasAttribute("param${attrindex}") ) { + push( + @{ $transition->{rel_energy}{function}{$name}{params} }, + $fun_node->getAttribute("param${attrindex}") + ); + $attrindex++; + } + } + + push( @{ $self->{transitions} }, $transition ); + + $transition_index++; + } + + if ( my ($node) = $xml->findnodes('/data/startup/code') ) { + $self->{startup}{code} = $node->textContent; + } + if ( my ($node) = $xml->findnodes('/data/after-transition/code') ) { + $self->{after_transition}{code} = $node->textContent; + } + for my $node ( $xml->findnodes('/data/after-transition/if') ) { + my $state = $node->getAttribute('state'); + for my $transition ( $node->findnodes('./transition') ) { + my $name = $transition->getAttribute('name'); + push( @{ $self->{after_transition}{in_state}{$state} }, $name ); + } + } + if ( my ($node) = $xml->findnodes('/data/shutdown/code') ) { + $self->{shutdown}{code} = $node->textContent; + } + + return $self; +} + +sub reset { + my ($self) = @_; + + for my $state (values %{$self->{states}}) { + $state->{node}->removeAttribute('power'); + for my $list_node (@{$state->{node}->findnodes('./powerfunction')}) { + for my $fun_name (keys %{$state->{power}{function}}) { + my $fun_node = $state->{power}{function}{$fun_name}{node}; + if ($fun_node->nodeName eq 'user') { + for my $attrnode ($fun_node->attributes) { + $attrnode->setValue(1); + } + } + else { + $list_node->removeChild($fun_node); + } + } + } + } + for my $transition (@{$self->{transitions}}) { + $transition->{node}->removeAttribute('duration'); + $transition->{node}->removeAttribute('energy'); + $transition->{node}->removeAttribute('rel_energy'); + for my $list_node (@{$transition->{node}->findnodes('./timeoutfunction')}) { + for my $fun_name (keys %{$transition->{timeout}{function}}) { + my $fun_node = $transition->{timeout}{function}{$fun_name}{node}; + if ($fun_node->nodeName eq 'user') { + for my $attrnode ($fun_node->attributes) { + $attrnode->setValue(1); + } + } + else { + $list_node->removeChild($fun_node); + } + } + } + } +} + +sub set_state_power { + my ( $self, $state, $power ) = @_; + + $power = sprintf( '%.f', $power ); + + printf( "state %-16s: adjust power %d -> %d µW\n", + $state, $self->{states}{$state}{power}{static}, $power ); + + $self->{states}{$state}{power}{static} = $power; + $self->{states}{$state}{node}->setAttribute( 'power', $power ); +} + +sub set_state_params { + my ( $self, $state, $fun_name, $function, @params ) = @_; + my $old_params = 'None'; + + if ( exists $self->{states}{$state}{power}{function}{$fun_name} ) { + $old_params = join( q{ }, + @{ $self->{states}{$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 ) ); + + if ( not defined $self->{states}{$state}{power}{function}{$fun_name}{node} ) + { + my ($fun_node) + = $self->{states}{$state}{node}->findnodes('./powerfunction'); + if ($fun_node) { + my $new_node = XML::LibXML::Element->new($fun_name); + $self->{states}{$state}{power}{function}{$fun_name}{node} + = $new_node; + $fun_node->appendChild($new_node); + } + else { + say + ' skipping XML write-back because of missing powerfunction node'; + return; + } + } + + if ( defined $function ) { + my $cdata_node = XML::LibXML::CDATASection->new($function); + $self->{states}{$state}{power}{function}{$fun_name}{node} + ->removeChildNodes; + $self->{states}{$state}{power}{function}{$fun_name}{node} + ->appendChild($cdata_node); + } + + for my $i ( 0 .. $#params ) { + $self->{states}{$state}{power}{function}{$fun_name}{params}[$i] + = $params[$i]; + $self->{states}{$state}{power}{function}{$fun_name}{node} + ->setAttribute( "param$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 ) ); + + if ( not defined $transition->{$fun_type}{function}{$fun_name}{node} ) { + my ($fun_node) = $transition->{node}->findnodes("./${fun_type}function"); + if ($fun_node) { + my $new_node = XML::LibXML::Element->new($fun_name); + $transition->{$fun_type}{function}{$fun_name}{node} = $new_node; + $fun_node->appendChild($new_node); + } + else { + say +" skipping XML write-back because of missing ${fun_type}function node"; + return; + } + } + + if ( defined $function ) { + my $cdata_node = XML::LibXML::CDATASection->new($function); + $transition->{$fun_type}{function}{$fun_name}{node}->removeChildNodes; + $transition->{$fun_type}{function}{$fun_name}{node} + ->appendChild($cdata_node); + } + + for my $i ( 0 .. $#params ) { + $transition->{$fun_type}{function}{$fun_name}{params}[$i] = $params[$i]; + $transition->{$fun_type}{function}{$fun_name}{node} + ->setAttribute( "param$i", $params[$i] ); + } +} + +sub set_transition_data { + my ( $self, $transition_name, $duration, $energy, $rel_energy ) = @_; + + my $transition = $self->get_transition_by_name($transition_name); + $duration = sprintf( '%.f', $duration ); + $energy = sprintf( '%.f', $energy ); + + printf( 'transition %-16s: adjust duration %d -> %d µs', + $transition->{name}, $transition->{duration}{static}, $duration); + $transition->{duration}{static} = $duration; + $transition->{node}->setAttribute('duration', $duration); + + printf( ', absolute energy %d -> %d pJ', + $transition->{energy}{static}, $energy ); + + $transition->{energy}{static} = $energy; + $transition->{node}->setAttribute( 'energy', $energy ); + + if (defined $rel_energy) { + $rel_energy = sprintf('%.f', $rel_energy); + printf( ", relative energy %d -> %d pJ\n", + $transition->{rel_energy}{static}, $rel_energy ); + + $transition->{rel_energy}{static} = $rel_energy; + $transition->{node}->setAttribute( 'rel_energy', $rel_energy ); + } + else { + print("\n"); + } +} + +sub save { + my ($self) = @_; + + $self->{xml}->toFile( $self->{xml_file} ); +} + +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->{startup}{code} // q{}; +} + +sub after_transition_code { + my ($self) = @_; + + return $self->{after_transition}{code} // q{}; +} + +sub get_state_extra_transitions { + my ( $self, $state ) = @_; + + return @{ $self->{after_transition}{in_state}{$state} // [] }; +} + +sub shutdown_code { + my ($self) = @_; + + return $self->{shutdown}{code} // q{}; +} + +sub get_transition_by_name { + my ( $self, $name ) = @_; + + my $transition = first { $_->{name} eq $name } @{ $self->{transitions} }; + + return $transition; +} + +sub get_transition_by_id { + my ( $self, $id ) = @_; + + return $self->{transitions}[$id]; +} + +sub get_state_id { + my ( $self, $name ) = @_; + + return $self->{states}{$name}{id}; +} + +sub get_state_name { + my ( $self, $id ) = @_; + + return ( $self->get_state_enum )[$id]; +} + +sub get_state_power { + my ( $self, $name ) = @_; + + return $self->{states}{$name}{power}{static}; +} + +sub get_state_enum { + my ($self) = @_; + + if ( not exists $self->{state_enum} ) { + @{ $self->{state_enum} } + = sort { $self->{states}{$a}{id} <=> $self->{states}{$b}{id} } + keys %{ $self->{states} }; + } + + return @{ $self->{state_enum} }; +} + +sub transitions { + my ($self) = @_; + + return @{ $self->{transitions} }; +} + +sub TO_JSON { + my ($self) = @_; + + my %state_copy + = map { $_ => { %{ $self->{states}{$_} } } } keys %{ $self->{states} }; + my %transition_copy + = map { $_->{name} => { %{$_} } } @{ $self->{transitions} }; + + for my $val ( values %state_copy ) { + delete $val->{node}; + if ( exists $val->{power}{function} ) { + $val->{power} = { %{ $val->{power} } }; + $val->{power}{function} = { %{ $val->{power}{function} } }; + for my $key ( keys %{ $val->{power}{function} } ) { + $val->{power}{function}{$key} + = { %{ $val->{power}{function}{$key} } }; + delete $val->{power}{function}{$key}{node}; + } + } + } + for my $val ( values %transition_copy ) { + delete $val->{node}; + for my $key (qw(duration energy rel_energy timeout)) { + if ( exists $val->{$key}{function} ) { + $val->{$key} = { %{ $val->{$key} } }; + $val->{$key}{function} = { %{ $val->{$key}{function} } }; + for my $ftype ( keys %{ $val->{$key}{function} } ) { + $val->{$key}{function}{$ftype} + = { %{ $val->{$key}{function}{$ftype} } }; + delete $val->{$key}{function}{$ftype}{node}; + } + } + } + } + + my $json = { + parameter => $self->{parameter}, + state => {%state_copy}, + transition => {%transition_copy}, + }; + + return $json; +} + +1; diff --git a/lib/MIMOSA.pm b/lib/MIMOSA.pm new file mode 100644 index 0000000..54a5e15 --- /dev/null +++ b/lib/MIMOSA.pm @@ -0,0 +1,177 @@ +package MIMOSA; + +use strict; +use warnings; +use 5.020; + +use Carp; +use Carp::Assert::More; +use File::Slurp qw(read_dir); +use IPC::Run qw(harness); +use List::Util qw(max); + +our $VERSION = '0.00'; + +sub new { + my ( $class, %opt ) = @_; + + my $self = \%opt; + + bless( $self, $class ); + + return $self; +} + +sub start { + my ($self) = @_; + my $buf; + + my $mim_daemon = harness( + [ 'MimosaCMD', '--start' ], + '<' => \undef, + '>&' => \$buf + ); + my $mim_p1 = harness( + [ 'MimosaCMD', '--parameter', 'offset', $self->{mimosa_offset} ], + '<' => \undef, + '>&' => \$buf + ); + my $mim_p2 = harness( + [ 'MimosaCMD', '--parameter', 'shunt', $self->{mimosa_shunt} ], + '<' => \undef, + '>&' => \$buf + ); + my $mim_p3 = harness( + [ 'MimosaCMD', '--parameter', 'voltage', $self->{mimosa_voltage} ], + '<' => \undef, + '>&' => \$buf + ); + my $mim_p4 = harness( + [ 'MimosaCMD', '--parameter', 'directory', 'src/apps/DriverEval' ], + '<' => \undef, + '>&' => \$buf + ); + my $mim_start = harness( + [ 'MimosaCMD', '--mimosa-start' ], + '<' => \undef, + '>&' => \$buf + ); + + if ( $self->is_running ) { + croak("MIMOSA daemon is already running"); + } + + $mim_daemon->run or croak(); + $mim_p1->run or croak(); + $mim_p2->run or croak(); + $mim_p3->run or croak(); + $mim_start->run or croak(); +} + +sub is_running { + my ($self) = @_; + + my $buf; + + my $mim_check = harness( + [ 'pidof', 'MimosaCMD' ], + '<' => \undef, + '>&' => \$buf + ); + + return $mim_check->run; +} + +sub stop { + my ($self) = @_; + my $buf; + + my $mim_stop = harness( + [ 'MimosaCMD', '--mimosa-stop' ], + '<' => \undef, + '>&' => \$buf + ); + my $mim_kill = harness( + [ 'MimosaCMD', '--stop' ], + '<' => \undef, + '>&' => \$buf + ); + + # make sure MIMOSA has all teh data + sleep(5); + + $mim_stop->run or croak(); + + $self->wait_for_save; + + $mim_kill->run or croak(); + + while ( $self->is_running ) { + sleep(1); + } +} + +sub wait_for_save { + my ($self) = @_; + + my $mtime = 0; + my $mtime_changed = 1; + + while ($mtime_changed) { + sleep(3); + my @mim_files = grep { m{ \. mim $ }x } read_dir('.'); + my @mtimes = map { ( stat($_) )[9] } @mim_files; + my $new_mtime = max @mtimes; + if ( $new_mtime != $mtime ) { + $mtime = $new_mtime; + } + else { + $mtime_changed = 0; + } + } + + return $self; +} + +sub kill { + my ($self) = @_; + my $buf; + + my $mim_kill = harness( + [ 'MimosaCMD', '--stop' ], + '<' => \undef, + '>&' => \$buf + ); + + $mim_kill->run or croak(); +} + +sub calibrate { + my ($self) = @_; + + $self->mimosactl('disconnect'); + sleep(2); + $self->mimosactl('1k'); # actually 987 Ohm + sleep(2); + $self->mimosactl('100k'); # actually 99.3 kOhm + sleep(2); + $self->mimosactl('connect'); +} + +sub mimosactl { + my ( $self, $arg ) = @_; + my $buf; + + my $mimosactl = harness( + [ 'mimosactl', $arg ], + '<' => \undef, + '>&' => \$buf + ); + + $mimosactl->run + or croak( "mimosactl $arg returned " . $mimosactl->full_result ); + + return $self; +} + +1; diff --git a/lib/MIMOSA/Log.pm b/lib/MIMOSA/Log.pm new file mode 100644 index 0000000..4f7c6a2 --- /dev/null +++ b/lib/MIMOSA/Log.pm @@ -0,0 +1,388 @@ +package MIMOSA::Log; + +use strict; +use warnings; +use 5.020; + +use Archive::Tar; +use Carp; +use File::Slurp qw(read_file read_dir write_file); +use JSON; +use List::Util qw(sum); + +#use Statistics::Basic::Mean; +#use Statistics::Basic::StdDev; + +our $VERSION = '0.00'; +my $CACHE_VERSION = 5; + +sub new { + my ( $class, %opt ) = @_; + + my $self = \%opt; + + $self->{tmpdir} = "/tmp/kratos-dfa-mim-$$"; + + if ( $opt{tmpsuffix} ) { + $self->{tmpdir} .= "-$opt{tmpsuffix}"; + } + + bless( $self, $class ); + + return $self; +} + +sub tar { + my ($self) = @_; + + $self->{tar} //= Archive::Tar->new( $self->{data_file} ); + + return $self->{tar}; +} + +sub setup { + my ($self) = @_; + + return $self->{setup}; +} + +sub load { + return new(@_); +} + +sub DESTROY { + my ($self) = @_; + + if ( -d $self->{tmpdir} ) { + for my $file ( read_dir( $self->{tmpdir} ) ) { + unlink("$self->{tmpdir}/$file"); + } + rmdir( $self->{tmpdir} ); + } +} + +sub load_archive { + my ($self) = @_; + + my $tmpdir = $self->{tmpdir}; + + my @filelist = $self->tar->list_files; + my @mim_files = sort grep { m{ \. mim $ }x } @filelist; + my @json_files = map { ( split( qr{[.]}, $_ ) )[0] . '.json' } @mim_files; + + if ( $self->{fast_analysis} ) { + splice( @mim_files, 4 ); + splice( @json_files, 4 ); + } + + $self->{filelist} = [@filelist]; + $self->{mim_files} = [@mim_files]; + $self->{mim_results} = [@json_files]; + + $self->{log}{traces} = JSON->new->decode( + $self->tar->get_content('src/apps/DriverEval/DriverLog.json') ); + $self->{setup} = JSON->new->decode( $self->tar->get_content('setup.json') ); + + mkdir($tmpdir); + + for my $file (@mim_files) { + $self->tar->extract_file( $file, "${tmpdir}/${file}" ); + } +} + +sub load_cache { + my ($self) = @_; + my $tmpdir = $self->{tmpdir}; + my ( $dirname, $basename ) + = ( $self->{data_file} =~ m{ ^ (.*) / ([^/]+) . tar $ }x ); + my $cachefile = "${dirname}/cache/${basename}.json"; + + if ( -e $cachefile ) { + mkdir($tmpdir); + write_file( $self->json_name, read_file($cachefile) ); + my $json = JSON->new->decode( read_file($cachefile) ); + if ( $json->{version} != $CACHE_VERSION ) { + return 0; + } + $self->{setup} = $json->{setup}; + return 1; + } + return 0; +} + +sub save_cache { + my ($self) = @_; + my $tmpdir = $self->{tmpdir}; + my ( $dirname, $basename ) + = ( $self->{data_file} =~ m{ ^ (.*) / ([^/]+) . tar $ }x ); + my $cachefile = "${dirname}/cache/${basename}.json"; + + if ( not -d "${dirname}/cache" ) { + mkdir("${dirname}/cache"); + } + + write_file( $cachefile, read_file( $self->json_name ) ); +} + +sub num_iterations { + my ($self) = @_; + + return scalar @{ $self->{mim_files} }; +} + +sub sched_trigger_count { + my ($self) = @_; + + if ( not $self->{sched_trigger_count} ) { + $self->{sched_trigger_count} = 0; + for my $run ( @{ $self->{log}{traces} } ) { + $self->{sched_trigger_count} += @{ $run->{trace} }; + } + } + + return $self->{sched_trigger_count}; +} + +sub merge { + my ( $self, $file ) = @_; + + if ( not -e $file ) { + return "Does not exist"; + } + + my $data = JSON->new->decode( read_file($file) ); + my $trig_count = $data->{triggers}; + if ( $self->sched_trigger_count != $trig_count ) { + return sprintf( 'Expected %d trigger edges, got %d', + $self->sched_trigger_count, $trig_count ); + } + + #printf("calibration check at: %.f±%.f %.f±%.f %.f±%.f\n", + # $data->{calibration}{r0_mean}, + # $data->{calibration}{r0_std}, + # $data->{calibration}{r2_mean}, + # $data->{calibration}{r2_std}, + # $data->{calibration}{r1_mean}, + # $data->{calibration}{r1_std}, + #); + + # verify that state duration really is < 1.5 * setup{state_duration} and > + # 0.5 * setup{state_duration}. otherwise we may have missed a trigger, + # which wasn't detected earlier because of duplicate triggers elsewhere. + my $data_idx = 0; + for my $run ( @{ $self->{log}{traces} } ) { + my $prev_elem = {name => q{}}; + for my $trace_elem ( @{ $run->{trace} } ) { + my $log_elem = $data->{trace}[$data_idx]; + if ($log_elem->{isa} eq 'state' + and $trace_elem->{name} ne 'UNINITIALIZED' + and $log_elem->{us} > $self->{setup}{state_duration} * 1500 + and $prev_elem->{name} ne 'txDone' + and $prev_elem->{name} ne 'epilogue') { + return sprintf('State %s (trigger index %d) took %.1f ms longer than expected', + $trace_elem->{name}, $data_idx, + ($log_elem->{us} / 1000) - $self->{setup}{state_duration} + ); + } + if ($log_elem->{isa} eq 'state' + and $trace_elem->{name} ne 'UNINITIALIZED' + and $trace_elem->{name} ne 'TX' + and $log_elem->{us} < $self->{setup}{state_duration} * 500 ) { + return sprintf('State %s (trigger index %d) was %.1f ms shorter than expected', + $trace_elem->{name}, $data_idx, + $self->{setup}{state_duration} - ($log_elem->{us} / 1000) + ); + } + $prev_elem = $trace_elem; + $data_idx++; + } + } + + $data_idx = 0; + for my $run ( @{ $self->{log}{traces} } ) { + for my $trace_elem ( @{ $run->{trace} } ) { + if ( $data->{trace}[$data_idx]{isa} ne $trace_elem->{isa} ) { + croak(); + } + delete $data->{trace}[$data_idx]{isa}; + push( @{ $trace_elem->{offline} }, $data->{trace}[$data_idx] ); + $data_idx++; + } + } + + push( @{ $self->{log}{calibration} }, $data->{calibration} ); + + return; +} + +sub preprocess { + my ($self) = @_; + my $tmpdir = $self->{tmpdir}; + my @files = @{ $self->{mim_files} }; + my $shunt = $self->{setup}{mimosa_shunt}; + my $voltage = $self->{setup}{mimosa_voltage}; + my @errmap; + + @files = map { "${tmpdir}/$_" } @files; + + if ( qx{parallel --version 2> /dev/null} =~ m{GNU parallel} ) { + system( qw(parallel ../dfatool/bin/analyze.py), + $voltage, $shunt, ':::', @files ); + } + else { + system( qw(parallel ../dfatool/bin/analyze.py), + $voltage, $shunt, '--', @files ); + } + + for my $i ( 0 .. $#{ $self->{mim_results} } ) { + my $file = $self->{mim_results}[$i]; + my $error = $self->merge("${tmpdir}/${file}"); + + if ($error) { + say "${file}: ${error}"; + push(@errmap, $i); + } + } + + if ( @errmap == @files ) { + die("All MIMOSA measurements were erroneous. Aborting.\n"); + } + + $self->{log}{model} = $self->{model}; + $self->{log}{errmap} = \@errmap; + $self->{log}{setup} = $self->{setup}; + $self->{log}{version} = $CACHE_VERSION; + write_file( $self->json_name, + JSON->new->convert_blessed->encode( $self->{log} ) ); +} + +sub analyze { + my ( $self, @extra_files ) = @_; + my $tmpdir = $self->{tmpdir}; + + @extra_files = grep { $_ ne $self->json_name } @extra_files; + + for my $file ( $self->json_name, @extra_files ) { + my $json = JSON->new->decode( read_file($file) ); + $json->{model} = $self->{model}; + +# fix for incomplete json files: transitions can also depend on global parameters + for my $run ( @{ $json->{traces} } ) { + for my $i ( 0 .. $#{ $run->{trace} } ) { + $run->{trace}[$i]{parameter} + //= $run->{trace}[ $i - 1 ]{parameter}; + } + } + + write_file( $file, JSON->new->convert_blessed->encode($json) ); + } + + system( '../dfatool/bin/merge.py', @{ $self->{merge_args} // [] }, + $self->json_name, @extra_files ); + + my $json = JSON->new->decode( read_file( $self->json_name ) ); + + $self->{aggregate} = $json->{aggregate}; + + # debug + write_file( "/tmp/DriverLog.json", JSON->new->pretty->encode($json) ); +} + +sub validate { + my ( $self, @extra_files ) = @_; + my $tmpdir = $self->{tmpdir}; + + @extra_files = grep { $_ ne $self->json_name } @extra_files; + + for my $file ( $self->json_name, @extra_files ) { + my $json = JSON->new->decode( read_file($file) ); + $json->{model} = $self->{model}; + my @errmap = @{ $json->{errmap} // [] }; + +# fix for incomplete json files: transitions can also depend on global parameters + for my $run ( @{ $json->{traces} } ) { + for my $i ( 0 .. $#{ $run->{trace} } ) { + $run->{trace}[$i]{parameter} + //= $run->{trace}[ $i - 1 ]{parameter}; + } + } + # online durations count current state + next transition, but we + # only want to analyze current state -> substract next transition. + # Note that we can only do this on online data which has + # corresponding offline data, i.e. where the offline data was not + # erroneous + for my $run ( @{ $json->{traces} } ) { + if (exists $run->{total_energy}) { + # splice changes the array (and thus the indices). so we need to + # start removing elements at the end + for my $erridx (reverse @errmap) { + splice(@{$run->{total_energy}}, $erridx, 1); + } + } + for my $i ( 0 .. $#{ $run->{trace} } ) { + for my $erridx (reverse @errmap) { + splice(@{$run->{trace}[$i]{online}}, $erridx, 1); + } + if ($run->{trace}[$i]{isa} eq 'state') { + for my $j (0 .. $#{ $run->{trace}[$i]{online} } ) { + $run->{trace}[$i]{online}[$j]{time} -= + $run->{trace}[$i+1]{offline}[$j]{us}; + } + } + } + } + + write_file( $file, JSON->new->convert_blessed->encode($json) ); + } + + system( '../dfatool/bin/merge.py', @{ $self->{merge_args} // [] }, + '--validate', $self->json_name, @extra_files ); + + my $json = JSON->new->decode( read_file( $self->json_name ) ); + + $self->{aggregate} = $json->{aggregate}; + + # debug + write_file( "/tmp/DriverLog.json", JSON->new->pretty->encode($json) ); +} + +sub crossvalidate { + my ( $self, @extra_files ) = @_; + my $tmpdir = $self->{tmpdir}; + + @extra_files = grep { $_ ne $self->json_name } @extra_files; + + for my $file ( $self->json_name, @extra_files ) { + my $json = JSON->new->decode( read_file($file) ); + $json->{model} = $self->{model}; + +# fix for incomplete json files: transitions can also depend on global parameters + for my $run ( @{ $json->{traces} } ) { + for my $i ( 0 .. $#{ $run->{trace} } ) { + $run->{trace}[$i]{parameter} + //= $run->{trace}[ $i - 1 ]{parameter}; + } + } + + write_file( $file, JSON->new->convert_blessed->encode($json) ); + } + + system( '../dfatool/bin/merge.py', @{ $self->{merge_args} // [] }, + '--crossvalidate', $self->json_name, @extra_files ); +} + +sub data { + my ($self) = @_; + my $tmpdir = $self->{tmpdir}; + my $json = JSON->new->decode( read_file( $self->json_name ) ); + return $json; +} + +sub json_name { + my ($self) = @_; + my $tmpdir = $self->{tmpdir}; + + return "${tmpdir}/DriverLog.json"; +} + +1; diff --git a/lib/dfatool.py b/lib/dfatool.py new file mode 100755 index 0000000..8a07b50 --- /dev/null +++ b/lib/dfatool.py @@ -0,0 +1,291 @@ +#!/usr/bin/env python3 + +import csv +from itertools import chain, combinations +import json +import numpy as np +import os +from scipy.cluster.vq import kmeans2 +import struct +import sys +import tarfile + +def running_mean(x, N): + cumsum = np.cumsum(np.insert(x, 0, 0)) + return (cumsum[N:] - cumsum[:-N]) / N + +def is_numeric(n): + try: + int(n) + return True + except ValueError: + return False + +def aggregate_measures(aggregate, actual): + aggregate_array = np.array([aggregate] * len(actual)) + return regression_measures(aggregate_array, np.array(actual)) + +def regression_measures(predicted, actual): + deviations = predicted - actual + measures = { + 'mae' : np.mean(np.abs(deviations), dtype=np.float64), + 'msd' : np.mean(deviations**2, dtype=np.float64), + 'rmsd' : np.sqrt(np.mean(deviations**2), dtype=np.float64), + 'ssr' : np.sum(deviations**2, dtype=np.float64), + } + + if np.all(actual != 0): + measures['mape'] = np.mean(np.abs(deviations / actual)) * 100 # bad measure + if np.all(np.abs(predicted) + np.abs(actual) != 0): + measures['smape'] = np.mean(np.abs(deviations) / (( np.abs(predicted) + np.abs(actual)) / 2 )) * 100 + + return measures + +def powerset(iterable): + s = list(iterable) + return chain.from_iterable(combinations(s, r) for r in range(len(s)+1)) + +class Keysight: + + def __init__(self): + pass + + def load_data(self, filename): + with open(filename) as f: + for i, l in enumerate(f): + pass + timestamps = np.ndarray((i-3), dtype=float) + currents = np.ndarray((i-3), dtype=float) + # basically seek back to start + with open(filename) as f: + for _ in range(4): + next(f) + reader = csv.reader(f, delimiter=',') + for i, row in enumerate(reader): + timestamps[i] = float(row[0]) + currents[i] = float(row[2]) * -1 + return timestamps, currents + +class MIMOSA: + + def __init__(self, voltage, shunt): + self.voltage = voltage + self.shunt = shunt + self.r1 = 984 # "1k" + self.r2 = 99013 # "100k" + + def charge_to_current_nocal(self, charge): + ua_max = 1.836 / self.shunt * 1000000 + ua_step = ua_max / 65535 + return charge * ua_step + + def load_data(self, filename): + with tarfile.open(filename) as tf: + num_bytes = tf.getmember('/tmp/mimosa//mimosa_scale_1.tmp').size + charges = np.ndarray(shape=(int(num_bytes / 4)), dtype=np.int32) + triggers = np.ndarray(shape=(int(num_bytes / 4)), dtype=np.int8) + with tf.extractfile('/tmp/mimosa//mimosa_scale_1.tmp') as f: + content = f.read() + iterator = struct.iter_unpack('<I', content) + i = 0 + for word in iterator: + charges[i] = (word[0] >> 4) + triggers[i] = (word[0] & 0x08) >> 3 + i += 1 + return (charges, triggers) + + def currents_nocal(self, charges): + ua_max = 1.836 / self.shunt * 1000000 + ua_step = ua_max / 65535 + return charges.astype(np.double) * ua_step + + def trigger_edges(self, triggers): + trigidx = [] + prevtrig = triggers[0] + # the device is reset for MIMOSA calibration in the first 10s and may + # send bogus interrupts -> bogus triggers + for i in range(1000000, triggers.shape[0]): + trig = triggers[i] + if trig != prevtrig: + # Due to MIMOSA's integrate-read-reset cycle, the trigger + # appears two points (20µs) before the corresponding data + trigidx.append(i+2) + prevtrig = trig + return trigidx + + def calibration_edges(self, currents): + r1idx = 0 + r2idx = 0 + ua_r1 = self.voltage / self.r1 * 1000000 + # first second may be bogus + for i in range(100000, len(currents)): + if r1idx == 0 and currents[i] > ua_r1 * 0.6: + r1idx = i + elif r1idx != 0 and r2idx == 0 and i > (r1idx + 180000) and currents[i] < ua_r1 * 0.4: + r2idx = i + # 2s disconnected, 2s r1, 2s r2 with r1 < r2 -> ua_r1 > ua_r2 + # allow 5ms buffer in both directions to account for bouncing relais contacts + return r1idx - 180500, r1idx - 500, r1idx + 500, r2idx - 500, r2idx + 500, r2idx + 180500 + + def calibration_function(self, charges, cal_edges): + dis_start, dis_end, r1_start, r1_end, r2_start, r2_end = cal_edges + if dis_start < 0: + dis_start = 0 + chg_r0 = charges[dis_start:dis_end] + chg_r1 = charges[r1_start:r1_end] + chg_r2 = charges[r2_start:r2_end] + cal_0_mean = np.mean(chg_r0) + cal_0_std = np.std(chg_r0) + cal_r1_mean = np.mean(chg_r1) + cal_r1_std = np.std(chg_r1) + cal_r2_mean = np.mean(chg_r2) + cal_r2_std = np.std(chg_r2) + + ua_r1 = self.voltage / self.r1 * 1000000 + ua_r2 = self.voltage / self.r2 * 1000000 + + b_lower = (ua_r2 - 0) / (cal_r2_mean - cal_0_mean) + b_upper = (ua_r1 - ua_r2) / (cal_r1_mean - cal_r2_mean) + b_total = (ua_r1 - 0) / (cal_r1_mean - cal_0_mean) + + a_lower = -b_lower * cal_0_mean + a_upper = -b_upper * cal_r2_mean + a_total = -b_total * cal_0_mean + + if self.shunt == 680: + # R1 current is higher than shunt range -> only use R2 for calibration + def calfunc(charge): + if charge < cal_0_mean: + return 0 + else: + return charge * b_lower + a_lower + else: + def calfunc(charge): + if charge < cal_0_mean: + return 0 + if charge <= cal_r2_mean: + return charge * b_lower + a_lower + else: + return charge * b_upper + a_upper + ua_r2 + + caldata = { + 'edges' : [x * 10 for x in cal_edges], + 'offset': cal_0_mean, + 'offset2' : cal_r2_mean, + 'slope_low' : b_lower, + 'slope_high' : b_upper, + 'add_low' : a_lower, + 'add_high' : a_upper, + 'r0_err_uW' : np.mean(self.currents_nocal(chg_r0)) * self.voltage, + 'r0_std_uW' : np.std(self.currents_nocal(chg_r0)) * self.voltage, + 'r1_err_uW' : (np.mean(self.currents_nocal(chg_r1)) - ua_r1) * self.voltage, + 'r1_std_uW' : np.std(self.currents_nocal(chg_r1)) * self.voltage, + 'r2_err_uW' : (np.mean(self.currents_nocal(chg_r2)) - ua_r2) * self.voltage, + 'r2_std_uW' : np.std(self.currents_nocal(chg_r2)) * self.voltage, + } + + #print("if charge < %f : return 0" % cal_0_mean) + #print("if charge <= %f : return charge * %f + %f" % (cal_r2_mean, b_lower, a_lower)) + #print("else : return charge * %f + %f + %f" % (b_upper, a_upper, ua_r2)) + + return calfunc, caldata + + def calcgrad(self, currents, threshold): + grad = np.gradient(running_mean(currents * self.voltage, 10)) + # len(grad) == len(currents) - 9 + subst = [] + lastgrad = 0 + for i in range(len(grad)): + # minimum substate duration: 10ms + if np.abs(grad[i]) > threshold and i - lastgrad > 50: + # account for skew introduced by running_mean and current + # ramp slope (parasitic capacitors etc.) + subst.append(i+10) + lastgrad = i + if lastgrad != i: + subst.append(i+10) + return subst + + # TODO konfigurierbare min/max threshold und len(gradidx) > X, binaere + # Sache nach noetiger threshold. postprocessing mit + # "zwei benachbarte substates haben sehr aehnliche werte / niedrige stddev" -> mergen + # ... min/max muessen nicht vorgegeben werden, sind ja bekannt (0 / np.max(grad)) + # TODO bei substates / index foo den offset durch running_mean beachten + # TODO ggf. clustering der 'abs(grad) > threshold' und bestimmung interessanter + # uebergaenge dadurch? + def gradfoo(self, currents): + gradients = np.abs(np.gradient(running_mean(currents * self.voltage, 10))) + gradmin = np.min(gradients) + gradmax = np.max(gradients) + threshold = np.mean([gradmin, gradmax]) + gradidx = self.calcgrad(currents, threshold) + num_substates = 2 + while len(gradidx) != num_substates: + if gradmax - gradmin < 0.1: + # We did our best + return threshold, gradidx + if len(gradidx) > num_substates: + gradmin = threshold + else: + gradmax = threshold + threshold = np.mean([gradmin, gradmax]) + gradidx = self.calcgrad(currents, threshold) + return threshold, gradidx + + def analyze_states(self, charges, trigidx, ua_func): + previdx = 0 + is_state = True + iterdata = [] + for idx in trigidx: + range_raw = charges[previdx:idx] + range_ua = ua_func(range_raw) + substates = {} + + if previdx != 0 and idx - previdx > 200: + thr, subst = 0, [] #self.gradfoo(range_ua) + if len(subst): + statelist = [] + prevsubidx = 0 + for subidx in subst: + statelist.append({ + 'duration': (subidx - prevsubidx) * 10, + 'uW_mean' : np.mean(range_ua[prevsubidx : subidx] * self.voltage), + 'uW_std' : np.std(range_ua[prevsubidx : subidx] * self.voltage), + }) + prevsubidx = subidx + substates = { + 'threshold' : thr, + 'states' : statelist, + } + + isa = 'state' + if not is_state: + isa = 'transition' + + data = { + 'isa': isa, + 'clip_rate' : np.mean(range_raw == 65535), + 'raw_mean': np.mean(range_raw), + 'raw_std' : np.std(range_raw), + 'uW_mean' : np.mean(range_ua * self.voltage), + 'uW_std' : np.std(range_ua * self.voltage), + 'us' : (idx - previdx) * 10, + } + + if 'states' in substates: + data['substates'] = substates + ssum = np.sum(list(map(lambda x : x['duration'], substates['states']))) + if ssum != data['us']: + print("ERR: duration %d vs %d" % (data['us'], ssum)) + + if isa == 'transition': + # subtract average power of previous state + # (that is, the state from which this transition originates) + data['uW_mean_delta'] = data['uW_mean'] - iterdata[-1]['uW_mean'] + data['timeout'] = iterdata[-1]['us'] + + iterdata.append(data) + + previdx = idx + is_state = not is_state + return iterdata diff --git a/lib/plotter.py b/lib/plotter.py new file mode 100755 index 0000000..763fae5 --- /dev/null +++ b/lib/plotter.py @@ -0,0 +1,177 @@ +#!/usr/bin/env python3 + +import itertools +import numpy as np +import matplotlib.pyplot as plt +from matplotlib.patches import Polygon + +def flatten(somelist): + return [item for sublist in somelist for item in sublist] + +def is_state(aggregate, name): + return aggregate[name]['isa'] == 'state' and name != 'UNINITIALIZED' + +def plot_states(model, aggregate): + keys = [key for key in sorted(aggregate.keys()) if is_state(aggregate, key)] + data = [aggregate[key]['means'] for key in keys] + mdata = [int(model['state'][key]['power']['static']) for key in keys] + boxplot(keys, mdata, None, data, 'Zustand', 'µW') + +def plot_transitions(model, aggregate): + keys = [key for key in sorted(aggregate.keys()) if aggregate[key]['isa'] == 'transition'] + data = [aggregate[key]['rel_energies'] for key in keys] + mdata = [int(model['transition'][key]['rel_energy']['static']) for key in keys] + boxplot(keys, mdata, None, data, 'Transition', 'pJ (rel)') + data = [aggregate[key]['energies'] for key in keys] + mdata = [int(model['transition'][key]['energy']['static']) for key in keys] + boxplot(keys, mdata, None, data, 'Transition', 'pJ') + +def plot_states_duration(model, aggregate): + keys = [key for key in sorted(aggregate.keys()) if is_state(aggregate, key)] + data = [aggregate[key]['durations'] for key in keys] + boxplot(keys, None, None, data, 'Zustand', 'µs') + +def plot_transitions_duration(model, aggregate): + keys = [key for key in sorted(aggregate.keys()) if aggregate[key]['isa'] == 'transition'] + data = [aggregate[key]['durations'] for key in keys] + boxplot(keys, None, None, data, 'Transition', 'µs') + +def plot_transitions_timeout(model, aggregate): + keys = [key for key in sorted(aggregate.keys()) if aggregate[key]['isa'] == 'transition'] + data = [aggregate[key]['timeouts'] for key in keys] + boxplot(keys, None, None, data, 'Timeout', 'µs') + +def plot_states_clips(model, aggregate): + keys = [key for key in sorted(aggregate.keys()) if is_state(aggregate, key)] + data = [np.array([100]) * aggregate[key]['clip_rate'] for key in keys] + boxplot(keys, None, None, data, 'Zustand', '% Clipping') + +def plot_transitions_clips(model, aggregate): + keys = [key for key in sorted(aggregate.keys()) if aggregate[key]['isa'] == 'transition'] + data = [np.array([100]) * aggregate[key]['clip_rate'] for key in keys] + boxplot(keys, None, None, data, 'Transition', '% Clipping') + +def plot_substate_thresholds(model, aggregate): + keys = [key for key in sorted(aggregate.keys()) if is_state(aggregate, key)] + data = [aggregate[key]['sub_thresholds'] for key in keys] + boxplot(keys, None, None, data, 'Zustand', 'substate threshold (mW/dmW)') + +def plot_histogram(data): + n, bins, patches = plt.hist(data, 1000, normed=1, facecolor='green', alpha=0.75) + plt.show() + +def plot_states_param(model, aggregate): + keys = [key for key in sorted(aggregate.keys()) if aggregate[key]['isa'] == 'state' and key[0] != 'UNINITIALIZED'] + data = [aggregate[key]['means'] for key in keys] + mdata = [int(model['state'][key[0]]['power']['static']) for key in keys] + boxplot(keys, mdata, None, data, 'Transition', 'µW') + +def plot_substate_thresholds_p(model, aggregate): + keys = [key for key in sorted(aggregate.keys()) if aggregate[key]['isa'] == 'state' and key[0] != 'UNINITIALIZED'] + data = [aggregate[key]['sub_thresholds'] for key in keys] + boxplot(keys, None, None, data, 'Zustand', '% Clipping') + +def plot_param_fit(function, name, fitfunc, funp, parameters, datatype, index, X, Y, xaxis=None, yaxis=None): + fig, ax1 = plt.subplots(figsize=(10,6)) + fig.canvas.set_window_title("fit %s" % (function)) + plt.subplots_adjust(left=0.14, right=0.99, top=0.99, bottom=0.14) + xsp = np.linspace(X[index].min(), X[index].max(), 100) + + if xaxis != None: + ax1.set_xlabel(xaxis) + else: + ax1.set_xlabel(parameters[index]) + if yaxis != None: + ax1.set_ylabel(yaxis) + else: + ax1.set_ylabel('%s %s' % (name, datatype)) + + otherparams = list(set(itertools.product(*X[:index], *X[index+1:]))) + cm = plt.get_cmap('brg', len(otherparams)) + for i in range(len(otherparams)): + elem = otherparams[i] + color = cm(i) + + tt = np.full((len(X[index])), True, dtype=bool) + for k in range(len(parameters)): + if k < index: + tt &= X[k] == elem[k] + elif k > index: + tt &= X[k] == elem[k-1] + + plt.plot(X[index][tt], Y[tt], "rx", color=color) + + xarg = [np.array([x] * 100) for x in elem[:index]] + xarg.append(xsp) + xarg.extend([np.array([x] * 100) for x in elem[index:]]) + plt.plot(xsp, fitfunc(funp, xarg), "r-", color=color) + plt.show() + + +def boxplot(ticks, modeldata, onlinedata, mimosadata, xlabel, ylabel): + fig, ax1 = plt.subplots(figsize=(10,6)) + fig.canvas.set_window_title('DriverEval') + plt.subplots_adjust(left=0.1, right=0.95, top=0.95, bottom=0.1) + + bp = plt.boxplot(mimosadata, notch=0, sym='+', vert=1, whis=1.5) + plt.setp(bp['boxes'], color='black') + plt.setp(bp['whiskers'], color='black') + plt.setp(bp['fliers'], color='red', marker='+') + + ax1.yaxis.grid(True, linestyle='-', which='major', color='lightgrey', + alpha=0.5) + + ax1.set_axisbelow(True) + #ax1.set_title('DriverEval') + ax1.set_xlabel(xlabel) + ax1.set_ylabel(ylabel) + + numBoxes = len(mimosadata) + + xtickNames = plt.setp(ax1, xticklabels=ticks) + plt.setp(xtickNames, rotation=0, fontsize=10) + + boxColors = ['darkkhaki', 'royalblue'] + medians = list(range(numBoxes)) + for i in range(numBoxes): + box = bp['boxes'][i] + boxX = [] + boxY = [] + for j in range(5): + boxX.append(box.get_xdata()[j]) + boxY.append(box.get_ydata()[j]) + boxCoords = list(zip(boxX, boxY)) + # Alternate between Dark Khaki and Royal Blue + k = i % 2 + boxPolygon = Polygon(boxCoords, facecolor=boxColors[k]) + #ax1.add_patch(boxPolygon) + # Now draw the median lines back over what we just filled in + med = bp['medians'][i] + medianX = [] + medianY = [] + for j in range(2): + medianX.append(med.get_xdata()[j]) + medianY.append(med.get_ydata()[j]) + plt.plot(medianX, medianY, 'k') + medians[i] = medianY[0] + # Finally, overplot the sample averages, with horizontal alignment + # in the center of each box + plt.plot([np.average(med.get_xdata())], [np.average(mimosadata[i])], + color='w', marker='*', markeredgecolor='k') + if modeldata: + plt.plot([np.average(med.get_xdata())], [modeldata[i]], + color='w', marker='o', markeredgecolor='k') + + pos = np.arange(numBoxes) + 1 + upperLabels = [str(np.round(s, 2)) for s in medians] + weights = ['bold', 'semibold'] + for tick, label in zip(range(numBoxes), ax1.get_xticklabels()): + k = tick % 2 + y0, y1 = ax1.get_ylim() + textpos = y0 + (y1 - y0)*0.97 + ypos = ax1.get_ylim()[0] + ax1.text(pos[tick], textpos, upperLabels[tick], + horizontalalignment='center', size='small', + color='royalblue') + + plt.show() |