diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/AspectC/Repo/Function.pm | 55 | ||||
| -rw-r--r-- | lib/FLAT.pm | 197 | ||||
| -rw-r--r-- | lib/FLAT/CMD.pm | 533 | ||||
| -rw-r--r-- | lib/FLAT/CMD/AcyclicStrings.pm | 54 | ||||
| -rw-r--r-- | lib/FLAT/CMD/DFTStrings.pm | 55 | ||||
| -rw-r--r-- | lib/FLAT/DFA.pm | 557 | ||||
| -rw-r--r-- | lib/FLAT/FA.pm | 554 | ||||
| -rw-r--r-- | lib/FLAT/NFA.pm | 509 | ||||
| -rw-r--r-- | lib/FLAT/PFA.pm | 293 | ||||
| -rw-r--r-- | lib/FLAT/Regex.pm | 194 | ||||
| -rw-r--r-- | lib/FLAT/Regex/Op.pm | 282 | ||||
| -rw-r--r-- | lib/FLAT/Regex/Parser.pm | 82 | ||||
| -rw-r--r-- | lib/FLAT/Regex/Transform.pm | 18 | ||||
| -rw-r--r-- | lib/FLAT/Regex/Util.pm | 33 | ||||
| -rw-r--r-- | lib/FLAT/Regex/WithExtraOps.pm | 109 | ||||
| -rw-r--r-- | lib/FLAT/Symbol.pm | 98 | ||||
| -rw-r--r-- | lib/FLAT/Transition.pm | 66 | ||||
| -rw-r--r-- | lib/FLAT/XFA.pm | 3 | ||||
| -rw-r--r-- | lib/Kratos/DFADriver.pm | 1423 | ||||
| -rw-r--r-- | lib/Kratos/DFADriver/DFA.pm | 277 | ||||
| -rw-r--r-- | lib/Kratos/DFADriver/Model.pm | 495 | ||||
| -rw-r--r-- | lib/MIMOSA.pm | 177 | ||||
| -rw-r--r-- | lib/MIMOSA/Log.pm | 398 | ||||
| -rw-r--r-- | lib/Math/Cartesian/Product.pm | 262 |
24 files changed, 0 insertions, 6724 deletions
diff --git a/lib/AspectC/Repo/Function.pm b/lib/AspectC/Repo/Function.pm deleted file mode 100644 index a7edae2..0000000 --- a/lib/AspectC/Repo/Function.pm +++ /dev/null @@ -1,55 +0,0 @@ -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 deleted file mode 100644 index ee6af9d..0000000 --- a/lib/FLAT.pm +++ /dev/null @@ -1,197 +0,0 @@ -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 deleted file mode 100644 index 5bd0e2d..0000000 --- a/lib/FLAT/CMD.pm +++ /dev/null @@ -1,533 +0,0 @@ -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 deleted file mode 100644 index ebc8840..0000000 --- a/lib/FLAT/CMD/AcyclicStrings.pm +++ /dev/null @@ -1,54 +0,0 @@ -# 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 deleted file mode 100644 index 9dc5a59..0000000 --- a/lib/FLAT/CMD/DFTStrings.pm +++ /dev/null @@ -1,55 +0,0 @@ -# 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 deleted file mode 100644 index f96c9fb..0000000 --- a/lib/FLAT/DFA.pm +++ /dev/null @@ -1,557 +0,0 @@ -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 deleted file mode 100644 index dd77f50..0000000 --- a/lib/FLAT/FA.pm +++ /dev/null @@ -1,554 +0,0 @@ -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 deleted file mode 100644 index 344ea76..0000000 --- a/lib/FLAT/NFA.pm +++ /dev/null @@ -1,509 +0,0 @@ -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 deleted file mode 100644 index 5557525..0000000 --- a/lib/FLAT/PFA.pm +++ /dev/null @@ -1,293 +0,0 @@ -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 deleted file mode 100644 index 2c5c243..0000000 --- a/lib/FLAT/Regex.pm +++ /dev/null @@ -1,194 +0,0 @@ -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 deleted file mode 100644 index 76e796c..0000000 --- a/lib/FLAT/Regex/Op.pm +++ /dev/null @@ -1,282 +0,0 @@ -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 deleted file mode 100644 index deb73f1..0000000 --- a/lib/FLAT/Regex/Parser.pm +++ /dev/null @@ -1,82 +0,0 @@ -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 deleted file mode 100644 index cd0cf56..0000000 --- a/lib/FLAT/Regex/Transform.pm +++ /dev/null @@ -1,18 +0,0 @@ -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 deleted file mode 100644 index 516ad9f..0000000 --- a/lib/FLAT/Regex/Util.pm +++ /dev/null @@ -1,33 +0,0 @@ -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 deleted file mode 100644 index b366d7c..0000000 --- a/lib/FLAT/Regex/WithExtraOps.pm +++ /dev/null @@ -1,109 +0,0 @@ -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 deleted file mode 100644 index aaadccc..0000000 --- a/lib/FLAT/Symbol.pm +++ /dev/null @@ -1,98 +0,0 @@ -# -# 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 deleted file mode 100644 index fc385f3..0000000 --- a/lib/FLAT/Transition.pm +++ /dev/null @@ -1,66 +0,0 @@ -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 deleted file mode 100644 index 67e073c..0000000 --- a/lib/FLAT/XFA.pm +++ /dev/null @@ -1,3 +0,0 @@ -package FLAT::XFA; - -1; diff --git a/lib/Kratos/DFADriver.pm b/lib/Kratos/DFADriver.pm deleted file mode 100644 index deb758c..0000000 --- a/lib/Kratos/DFADriver.pm +++ /dev/null @@ -1,1423 +0,0 @@ -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 Data::Dumper; -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->{repo} = AspectC::Repo->new; - $self->{lp}{iteration} = 1; - - if ( -r $opt{model_file} ) { - $self->{model} = Kratos::DFADriver::Model->new(%opt); - $self->{class_name} = $self->{model}->class_name; - } - elsif ( $opt{class_name} ) { - $self->{model} = Kratos::DFADriver::Model->new_from_repo( - repo => $self->{repo}, - class_name => $opt{class_name}, - model_file => $opt{model_file}, - ); - } - else { - die('Neither driver.json nor class name specified, cannot continue'); - } - - bless( $self, $class ); - - $self->set_paths; - $self->dfa->set_model( $self->model ); - - return $self; -} - -sub set_paths { - my ($self) = @_; - - my $model_path = $self->{model_file}; - $model_path =~ s{ /?+dfa-driver/[^/]+[.] ( xml | json ) $ }{}x; - - my $prefix = $self->{prefix} = cwd() . "/${model_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 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, $funtype ) = @_; - - $funtype //= 'fit_guess'; - - my $errmap = $hash->{$funtype}{$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_counter_status { - my ( $self, $hash, $key ) = @_; - - $hash = $hash->{$key}; - - if ( 2**32 / $hash->{median} < 10e6 ) { - printf( " %s: 32bit energy counter will overflow after %.f ms\n", - 'power', ( 2**32 / $hash->{median} ) / 1000 ); - } -} - -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_arg = $hash->{std_arg}; - my $std_ind_param = $hash->{std_param}; - my $std_ind_trace = $hash->{std_trace}; - my $std_by_arg = $hash->{std_by_arg} // {}; - my $std_by_param = $hash->{std_by_param}; - my $std_by_trace = $hash->{std_by_trace} // {}; - my $r_by_param = $hash->{spearmanr_by_param} // {}; - my $arg_ratio; - my $param_ratio; - my $trace_ratio; - - if ( $std_global > 0 ) { - $param_ratio = $std_ind_param / $std_global; - if ( defined $std_ind_arg ) { - $arg_ratio = $std_ind_arg / $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 ( defined $std_ind_arg - and $std_global > 10 - and $arg_ratio < 0.5 - and not exists $hash->{function}{user_arg} ) - { - printf( " %s: depends on arguments (%.2f / %.2f = %.3f)\n", - $key, $std_ind_arg, $std_global, $arg_ratio ); - } - if ( - defined $std_ind_arg - and ( $std_global < 10 - or $arg_ratio > 0.5 ) - and exists $hash->{function}{user_arg} - ) - { - printf( " %s: should not depend on arguments (%.2f / %.2f = %.3f)\n", - $key, $std_ind_arg, $std_global, $arg_ratio ? $arg_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 global %s (%.2f / %.2f = %.3f%s)\n", - $key, $status, $param, $std_ind_param, $std_this, $ratio, - $fline ); - } - if ( exists $r_by_param->{$param} ) { - printf( " %s: spearman_r for global %s is %.3f (p = %.3f)\n", - $key, $param, $r_by_param->{$param}, -1 ); - } - } - - for my $arg ( sort keys %{$std_by_arg} ) { - my $std_this = $std_by_arg->{$arg}; - my $ratio = $std_ind_arg / $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, $arg, 'arg_fit_guess' ) ); - } - if ( $ratio < 0.3 ) { - $status = 'depends'; - } - if ($fline) { - printf( " %s: %s on local %s (%.2f / %.2f = %.3f%s)\n", - $key, $status, $arg, $std_ind_arg, $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}; - - for my $funtype ( sort keys %{ $hash->{function} } ) { - if ( exists $hash->{function}{$funtype}{error} ) { - printf( " %s: %s function could not be fitted: %s\n", - $key, $funtype, $hash->{function}{$funtype}{error} ); - } - else { - printf( - " %s: %s function fit error: %.2f%% / %.f %s\n", - $key, $funtype, - $hash->{function}{$funtype}{fit}{smape} // -1, - $hash->{function}{$funtype}{fit}{mae}, $unit - ); - } - } - - for my $pair ( - [ 'param_mean_goodness', 'param mean/ssr-fit' ], - [ 'param_median_goodness', 'param median/static' ], - [ 'arg_mean_goodness', 'arg mean/ssr-fit' ], - [ 'arg_median_goodness', 'arg median/static' ] - ) - { - my ( $goodness, $desc ) = @{$pair}; - if ( exists $hash->{$goodness} ) { - printf( - " %s: %s LUT error: %.2f%% / %.f %s / %.f\n", - $key, $desc, - $hash->{$goodness}{smape} // -1, - $hash->{$goodness}{mae}, - $unit, $hash->{$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_counter_status( $state, 'power' ); - $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_prev', 'pJ' ); - $self->printf_parameterized( $transition, 'rel_energy_prev' ); - $self->printf_fit( $transition, 'rel_energy_prev', 'pJ' ); - - if ( exists $transition->{rel_energy_next}{median} ) { - $self->printf_aggr( $transition, 'rel_energy_next', 'pJ' ); - $self->printf_parameterized( $transition, 'rel_energy_next' ); - $self->printf_fit( $transition, 'rel_energy_next', '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_prev', '\uJ', 1e6 ); - $self->printf_aggr_tex( $transition, 'rel_energy_next', '\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_prev', '\uJ', 1e6 ); - $self->printf_eval_tex( $transition, 'rel_energy_next', '\uJ', 1e6 ); - $self->printf_eval_tex( $transition, 'duration', 'ms', 1e3 ); - $self->printf_count_tex; - print " \\\\"; - } - print "\\hline\n"; - say '\end{tabular}'; -} - -sub assess_workload { - my ( $self, $workload ) = @_; - - $workload =~ s{ \s* \) \s* ; \s* }{:}gx; - $workload =~ s{ \s* \) \s* $ }{}gx; - $workload =~ s{ \s* ; \s* }{!:}gx; - $workload =~ s{ \s* \( \s* }{!}gx; - $workload =~ s{ \s* , \s* }{!}gx; - $workload =~ s{ [^!] \K $ }{!}gx; - - say $workload; - - my $traces = $self->dfa->run_str_to_trace($workload); -} - -sub update_model { - my ($self) = @_; - - for my $name ( sort keys %{ $self->{log}{aggregate}{state} } ) { - my $state = $self->{log}{aggregate}{state}{$name}; - $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} } - ); - } - if ( $self->{with_lut} ) { - $self->model->set_state_lut( $name, 'power', - $state->{power}{median_by_param} ); - } - } - for my $name ( sort keys %{ $self->{log}{aggregate}{transition} } ) { - my $transition = $self->{log}{aggregate}{transition}{$name}; - my @keys = (qw(duration energy rel_energy_prev rel_energy_next)); - - if ( - $self->model->get_transition_by_name($name)->{level} eq 'epilogue' ) - { - push( @keys, 'timeout' ); - } - - for my $key (@keys) { - $self->model->set_transition_property( $name, $key, - $transition->{$key}{median} ); - 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} } - ); - } - if ( $self->{with_lut} ) { - $self->model->set_transition_lut( $name, $key, - $transition->{$key}{median_by_param} ); - } - } - } - - $self->model->set_voltage( - $self->{log}{aggregate}{min_voltage}, - $self->{log}{aggregate}{max_voltage} - ); - - $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'; - my $pass_function = $self->{logging} ? 'logTransition' : 'passTransition'; - - 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}" - -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()->${pass_function}(${class_name}::statepower[tjp->target()->state], - $transition->{rel_energy_prev}{static}, $transition->{id}, - ${dest_state_id}); - }; - -EOF - } - else { - $ah_buf .= <<"EOF"; - - advice execution("% ${class_name}::$transition->{name}(...)") : after() { - tjp->target()->${pass_function}(${class_name}::statepower[tjp->target()->state], - $transition->{rel_energy_prev}{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 %param_default; - - for my $default_setting ( @{ $self->{param_default} } ) { - my ( $param, $value ) = split( qr{ = }x, $default_setting ); - $param_default{$param} = $value; - } - - my $buf = "DFA_Driver::power_uW_t ${class_name}::statepower[] = {" . join( - ', ', - map { - sprintf( - '%.f', - $self->model->get_state_power_with_params( - $_, \%param_default - ) - ) - } @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 $transition_elem ( @{ $transition->{transitions} } ) { - my ( $origin, $destination ) = @{$transition_elem}; - my @edgestyles; - if ( $transition->{level} eq 'epilogue' ) { - push( @edgestyles, 'dashed' ); - } - if ( $origin eq $destination ) { - push( @edgestyles, 'loop above' ); - } - my $edgestyle - = @edgestyles ? '[' . join( q{,}, @edgestyles ) . ']' : q{}; - $buf - .= "\t\t ($origin) edge ${edgestyle} node {$transition->{name}} ($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 $class_name = $self->{class_name}; - 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_${class_name}, driverEvalThread, 256); - -EOF - - $buf .= <<"EOF"; -void DriverEvalThread_${class_name}::action() -{ - Guarded_Buzzer buzzer; - - while (1) { - - /* wait for MIMOSA calibration */ - buzzer.sleep(12000); - buzzer.set(${state_duration}); - - -EOF - - $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 .= "${instance}.stopIteration(); }}\n"; - - return $buf; -} - -sub to_test_h { - my ($self) = @_; - my $class_name = $self->{class_name}; - - my $class_prefix = $self->repo->get_class_path_prefix($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_${class_name} : public Thread { - public: - DriverEvalThread_${class_name}(void* tos) : Thread(tos) { } - void action(); -}; - -extern DriverEvalThread_${class_name} 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->{model_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}, - } - ) - ); - - my $filename = "../data/$self->{lp}{timestamp}_$self->{class_name}"; - if ( $self->{filename_suffix} ) { - $filename .= '_' . $self->{filename_suffix}; - } - $filename .= '.tar'; - - $tar->write($filename); - - 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( $self->{baud_rate} // 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|\r\n/, $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 ); - $self->mimosa->kill; - 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 ); - $self->mimosa->kill; - 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 deleted file mode 100644 index 9b581d8..0000000 --- a/lib/Kratos/DFADriver/DFA.pm +++ /dev/null @@ -1,277 +0,0 @@ -package Kratos::DFADriver::DFA; - -use strict; -use warnings; -use 5.020; - -use parent 'Class::Accessor'; - -use Data::Dumper; -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 ) { - print Dumper( $transition->{parameters} ); - - for my $param ( @{ $transition->{parameters} } ) { - if ( not defined $param->{values} ) { - die( -"argument values for transition $transition->{name} are undefined\n" - ); - } - if ( @{ $param->{values} } == 0 ) { - die( -"argument-value list for transition $transition->{name} is empty \n" - ); - } - } - - my @argtuples - = cartesian { 1 } map { $_->{values} } @{ $transition->{parameters} }; - - # 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 $transition_pair ( @{ $transition->{transitions} } ) { - my ( $origin, $destination ) = @{$transition_pair}; - $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 run_str_to_trace { - my ( $self, $run_str ) = @_; - my @trace; - my $dfa = $self->dfa; - my %param = $self->model->parameter_hash; - my $state = 0; - my $state_duration = $self->{state_duration} // 1000; - my @state_enum = $self->model->get_state_enum; - 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}" ); - - if ( not defined $state ) { - die("Transition $transition_str is invalid or has no successors\n"); - } - - $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, }; - return @trace; -} - -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 $next = $self->dfa->new_deepdft_string_generator($max_iter); - 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{^}{(^}; - if ( $re =~ m{ \$ }x ) { - $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 = $self->run_str_to_trace($run_str); - 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 deleted file mode 100644 index 4a38155..0000000 --- a/lib/Kratos/DFADriver/Model.pm +++ /dev/null @@ -1,495 +0,0 @@ -package Kratos::DFADriver::Model; - -use strict; -use warnings; -use 5.020; - -use parent 'Class::Accessor'; - -use Carp; -use Carp::Assert::More; -use List::Util qw(first uniq); -use File::Slurp qw(read_file write_file); -use JSON; - -Kratos::DFADriver::Model->mk_ro_accessors( - qw(class_name parameter state transition)); - -our $VERSION = '0.00'; - -sub new { - my ( $class, %opt ) = @_; - - my $self = \%opt; - - $self->{custom_code} = {}; - $self->{parameter} = {}; - $self->{state} = {}; - $self->{transition} = {}; - $self->{voltage} = {}; - - bless( $self, $class ); - - my $json = JSON->new->decode( scalar read_file( $self->{model_file} ) ); - for my $key (qw(custom_code parameter state transition)) { - $self->{$key} = $json->{$key}; - } - $self->{class_name} = $json->{class}; - - return $self; -} - -sub new_from_repo { - my ( $class, %opt ) = @_; - my $repo = $opt{repo}; - - my $self = { - class_name => $opt{class_name}, - model_file => $opt{model_file}, - voltage => {}, - }; - - bless( $self, $class ); - - my $class_name = $self->{class_name}; - - my @states; - my %transition; - - if ( not exists $repo->{class}{$class_name} ) { - die("Unknown class: $class_name\n"); - } - my $class_base = $repo->{class}{$class_name}; - - for my $function ( values %{ $class_base->{function} } ) { - my %param_values; - for my $attrib ( @{ $function->{attributes} // [] } ) { - if ( $attrib->{namespace} eq 'Model' ) { - if ( $attrib->{name} =~ m{ ^ transition }x - and @{ $attrib->{args} } == 2 ) - { - push( @states, $attrib->{args}[0]{expression} ); - push( @states, $attrib->{args}[1]{expression} ); - push( - @{ $transition{ $function->{name} }{src} }, - $attrib->{args}[0]{expression} - ); - push( - @{ $transition{ $function->{name} }{dst} }, - $attrib->{args}[1]{expression} - ); - push( - @{ $transition{ $function->{name} }{transitions} }, - [ - $attrib->{args}[0]{expression}, - $attrib->{args}[1]{expression} - ] - ); - } - elsif ( $attrib->{name} =~ m{ ^ testval }x - and @{ $attrib->{args} } == 2 ) - { - push( - @{ $param_values{ $attrib->{args}[0]{value} } }, - $attrib->{args}[1]{value} - ); - } - elsif ( - $attrib->{name} =~ m{ ^ required_in_ (?<state> .* ) $ }x ) - { - push( - @{ - $self->{custom_code}{after_transition_by_state} - { $+{state} } - }, - $function->{name} - ); - } - else { - printf( "wat %s::%s\n", - $attrib->{namespace}, $attrib->{name} ); - } - } - elsif ( $attrib =~ m{ ^ epilogue $ }x ) { - $transition{ $function->{name} }{level} = 'epilogue'; - } - else { - printf( "wat %s::%s\n", $attrib->{namespace}, $attrib->{name} ); - } - } - if ( exists $transition{ $function->{name} } ) { - for my $i ( 0 .. $#{ $function->{argtypes} } ) { - my $argtype = $function->{argtypes}[$i]; - my $param_name = sprintf( '%s.arg%d', $function->{name}, $i ); - push( - @{ $transition{ $function->{name} }{parameters} }, - { - name => $param_name, - values => $param_values{$i}, - } - ); - $self->{parameter}{$param_name} = { - arg_name => $param_name, - function => $function->{name}, - default => undef, - }; - } - } - } - - if ( exists $repo->{class}{"DriverEvalThread_${class_name}"} ) { - for my $var ( - keys %{ $repo->{class}{"DriverEvalThread_${class_name}"}{variable} } - ) - { - if ( $var - =~ m{ ^ testVal __ (?<fun> [^_]+ ) __ arg (?<index> \d+ ) __ (?<descr> [^_]+ ) $ }x - ) - { - push( - @{ - $transition{ $+{fun} }{parameters}[ $+{index} ]{values} - }, - $var - ); - } - } - } - - @states = uniq @states; - @states = sort @states; - - # by convention, UNINITIALIZED always has ID 0 - @states = grep { $_ ne 'UNINITIALIZED' } @states; - unshift( @states, 'UNINITIALIZED' ); - - for my $i ( 0 .. $#states ) { - $self->{state}{ $states[$i] } = { - id => $i, - power => { - static => 0, - } - }; - } - - my @transition_names = sort keys %transition; - - for my $i ( 0 .. $#transition_names ) { - - my $name = $transition_names[$i]; - my @origins = uniq @{ $transition{$name}{src} }; - my @destinations = uniq @{ $transition{$name}{dst} }; - my $guess_level = ( $name eq 'epilogue' ? 'epilogue' : 'user' ); - - $self->{transition}{$name} = { - name => $name, - id => $i, - destination => \@destinations, - origins => \@origins, - transitions => $transition{$name}{transitions}, - level => $transition{$name}{level} // $guess_level, - parameters => $transition{$name}{parameters} // [], - duration => { static => 0 }, - energy => { static => 0 }, - rel_energy_prev => { static => 0 }, - rel_energy_next => { static => 0 }, - timeout => { static => 0 }, - }; - if ( @destinations > 1 ) { - my $dst_str = join( q{, }, @destinations ); - warn( -"Transition ${name} has several destination states ($dst_str). This is only partially supported.\n" - ); - } - } - - write_file( $self->{model_file}, - JSON->new->pretty->encode( $self->TO_JSON ) ); - - return $self; -} - -sub reset_property { - my ( $self, $hash, $name ) = @_; - - delete $hash->{$name}{static}; - if ( exists $hash->{$name}{function} ) { - delete $hash->{$name}{function}{estimate}; - } - if ( exists $hash->{$name}{function}{user} ) { - $hash->{$name}{function}{user}{params} - = [ map { 1 } @{ $hash->{$name}{function}{user}{params} } ]; - } -} - -sub reset { - my ($self) = @_; - - for my $state ( values %{ $self->{state} } ) { - for my $property (qw(power)) { - $self->reset_property( $state, $property ); - } - } - - for my $transition ( $self->transitions ) { - for my $property ( - qw(duration energy rel_energy_prev rel_energy_next timeout)) - { - $self->reset_property( $transition, $property ); - } - } -} - -sub set_state_power { - my ( $self, $state, $power ) = @_; - - $power = sprintf( '%.f', $power ); - - printf( "state %-16s: adjust power %d -> %d µW\n", - $state, $self->{state}{$state}{power}{static}, $power ); - - $self->{state}{$state}{power}{static} = $power; -} - -sub set_transition_property { - my ( $self, $transition_name, $property, $value ) = @_; - - if ( not defined $value ) { - return; - } - - my $transition = $self->get_transition_by_name($transition_name); - - $value = sprintf( '%.f', $value ); - - printf( "transition %-16s: adjust %s %d -> %d\n", - $transition->{name}, $property, $transition->{$property}{static}, - $value ); - - $transition->{$property}{static} = $value; -} - -sub set_state_lut { - my ( $self, $state, $property, $lut ) = @_; - - if ( not defined $lut ) { - return; - } - - ...; -} - -sub set_transition_lut { - my ( $self, $transition_name, $property, $lut ) = @_; - - if ( not defined $lut ) { - return; - } - - ...; -} - -sub set_state_params { - my ( $self, $state, $fun_name, $function, @params ) = @_; - my $old_params = 'None'; - - if ( exists $self->{state}{$state}{power}{function}{$fun_name} ) { - $old_params = join( q{ }, - @{ $self->{state}{$state}{power}{function}{$fun_name}{params} } ); - } - - printf( "state %-16s: adjust %s power function parameters [%s] -> [%s]\n", - $state, $fun_name, $old_params, join( q{ }, @params ) ); - - $self->{state}{$state}{power}{function}{$fun_name}{raw} = $function; - for my $i ( 0 .. $#params ) { - $self->{state}{$state}{power}{function}{$fun_name}{params}[$i] - = $params[$i]; - } -} - -sub set_transition_params { - my ( $self, $transition_name, $fun_type, $fun_name, $function, @params ) - = @_; - my $transition = $self->get_transition_by_name($transition_name); - my $old_params = 'None'; - - if ( exists $transition->{$fun_type}{function}{$fun_name} ) { - $old_params = join( q{ }, - @{ $transition->{$fun_type}{function}{$fun_name}{params} } ); - } - - printf( "transition %-16s: adjust %s %s function parameters [%s] -> [%s]\n", - $transition_name, $fun_name, $fun_type, $old_params, - join( q{ }, @params ) ); - - $transition->{$fun_type}{function}{$fun_name}{raw} = $function; - for my $i ( 0 .. $#params ) { - $transition->{$fun_type}{function}{$fun_name}{params}[$i] = $params[$i]; - } -} - -sub set_voltage { - my ( $self, $min_voltage, $max_voltage ) = @_; - - $self->{voltage} = { - min => $min_voltage, - max => $max_voltage, - }; -} - -sub save { - my ($self) = @_; - - write_file( $self->{model_file}, - JSON->new->pretty->encode( $self->TO_JSON ) ); -} - -sub parameter_hash { - my ($self) = @_; - - for my $param_name ( keys %{ $self->{parameter} } ) { - $self->{parameter}{$param_name}{value} - = $self->{parameter}{$param_name}{default}; - } - - return %{ $self->{parameter} }; -} - -sub update_parameter_hash { - my ( $self, $param_hash, $function, @args ) = @_; - - my $transition = $self->get_transition_by_name($function); - - for my $param ( keys %{ $transition->{affects} } ) { - $param_hash->{$param}{value} = $transition->{affects}{$param}; - } - - for my $i ( 0 .. $#args ) { - my $arg_name = $transition->{parameters}[$i]{name}; - my $arg_value = $args[$i]; - - for my $param_name ( keys %{ $self->{parameter} } ) { - if ( $self->{parameter}{$param_name}{arg_name} eq $arg_name ) { - $param_hash->{$param_name}{value} = $arg_value; - } - } - } -} - -sub startup_code { - my ($self) = @_; - - return $self->{custom_code}{startup} // q{}; -} - -sub heap_code { - my ($self) = @_; - - return $self->{custom_code}{heap} // q{}; -} - -sub after_transition_code { - my ($self) = @_; - - return $self->{custom_code}{after_transition} // q{}; -} - -sub get_state_extra_transitions { - my ( $self, $state ) = @_; - - return @{ $self->{custom_code}{after_transition_by_state}{$state} // [] }; -} - -sub shutdown_code { - my ($self) = @_; - - return $self->{custom_code}{shutdown} // q{}; -} - -sub get_transition_by_name { - my ( $self, $name ) = @_; - - return $self->{transition}{$name}; -} - -sub get_transition_by_id { - my ( $self, $id ) = @_; - - my $transition = first { $_->{id} == $id } $self->transitions; - - return $transition; -} - -sub get_state_id { - my ( $self, $name ) = @_; - - return $self->{state}{$name}{id}; -} - -sub get_state_name { - my ( $self, $id ) = @_; - - return ( $self->get_state_enum )[$id]; -} - -sub get_state_power { - my ( $self, $name ) = @_; - - return $self->{state}{$name}{power}{static}; -} - -sub get_state_power_with_params { - my ( $self, $name, $param_values ) = @_; - - my $hash_str = join( ';', - map { $param_values->{$_} } - sort { $a cmp $b } keys %{$param_values} ); - - if ( $hash_str eq q{} ) { - return $self->get_state_power($name); - } - - if ( exists $self->{state}{$name}{power}{lut}{$hash_str} ) { - return $self->{state}{$name}{power}{lut}{$hash_str}; - } - - say "Note: No matching LUT for state ${name}, using median"; - - return $self->get_state_power($name); -} - -sub get_state_enum { - my ($self) = @_; - - if ( not exists $self->{state_enum} ) { - @{ $self->{state_enum} } - = sort { $self->{state}{$a}{id} <=> $self->{state}{$b}{id} } - keys %{ $self->{state} }; - } - - return @{ $self->{state_enum} }; -} - -sub transitions { - my ($self) = @_; - - my @ret = values %{ $self->{transition} }; - @ret = sort { $a->{id} <=> $b->{id} } @ret; - return @ret; -} - -sub TO_JSON { - my ($self) = @_; - - return { - class => $self->{class_name}, - parameter => $self->{parameter}, - state => $self->{state}, - transition => $self->{transition}, - custom_code => $self->{custom_code}, - voltage => $self->{voltage}, - }; -} - -1; diff --git a/lib/MIMOSA.pm b/lib/MIMOSA.pm deleted file mode 100644 index 54a5e15..0000000 --- a/lib/MIMOSA.pm +++ /dev/null @@ -1,177 +0,0 @@ -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 deleted file mode 100644 index 270bbb2..0000000 --- a/lib/MIMOSA/Log.pm +++ /dev/null @@ -1,398 +0,0 @@ -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 = 6; - -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 'rxDone' - 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 $trace_elem->{name} ne 'RX' - 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/Math/Cartesian/Product.pm b/lib/Math/Cartesian/Product.pm deleted file mode 100644 index eedcf1e..0000000 --- a/lib/Math/Cartesian/Product.pm +++ /dev/null @@ -1,262 +0,0 @@ -=head1 Name - -Math::Cartesian::Product - Generate the Cartesian product of zero or more lists. - -=head1 Synopsis - - use Math::Cartesian::Product; - - cartesian {print "@_\n"} [qw(a b c)], [1..2]; - - # a 1 - # a 2 - # b 1 - # b 2 - # c 1 - # c 2 - - cartesian {print "@_\n"} ([0..1]) x 8; - - # 0 0 0 0 0 0 0 0 - # 0 0 0 0 0 0 0 1 - # 0 0 0 0 0 0 1 0 - # ... - # 1 1 1 1 1 1 1 0 - # 1 1 1 1 1 1 1 1 - - print "@$_\n" for - cartesian {"@{[reverse @_]}" eq "@_"} - ([' ', '*']) x 8; - - # * * - # * * - # * * * * - # * * - # * * * * - # * * * * - # * * * * * * - # * * - # * * * * - # * * * * - # * * * * * * - # * * * * - # * * * * * * - # * * * * * * - # * * * * * * * * - -=cut - -package Math::Cartesian::Product; - -use Carp; -use strict; - -sub cartesian(&@) # Generate the Cartesian product of zero or more lists - {my $s = shift; # Subroutine to call to process each element of the product - - my @C = @_; # Lists to be multiplied - my @c = (); # Current element of Cartesian product - my @P = (); # Cartesian product - my $n = 0; # Number of elements in product - -# return 0 if @C == 0; # Empty product per Philipp Rumpf - - @C == grep {ref eq 'ARRAY'} @C or croak("Arrays of things required by cartesian"); - -# Generate each Cartesian product when there are no prior Cartesian products. -# The first variant builds the results array, the second does not per Justin Case - - my $p; $p = wantarray() ? sub - {if (@c < @C) - {for(@{$C[@c]}) - {push @c, $_; - &$p(); - pop @c; - } - } - else - {my $p = [@c]; - push @P, bless $p if &$s(@$p); - } - } : sub # List not required per Justin Case - {if (@c < @C) - {for(@{$C[@c]}) - {push @c, $_; - &$p(); - pop @c; - } - } - else - {++$n if &$s(@c); - } - }; - -# Generate each Cartesian product allowing for prior Cartesian products. - - my $q; $q = wantarray() ? sub - {if (@c < @C) - {for(@{$C[@c]}) - {push @c, $_; - &$q(); - pop @c; - } - } - else - {my $p = [map {ref eq __PACKAGE__ ? @$_ : $_} @c]; - push @P, bless $p if &$s(@$p); - } - } : sub # List not required per Justin Case - {if (@c < @C) - {for(@{$C[@c]}) - {push @c, $_; - &$q(); - pop @c; - } - } - else - {++$n if &$s(map {ref eq __PACKAGE__ ? @$_ : $_} @c); - } - }; - -# Determine optimal method of forming Cartesian products for this call - - if (grep {grep {ref eq __PACKAGE__} @$_} @C) - {&$q - } - else - {&$p - } - - $p = $q = undef; # Break memory loops per Philipp Rumpf - wantarray() ? @P : $n # Product or count per Justin Case - } - -# Export details - -require 5; -require Exporter; - -use vars qw(@ISA @EXPORT $VERSION); - -@ISA = qw(Exporter); -@EXPORT = qw(cartesian); -$VERSION = '1.009'; # Tuesday 18 Aug 2015 - -=head1 Description - -Generate the Cartesian product of zero or more lists. - -Given two lists, say: [a,b] and [1,2,3], the Cartesian product is the -set of all ordered pairs: - - (a,1), (a,2), (a,3), (b,1), (b,2), (b,3) - -which select their first element from all the possibilities listed in -the first list, and select their second element from all the -possibilities in the second list. - -The idea can be generalized to n-tuples selected from n lists where all the -elements of the first list are combined with all the elements of the second -list, the results of which are then combined with all the member of the third -list and so on over all the input lists. - -It should be noted that Cartesian product of one or more lists where one or -more of the lists are empty (representing the empty set) is the empty set -and thus has zero members; and that the Cartesian product of zero lists is a -set with exactly one member, namely the empty set. - -C<cartesian()> takes the following parameters: - -1. A block of code to process each n-tuple. this code should return true -if the current n-tuple should be included in the returned value of the -C<cartesian()> function, otherwise false. - -2. Zero or more lists. - -C<cartesian()> returns an array of references to all the n-tuples selected by -the code block supplied as parameter 1 if called in list context, else it -returns a count of the selected n-tuples. - -C<cartesian()> croaks if you try to form the Cartesian product of -something other than lists of things or prior Cartesian products. - -The cartesian product of lists A,B,C is associative, that is: - - (A X B) X C = A X (B X C) - -C<cartesian()> respects associativity by allowing you to include a -Cartesian product produced by an earlier call to C<cartesian()> in the -set of lists whose Cartesian product is to be formed, at the cost of a -performance penalty if this option is chosen. - - use Math::Cartesian::Product; - - my $a = [qw(a b)]; - my $b = [cartesian {1} $a, $a]; - cartesian {print "@_\n"} $b, $b; - - # a a a a - # a a a b - # a a b a - # ... - -C<cartesian()> is easy to use and fast. It is written in 100% Pure Perl. - -=head1 Export - -The C<cartesian()> function is exported. - -=head1 Installation - -Standard Module::Build process for building and installing modules: - - perl Build.PL - ./Build - ./Build test - ./Build install - -Or, if you're on a platform (like DOS or Windows) that doesn't require -the "./" notation, you can do this: - - perl Build.PL - Build - Build test - Build install - -=head1 Author - -Philip R Brenan at gmail dot com - -http://www.appaapps.com - -=head1 Acknowledgements - -With much help and good natured advice from Philipp Rumpf and Justin Case to -whom I am indebted. - -=head1 See Also - -=over - -=item L<Math::Disarrange::List> - -=item L<Math::Permute::List> - -=item L<Math::Permute::Lists> - -=item L<Math::Permute::Partitions> - -=item L<Math::Subsets::List> - -=item L<Math::Transform::List> - -=back - -=head1 Copyright - -Copyright (c) 2009-2015 Philip R Brenan. - -This module is free software. It may be used, redistributed and/or -modified under the same terms as Perl itself. - -=cut |