view release on metacpan or  search on metacpan

lib/AI/Prolog/Parser/PreProcessor/Math.pm  view on Meta::CPAN

    while ( $prolog =~ $expression ) {
        my ( $old_expression, $lhs, $comp, $rhs ) = ( $1, $2, $3, $4 );
        my $new_rhs        = $class->_parse( $class->_lex($rhs) );
        my $new_expression = sprintf
            "%s(%s, %s)" => $convert{$comp},
            $lhs, $new_rhs;
        $prolog =~ s/\Q$old_expression\E/$new_expression/g;
    }
    return $prolog;
}

sub _lex {
    my ( $class, $rhs ) = @_;
    my $lexer = _lexer($rhs);
    my @tokens;
    while ( my $token = $lexer->() ) {
        push @tokens => $token;
    }
    return \@tokens;
}

sub _lexer {
    my $rhs = shift;

   # the entire "$prev_op" thing is to allow the lexer to be aware of '7 + -3'
   # $op_ok is false on the first pass because it can never be first, but we
   # might have '-7 * (-2 + 3)'
    my $op_ok = 0;
    return sub {
    LEXER: {
            $op_ok = 0, return [ 'OP', $1 ]
                if $op_ok && $rhs =~ /\G ($op)               /gcx;
            $op_ok = 1, return [ 'ATOM', $1 ]
                if $rhs =~ /\G ($simple_math_term) /gcx;
            $op_ok = 0, return [ 'LPAREN', '(' ]
                if $rhs =~ /\G $lparen             /gcx;
            $op_ok = 1, return [ 'RPAREN', ')' ]
                if $rhs =~ /\G $rparen             /gcx;
            redo LEXER if $rhs =~ /\G \s+                 /gcx;
        }
    };
}

sub _parse {
    my ( $class, $tokens ) = @_;
    my $parens_left = 1;
REDUCE: while ($parens_left) {
        my ( $first, $last );
        for my $i ( 0 .. $#$tokens ) {
            my $token = $tokens->[$i];
            next unless $token;
            if ( "(" eq _as_string($token) ) {
                $first = $i;
            }
            if ( ")" eq _as_string($token) ) {
                unless ( defined $first ) {

                # XXX I should probably cache the string and show it.
                # XXX But it doesn't matter because that shouldn't happen here
                    croak(
                        "Parse error in math pre-processor.  Mismatched parens"
                    );
                }
                $last = $i;
                $tokens->[$first] = $class->_parse_group(
                    [ @{$tokens}[ $first + 1 .. $last - 1 ] ] );
                undef $tokens->[$_] for $first + 1 .. $last;
                @$tokens = grep $_ => @$tokens;
                undef $first;
                undef $last;
                redo REDUCE;
            }
        }
        $parens_left = 0 unless defined $first;
    }
    return _as_string( $class->_parse_group($tokens) );
}

sub _parse_group {
    my ( $class, $tokens ) = @_;
    foreach my $op_re ( qr{(?:\*\*|[*/])}, qr{[+-]}, qr/\%/ ) {
        for my $i ( 0 .. $#$tokens ) {
            my $token = $tokens->[$i];
            if ( ref $token && "@$token" =~ /OP ($op_re)/ ) {
                my $curr_op = $1;
                my $prev    = _prev_token( $tokens, $i );
                my $next    = _next_token( $tokens, $i );
                $tokens->[$i] = sprintf
                    "%s(%s, %s)" => $convert{$curr_op},
                    _as_string( $tokens->[$prev] ),
                    _as_string( $tokens->[$next] );
                undef $tokens->[$prev];
                undef $tokens->[$next];
            }
        }
        @$tokens = grep $_ => @$tokens;
    }

    #main::diag Dumper $tokens;
    return $tokens->[0];    # should never have more than on token left
}

sub _prev_token {
    my ( $tokens, $index ) = @_;
    for my $i ( reverse 0 .. $index - 1 ) {
        return $i if defined $tokens->[$i];
    }
}

sub _next_token {
    my ( $tokens, $index ) = @_;
    for my $i ( $index + 1 .. $#$tokens ) {
        return $i if defined $tokens->[$i];
    }
}

sub _as_string { ref $_[0] ? $_[0][1] : $_[0] }

sub match { shift; shift =~ $expression }

# The following are testing hooks