File Coverage

blib/lib/Set/Formula.pm

Criterion	Covered	Total	%
statement	168	208	80.7
branch	71	118	60.1
condition	3	6	50.0
subroutine	10	10	100.0
pod	3	3	100.0
total	255	345	73.9

package Set::Formula;

use 5.8.8;
use strict;
use warnings;

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(formula_checker formula_calcul equality_checker);

use Carp qw(cluck);
our $VERSION = '0.05';
my $debug = 0;

my %operators = (
                  '+'   => \&_union
                 ,'-'   => \&_complement
                 ,'^'   => \&_intersection
                );

my $counter = 0;
#------------------------------------------#
sub _union
{
   my ($hrefA, $hrefB, $href_result) = @_;
   %{$href_result} = ();  # reset this hash

   for  (keys %{$hrefA}) { ${$href_result}{$_} = 0 }
   for  (keys %{$hrefB}) { ${$href_result}{$_} = 0 }
}
#------------------------------------------#
sub _complement
{  # Result := A - B
   my ($hrefA, $hrefB, $href_result) = @_;
   %{$href_result} = ();  # reset this hash

   for  (keys %{$hrefA})
   {  unless (exists ${$hrefB}{$_}) { ${$href_result}{$_} = 0 } }
}
#------------------------------------------#
sub _intersection
{
   my ($hrefA, $hrefB, $href_result) = @_;
   %{$href_result} = ();  # reset this hash

   for  (keys %{$hrefB})
   {  if (exists ${$hrefA}{$_})  { ${$href_result}{$_} = 0; } }
}
#------------------------------------------#
sub equality_checker   # returns 1 if equal, else 0
{
   my ($hrefA, $hrefB, $debug) = @_;

   $debug = (defined $debug)? 1:0;
   if ($debug)
   {
      printf "*** %s: running in debug mode ***\n", (caller(0))[3];
      print "DEBUG: 1st operand: "; for (sort keys %{$hrefA}) { print "$_ "; }; print "\n";
      print "DEBUG: 2nd operand: "; for (sort keys %{$hrefB}) { print "$_ "; }; print "\n";
   }

   for (keys %{$hrefA})
   { unless (exists ${$hrefB}{$_}) { return 0 } }

   for (keys %{$hrefB})
   { unless (exists ${$hrefA}{$_}) { return 0 } }
   return 1;
}
#------------------------------------------#

