# Math::Symbolic::Parser::Yapp
# 
# Based on Parse::Yapp's calculator example

%left   ','
%left   '-' '+'
%left   '*' '/'
%left   NEG
%right  '^'


%%
exp:        NUM                 { $_[1] }
        |   FUNC '(' list ')'  
            {
                if (exists($Math::Symbolic::Parser::Parser_Functions{$_[1]})) {
                    $Math::Symbolic::Parser::Parser_Functions{$_[1]}->($_[1], @{$_[3]})
                }
                else {
                    Math::Symbolic::Operator->new($_[1], @{$_[3]})
                }
            }
        |   PRED '{' exp '}'
            {
                Math::Symbolic::Variable->new(
                    'TRANSFORMATION_HOOK',
                    [$_[1], $_[3]]
                );
            }
        |   PRIVEFUNC
            {
                $_[1] =~ /^([^(]+)\((.*)\)$/ or die "invalid per-object parser extension function: '$_[1]'";
                $_[0]->{__PRIV_EXT_FUNCTIONS}->{$1}->($2);
            }
        |   EFUNC
            {
                $_[1] =~ /^([^(]+)\((.*)\)$/ or die "invalid global parser extension function: '$_[1]'";
                $Math::SymbolicX::ParserExtensionFactory::Functions->{$1}->($2)
            }
        |   VAR                 { $_[1] }
        |   exp '+' exp         { Math::Symbolic::Operator->new('+', $_[1], $_[3]) }
        |   exp '-' exp         { Math::Symbolic::Operator->new('-', $_[1], $_[3]) }
        |   exp '*' exp         { Math::Symbolic::Operator->new('*', $_[1], $_[3]) }
        |   exp '/' exp         { Math::Symbolic::Operator->new('/', $_[1], $_[3]) }
        |   '-' exp %prec NEG   { Math::Symbolic::Operator->new('neg', $_[2]) }
        |   exp '^' exp         { Math::Symbolic::Operator->new('^', $_[1], $_[3]) }
        |   '(' exp ')'         { $_[2] }
;

list:       exp ',' list        { unshift @{$_[3]}, $_[1]; $_[3] }
        |   exp                 { [$_[1]] }
;
%%

use strict;
use warnings;
use Math::Symbolic qw//;
use constant DAT => 0;
use constant OP  => 1;

sub _Error {
    exists $_[0]->YYData->{ERRMSG}
    and do {
        my $x = $_[0]->YYData->{ERRMSG};
        delete $_[0]->YYData->{ERRMSG};
        die $x;
    };
    die "Syntax error in input string while parsing the following string: '".$_[0]->{USER}{INPUT}."'\n";
}

my $Num = qr/[+-]?(?=\d|\.\d)\d*(?:\.\d*)?(?:[Ee]([+-]?\d+))?/o;
my $Ident = qr/[a-zA-Z][a-zA-Z0-9_]*/o;
my $Op =  qr/\+|\-|\*|\/|\^/o;
my $Func = qr/log|partial_derivative|total_derivative|a?(?:sin|sinh|cos|cosh|tan|cot)|exp|sqrt/;
my $Unary = qr/\+|\-/o;

# taken from perlre
my $balanced_parens_re;
$balanced_parens_re = qr{\((?:(?>[^()]+)|(??{$balanced_parens_re}))*\)};

# This is a hack so we can hook into the new() method.
{
    no warnings; no strict;
    *real_new = \&new;
    *new = sub {
        my $class = shift;
        my %args = @_;
        my $predicates = $args{predicates};
        delete $args{predicates};
        my $parser = real_new($class, %args);
        if ($predicates) {
            $parser->{__PREDICATES} = $predicates;
        }
        return $parser;
    };
}

sub _Lexer {
    my($parser)=shift;

    my $ExtFunc     = $Math::SymbolicX::ParserExtensionFactory::RegularExpression || qr/(?!)/;
    my $PrivExtFunc = $parser->{__PRIV_EXT_FUNC_REGEX};

    my $data = $parser->{USER};
    my $predicates = $parser->{__PREDICATES};

    pos($data->{INPUT}) < length($data->{INPUT})
    or  return('',undef);

    # This is a huge hack
    if (defined $predicates) {
        for ($data->{INPUT}) {
            if ($data->{STATE} == DAT) {
                if ($data->{INPUT} =~ /\G($Func)(?=\()/cg) {
                    return('FUNC', $1);
                }
                elsif ($PrivExtFunc ? $data->{INPUT} =~ /\G($PrivExtFunc$balanced_parens_re)/cg : 0) {
                    $data->{STATE} = OP;
                    return('PRIVEFUNC', $1);
                }
                elsif ($data->{INPUT} =~ /\G($ExtFunc$balanced_parens_re)/cg) {
                    $data->{STATE} = OP;
                    return('EFUNC', $1);
                }
                elsif ($data->{INPUT} =~ /\G($predicates)(?=\{)/cg) {
                    return('PRED', $1);
                }
                elsif ($data->{INPUT} =~ /\G($Ident)((?>\'*))(?:\(($Ident(?:,$Ident)*)\))?/cgo) {
                    $data->{STATE} = OP;
                    my $name  = $1;
                    my $ticks = $2;
                    my $sig   = $3;
                    my $n;
                    if (defined $ticks and ($n = length($ticks))) {
                        my @sig = defined($sig) ? (split /,/, $sig) : ('x');
                        my $return = Math::Symbolic::Variable->new(
                          {name=>$name, signature=>\@sig}
                        );
                        my $var = $sig[0];
                        foreach (1..$n) {
                            $return = Math::Symbolic::Operator->new(
                              'partial_derivative',
                              $return, $var,
                            );
                        }
                        return('VAR', $return);
                    }
                    elsif (defined $sig) {
                        return(
                            'VAR', Math::Symbolic::Variable->new({name=>$name, signature=>[split /,/, $sig]})
                        );
                    }
                    else {
                        return('VAR', Math::Symbolic::Variable->new($name));
                    }
                }
                elsif ($data->{INPUT} =~ /\G\(/cgo) {
                    return('(', '(');
                }
                elsif ($data->{INPUT} =~ /\G\{/cgo) {
                    return('{', '{');
                }
                elsif ($data->{INPUT} =~ /\G($Num)/cgo) {
                    $data->{STATE} = OP;
                    return('NUM', Math::Symbolic::Constant->new($1));
                }
                elsif ($data->{INPUT} =~ /\G($Unary)/cgo) {
                    return($1, $1);
                }
                else {
                    my $pos = pos($data->{INPUT});
                    die "Parse error at position $pos of string '$data->{INPUT}'.\nCould not find a suitable token while expecting data (identifier, function, number, etc.).";
                }
            }
            else { # $data->{STATE} == OP
                if ($data->{INPUT} =~ /\G\)/cgo) {
                    return(')', ')');
                }
                elsif ($data->{INPUT} =~ /\G\}/cgo) {
                    return('}', '}');
                }
                elsif ($data->{INPUT} =~ /\G($Op)/cgo) {
                    $data->{STATE} = DAT;
                    return($1, $1);
                }
                elsif ($data->{INPUT} =~ /\G,/cgo) {
                    $data->{STATE} = DAT;
                    return(',', ',');
                }
                else {
                    my $pos = pos($data->{INPUT});
                    die "Parse error at position $pos of string '$data->{INPUT}'.\nCould not find a suitable token while expecting an operator (+, -, etc).";
                }
            }
        }
    } # }}} end if defined $predicates
    else { # {{{ not defined $predicates
        for ($data->{INPUT}) {
            if ($data->{STATE} == DAT) {
                if ($data->{INPUT} =~ /\G($Func)(?=\()/cg) {
                    return('FUNC', $1);
                }
                elsif ($PrivExtFunc ? $data->{INPUT} =~ /\G($PrivExtFunc\s*$balanced_parens_re)/cg : 0) {
                    $data->{STATE} = OP;
                    return('PRIVEFUNC', $1);
                }
                elsif ($data->{INPUT} =~ /\G($ExtFunc\s*$balanced_parens_re)/cg) {
                    $data->{STATE} = OP;
                    return('EFUNC', $1);
                }
                elsif ($data->{INPUT} =~ /\G($Ident)((?>\'*))(?:\(($Ident(?:,$Ident)*)\))?/cgo) {
                    $data->{STATE} = OP;
                    my $name  = $1;
                    my $ticks = $2;
                    my $sig   = $3;
                    my $n;
                    if (defined $ticks and ($n = length($ticks))) {
                        my @sig = defined($sig) ? (split /,/, $sig) : ('x');
                        my $return = Math::Symbolic::Variable->new(
                          {name=>$name, signature=>\@sig}
                        );
                        my $var = $sig[0];
                        foreach (1..$n) {
                            $return = Math::Symbolic::Operator->new(
                              'partial_derivative',
                              $return, $var,
                            );
                        }
                        return('VAR', $return);
                    }
                    elsif (defined $sig) {
                        return(
                            'VAR', Math::Symbolic::Variable->new({name=>$name, signature=>[split /,/, $sig]})
                        );
                    }
                    else {
                        return('VAR', Math::Symbolic::Variable->new($name));
                    }
                }
                elsif ($data->{INPUT} =~ /\G\(/cgo) {
                    return('(', '(');
                }
                elsif ($data->{INPUT} =~ /\G($Num)/cgo) {
                    $data->{STATE} = OP;
                    return('NUM', Math::Symbolic::Constant->new($1));
                }
                elsif ($data->{INPUT} =~ /\G($Unary)/cgo) {
                    return($1, $1);
                }
                else {
                    my $pos = pos($data->{INPUT});
                    die "Parse error at position $pos of string '$data->{INPUT}'.\nCould not find a suitable token while expecting data (identifier, function, number, etc.).";
                }
            }
            else { # $data->{STATE} == OP
                if ($data->{INPUT} =~ /\G\)/cgo) {
                    return(')', ')');
                }
                elsif ($data->{INPUT} =~ /\G($Op)/cgo) {
                    $data->{STATE} = DAT;
                    return($1, $1);
                }
                elsif ($data->{INPUT} =~ /\G,/cgo) {
                    $data->{STATE} = DAT;
                    return(',', ',');
                }
                else {
                    my $pos = pos($data->{INPUT});
                    die "Parse error at position $pos of string '$data->{INPUT}'.\nCould not find a suitable token while expecting an operator (+, -, etc).";
                }
            }
        }
    } # }}} end else => not defined $predicates

}

sub parse {
    my($self)=shift;
    my $in = shift;
    $in =~ s/\s+//g;
    $self->{USER}{STATE} = DAT;
    $self->{USER}{INPUT} = $in;
    pos($self->{USER}{INPUT}) = 0;
    return $self->YYParse( yylex => \&_Lexer, yyerror => \&_Error );
}

sub parsedebug {
    my($self)=shift;
    my $in = shift;
    $in =~ s/\s+//g;
    $self->{USER}{STATE} = DAT;
    $self->{USER}{INPUT} = $in;
    pos($self->{USER}{INPUT}) = 0;
    return $self->YYParse( yydebug => 0x1F, yylex => \&_Lexer, yyerror => \&_Error );
}

1;