gistfile1.pl

use v6;


# initial code from moritz http://www.perlmonks.org/?node_id=842792
# 
# calculator with different operators with different associativity and priority levels
# and wuth brackets

grammar Calc 
{
    token TOP { <expression> }
    rule expression 
{ [@<bracket1>=['(' <.ws>]]*  <lhs=.numeric>  [@<bracket2>=[')'<.ws>]]*  ( <op> [@<bracket3>=['('<.ws>]]* <rhs=.numeric> [@<bracket4>=[')' <.ws> ]]* )*
# | [<lhs=.numeric> ( <op> <rhs=.numeric> )* <op> ]? '(' <expression> ')'  [<op>  <lhs=.numeric> ( <op> <rhs=.numeric> )*]? 
 # <lhs=.expression> ( <op> <rhs=.expression> )*
 # | '(' <expression> ')'
  # | =.numeric>
   }
    token numeric { \d+[\.\d*]? }
    token op { '-' | '+' | '**' | '*' | '/' | 'x' }
}

my %actions =
    '*' => { $^a * $^b },
    'x' => { $^a * $^b },
    '**' => { $^a ** $^b },
    '/' => { $^a / $^b },
    '+' => { $^a + $^b },
    '-' => { $^a - $^b };

my %priorities = 
    '*' => 100,
    'x' => 100,
     '**' => 150,
    '/' => 100,
    '+' => 50,
    '-' => 50;

my %associativity = 
    '*' => 'L',
    'x' => 'L',
     '**' => 'R',
    '/' => 'L',
    '+' => 'L',
    '-' =>'L';


class Calc::Actions {
   
    method TOP($/) { make $<expression>.ast }
    method bracket_handling($m, $bracketlevel is rw, @values is rw, $value is rw,$next_op) {
    
    my $bracketlevel_max =  $bracketlevel + $m<bracket3>.elems - min $m<bracket4>.elems  , 0;
             my $bracketlevel_min = $bracketlevel + $m<bracket3>.elems - $m<bracket4>.elems; # bracket level at the end
              say "bracketlevel before: $bracketlevel {$m<bracket4>.elems}\n";
             $bracketlevel += $m<bracket3>.elems - $m<bracket4>.elems;
          
             say "bracketlevel:$bracketlevel $bracketlevel_max >= @values[*-1][2] >= $bracketlevel_min\n";
             if @values.elems>0 && $bracketlevel_max >= @values[*-1][2] >= $bracketlevel_min 
             {
               say "entered\n";
               if defined $next_op 
               {
                  if @values[*-1][2] == $bracketlevel # same bracket level
                  {
	               if %priorities{@values[*-1][0]} < %priorities{$next_op} 
	               {
	                   # do nothing
	               }
	               elsif @values[*-1][0] eq $next_op && %associativity{$next_op} eq 'L' 
	               {
		              my @values2 = reverse @values;
		              for @values2 -> $v 
		              {
		               if $v[2]>=$bracketlevel
		               {
		                 $value = %actions{$v[1]}.($v[0],$value); 
		                 pop @values;
		               }
		               else
		               {
		                 last;
		               }              
		              }
	               }
	               else # priority is the same, it does not matter in which direction we go
	               {
	
	               }
	          }    
	          else # go backwards , bracket closed this part
	          {
	             my @values2 = reverse @values;
	              for @values2 -> $v 
	              {
	               if $v[2]>=$bracketlevel
	               {
	                 $value = %actions{$v[1]}.($v[0],$value); 
	                 pop @values;
	               }
	               else
	               {
	                 last;
	               }              
	              }
	            
	                  
	          
	          } 
	               
	              
               }
               # no next op
             }
    
    
    
    }
    method expression($/) {
        my $value = $<lhs>.ast;
        say "$value";
        my @values;
        say "bracket1"~$<bracket1>.elems~" "~$<bracket1>[0];
        my $bracketlevel = $<bracket1>.elems - $<bracket2>.elems;
        for $0.list.kv -> $k,$m {
           #say $m<rhs>.ast.perl;
          say "loop:$k";
          # say ">>$value $k {$m<rhs>.ast..[0]}";
          my $current_op = $m<op>.ast[0];
          my $next_op;
          if $0.list.elems > $k+1
          {
            $next_op=$0.list[$k+1]<op>.ast[0];

          }
          if $m<bracket3>.elems>0
          {
             say "got here";
             push @values, [$value, $m<op>.ast[0],$bracketlevel];
             $value = $m<rhs>.ast;
             self.bracket_handling($m, $bracketlevel, @values, $value,$next_op) ;
          } 
          elsif not defined $next_op
          {
             #say "here1";
             say "final:$value $m<op>.ast[0] $m<rhs>.ast";
             $value = $m<op>.ast[1].($value, $m<rhs>.ast);
             
            # say "here2"; 
          }
          elsif $m<bracket4>.elems > 0
          {
             say "closing brackets:$value $m<op>.ast[0] $m<rhs>.ast";
             $value = $m<op>.ast[1].($value, $m<rhs>.ast);       
             self.bracket_handling($m, $bracketlevel, @values, $value,$next_op) ;
          }
          elsif %priorities{$current_op}>=%priorities{$next_op}
          {
            #say "here3"; 
            if ($current_op eq $next_op && %associativity{$current_op} eq 'L') || $current_op ne $next_op
            {
          #         say "here5"; 
	            $value = $m<op>.ast[1].($value, $m<rhs>.ast);
	            if @values.elems>0 && %priorities{$0.list[$k+1]<op>.ast[0]}>=%priorities{@values[*-1][1]}
	            {
	                 for reverse @values -> $v {$value = %actions{$v[1]}.($v[0],$value) }
	                 @values=(); 
	            }
            }
            else
            {
         #     say "here6"; 
               push @values, [$value, $m<op>.ast[0],$bracketlevel];
               $value = $m<rhs>.ast;
            }
       #     say "here4"; 
          }
          else
          {
        #    say "here5"; 
            push @values, [$value, $m<op>.ast[0],$bracketlevel];
            $value = $m<rhs>.ast;
           # say "here6"; 
          }
        }
       # say "here7"; 
       # finish remaining calculations
        for reverse @values -> $v
        {
          say "$v[0] $v[1] $value";
        
          $value = %actions{$v[1]}.($v[0],$value);
          say "result:$value";
        }
       
        make $value;
    }
    method numeric($/) { make +$/ }
    method op($/) { make [$/,%actions{$/}] }
}

my $t1 = time;
my $m = Calc.parse( " (3 ** (5 +2) ** 2) * 2+ (2+3)",  :actions( Calc::Actions)); #"8.8 - 5.0 * 2" "8.8 - 5.0 * 2-4"
die "dying no match"  unless  $m;
say "$m<expression> =  $m.ast()";
my $t2 = time;
say "running time:"~($t2-$t1);