sub formula_checker   # returns true on success and undefined value on error
{
   my $formula = shift;
   my $remainder;
   my $debug = (defined $ARGV[0]) && $ARGV[0] ?1:0;
   $debug && printf "*** %s: running in debug mode ***\n", (caller(0))[3];
   unless (defined $remainder) { $remainder = ''; }
   my $parentheses_cnt = 0;
   my $parentheses_number_cnt = 0;
   my $operator;
   my $regexpr ;

   # ---- check "interlacing": start ----
   # rule 1: 2 operands  can't be adjacent
   # rule 2: 2 operators can't be adjacent
   # rule 3: operator can be neither first not last formula element

   $debug && print "DEBUG 10: formula:  $formula\n";
   $remainder = $formula;
   $remainder =~ s/[()]//g;  # remove all parentheses
   $debug && print "DEBUG 20: remainder: $remainder\n";
   my $operator_found = 0;

   INTERLACING:
   while(1)
   {
      unless ( $remainder =~ /^\s*(\w+)\s*/ )
      {
         $debug && cluck "ERROR: remainder of formula $remainder must begin with operand";
         return;
      }

      $remainder = $';
      $debug && print "DEBUG 30: operand:  $1    remainder: $remainder\n";

      unless ($remainder) { last INTERLACING; } # interlacing is correct

      $operator_found = 0;
      for (keys %operators)
      {
         $debug && print "DEBUG 40: operator: $_\n";
         $regexpr = qq (^\\s*(\\$_)\\s*);
         $debug && printf "DEBUG 45: regexpr = %s\n", $regexpr;
         if ( $remainder =~ /$regexpr/ )
         {
            $operator_found = 1;
            $operator = $_;
            $remainder = $';
            last;
         }
      }

      unless ($operator_found)
      {
         $debug && cluck "ERROR: remainder of formula $remainder must begin with operator";
         return;
      }

      $debug && printf "DEBUG 50: operator: %s\n", $operator;

      unless ($remainder)
      {
         $debug && cluck "ERROR: formula must begin with operator";
         return;
      }
   }  #  end of 'while (1)'

   # ---- check "interlacing": finish  ----

   # ---- check parentheses: start ----
   $remainder = $formula;
   $debug && printf "DEBUG 60: *** remainder = %s\n", $remainder;

   for $operator (keys %operators)
   {
      $regexpr = qq (\\(\\s*\\$operator|\\$operator\\s*\\));
      $debug && printf "DEBUG 65: *** operator = %-3s   regexpr = %s\n", $operator, $regexpr;
      if ( $remainder =~ /$regexpr/ )
      {
         $debug && cluck "ERROR: $& has no sense";
         return;
      }
   }

   while ($remainder =~ /[()]/)
   {
      $debug && printf "DEBUG 70: *** remainder = %s\n", $remainder;
      $parentheses_number_cnt ++;
      $remainder = $';
      unless (defined $remainder) { $remainder = ''; }
      $debug && printf "DEBUG 75: *** remainder = %s\n", $remainder;
      if ( $& =~ /\(/ ) {  $parentheses_cnt ++; }
      else
      {
         $parentheses_cnt --;
         if ($parentheses_cnt < 0)
         {
            $debug && cluck "ERROR: negative parentheses amount at parentheses nr.$parentheses_number_cnt from left";
            return;
         }
      }
   }  #  end of "while ($remainder)"

   if ($parentheses_cnt)
   {
      $debug && cluck "ERROR: more opening parentheses than closing parentheses";
      return;
   }
   return 1;
}  #  end of "sub formula_checker"
#------------------------------------------#
#------------------------------------------#

sub formula_calcul
{
   my ($curr_formula, $href_result, $href_HoH_sets, $debug) = @_;
   %{$href_result} = ();  # reset this hash
   unless (defined $curr_formula) { $curr_formula = '' }

   $debug = (defined $debug) && $debug ?1:0;
   $debug && printf "*** %s: running in debug mode ***\n", (caller(0))[3];

   $debug && print "\n--------------------------\n#1 curr_formula = $curr_formula\n";

   my $href_operand_left;
   my $href_operand_right;
   my $operator;           # a key of %operators
   my $href_remainder;
   my $new_name;

   # parse formula: search internal (...)
   while ( $curr_formula =~ /\(([^(]+?)\)/ )
   {
      #  $curr_formula contains parentheses
      #  $1 is innenmost formula part, that does not contains parentheses.
      #  Opened and closed parentheses are located on boundaries of $1 and don't belong it.
      $debug && print "#2 in parentheses:  $1\n";
      #------------------------------------------#
      unless (defined &formula_calcul ($1, $href_result, $href_HoH_sets, $debug))
      { $debug && cluck "Error in formula \"$1\""; return; }

      $new_name = "InTeRmEdIaTe$counter";
      $counter++;
      for (keys %{$href_result})  { $href_HoH_sets->{$new_name}{$_} = 0; }
      unless (exists $href_HoH_sets->{$new_name}) { $href_HoH_sets->{$new_name} = () }
      %{$href_result} = ();  # reset this hash

      $curr_formula = "$` $new_name $'";
      $debug && print "#3 curr_formula = $curr_formula\n\n";
   }

   # parenthesesless formula.
   # Calculate all operators with equal priority from left to right
   if ( $curr_formula =~ /(\w+)\s*(\S+)\s*(\w+)/ )
   {
      $href_operand_left  = $1;
      $operator           = $2;
      $href_operand_right = $3;
      $href_remainder     = $';
      if ($operator !~ /^(\+|\-|\^)$/)
      { $debug && cluck "ERROR: Unknown operator \"$operator\" in formula \"$curr_formula\"\n"; return; }

      $debug && printf "*** left operand = $href_operand_left, operator = $operator, right operand = $href_operand_right,  remainder = %s\n", $href_remainder;

      unless (exists $href_HoH_sets->{$href_operand_left})
      {
         $debug && cluck "ERROR: Unknown left operand \"$href_operand_left\" in formula \"$curr_formula\"\n";
         return;
      }

      unless (exists $href_HoH_sets->{$href_operand_right})
      {
         $debug && cluck "ERROR: Unknown right operand \"$href_operand_right\" in formula \"$curr_formula\"\n";
         return;
      }

      if ($debug)
      {
         printf "!!! %-13s : ", $href_operand_left;
         for ( keys %{$href_HoH_sets->{$href_operand_left}} ) {print "$_ "}
         print "\n";

         printf "!!! %-13s : ", $href_operand_right;
         for ( keys %{$href_HoH_sets->{$href_operand_right}} ) {print "$_ "}
         print "\n";
      }

      $operators{$operator} ( $href_HoH_sets->{$href_operand_left}
                            , $href_HoH_sets->{$href_operand_right}
                            , $href_result );

      if ($debug)
      {
         print "DEBUG: result of ($href_operand_left  $operator  $href_operand_right) : ";
         for (keys %{$href_result}) { print "$_ " }
         print "\n";
      }

      if ($href_remainder =~ /\S/)
      {
         $new_name = "InTeRmEdIaTe$counter";
         $counter++;
         for (keys %{$href_result}) { $href_HoH_sets->{$new_name}{$_} = 0 }
         unless (exists $href_HoH_sets->{$new_name}) { $href_HoH_sets->{$new_name} = () }
         %{$href_result} = ();  # reset this hash

         $curr_formula = "$new_name $href_remainder";
         $debug && print "#4 curr_formula = $curr_formula\n\n";
         if (defined &formula_calcul ($curr_formula, $href_result, $href_HoH_sets, $debug))
         { return 1; }
         else { $debug && cluck "ERROR 33\n"; return; }
      }
   }  # end of "if ( $curr_formula =~ ...)"
   return 1;
}  #  end of "sub formula_calcul"

1;
__END__