BNF generator for counted rule X{N}

counted_rule.pl

use 5.14.2;
use List::Util 'sum';

# power a n = a                                    if n == 1
# power a n = power (power a 2) (n/2)              if n is even
# power a n = (power (power a 2) (n/2)) * a        if n is odd

sub power {
    my ($op, $a, $n) = @_;
    if ($n == 1) {
        return $a;
    }
    elsif ($n % 2 == 0) {
        return power($op, $op->($a, $a), $n/2);
    }
    elsif ($n % 2 == 1) {
        return $op->(power($op, $op->($a, $a), int($n/2)), $a);
    }
}

sub block {
    my ($tt, $n) = @_;
    return '_'.$tt.'_block_'.$n;
}

sub rule {
    my ($lhs, $rhs, $action) = @_;
    say sprintf('%-13s ::= %-50s    action => %s', $lhs, join(' ',@$rhs), $action);
}

sub do_flatten_list {
    shift;
    my @r;
    for (@_) {
        push @r, @$_ if ref($_) eq 'ARRAY';
        push @r, $_  if !ref;
    }
}

sub rules_out {
    my ($olhs, $tt, $rules) = @_;

    my %used_rhs;
    my $first_lhs;

    for my $rule (@$rules) {
        my ($lhs, $rhs) = @$rule;

        my $rule_name = block($tt, $lhs);
        $first_lhs = $rule_name if !defined $first_lhs;
        if (!keys %used_rhs) {
            $used_rhs{$rule_name} = 1;
        }

        my $count = sum(@$rhs);
        my @rhs = ($count < 4) 
                ? (($tt) x $count)
                : (map {block($tt, $_)} @$rhs);

        for (@rhs) {
            $used_rhs{$_} = 1;
        }

        if ($used_rhs{$rule_name}) {
            rule($rule_name, \@rhs, 'do_flatten_list');
        }
    }

    rule($olhs, [$first_lhs], 'specified_action');
}

sub generate_rules {
    my ($lhs, $tt, $count, $action) = @_;


    my $rules = power(sub {
        my ($a, $b) = @_;

        return [ 
                   [ 
                       $a->[0][0] + $b->[0][0], 
                       [ $a->[0][0], $b->[0][0] ]
                   ],
                   @$a 
               ];
    },[ [ 1, [ 1 ] ] ], $count);

    rules_out($lhs, $tt, $rules);
}

my ($lhs, $rhs, $count, $action) = @ARGV;

generate_rules($lhs, $rhs, $count, $action);