summaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/AspectC/Repo.pm140
-rw-r--r--lib/AspectC/Repo/Function.pm55
-rw-r--r--lib/FLAT.pm197
-rw-r--r--lib/FLAT/CMD.pm533
-rw-r--r--lib/FLAT/CMD/AcyclicStrings.pm54
-rw-r--r--lib/FLAT/CMD/DFTStrings.pm55
-rw-r--r--lib/FLAT/DFA.pm557
-rw-r--r--lib/FLAT/FA.pm554
-rw-r--r--lib/FLAT/NFA.pm509
-rw-r--r--lib/FLAT/PFA.pm293
-rw-r--r--lib/FLAT/Regex.pm194
-rw-r--r--lib/FLAT/Regex/Op.pm282
-rw-r--r--lib/FLAT/Regex/Parser.pm82
-rw-r--r--lib/FLAT/Regex/Transform.pm18
-rw-r--r--lib/FLAT/Regex/Util.pm33
-rw-r--r--lib/FLAT/Regex/WithExtraOps.pm109
-rw-r--r--lib/FLAT/Symbol.pm98
-rw-r--r--lib/FLAT/Transition.pm66
-rw-r--r--lib/FLAT/XFA.pm3
-rw-r--r--lib/Kratos/DFADriver.pm1334
-rw-r--r--lib/Kratos/DFADriver/DFA.pm251
-rw-r--r--lib/Kratos/DFADriver/Model.pm555
-rw-r--r--lib/MIMOSA.pm177
-rw-r--r--lib/MIMOSA/Log.pm388
-rwxr-xr-xlib/dfatool.py291
-rwxr-xr-xlib/plotter.py177
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()
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-22 20:06:07 +0000