# --*-Perl-*----------------------------------------------------
#$Author: antanas $
#$Date: 2022-07-31 04:53:56 +0300 (Sun, 31 Jul 2022) $
#$Revision: 9351 $
#$URL: svn+ssh://www.crystallography.net/home/coder/svn-repositories/cod-tools/tags/v3.8.1/src/lib/perl5/COD/Formulae/Parser/AdHoc/AdHoc.yp $
# --------------------------------------------------------------
#
# --------------------------------------------------------------
# copy directly to PERL module:
%{
use warnings;
use COD::UserMessage qw( sprint_message );

$COD::Formulae::Parser::AdHoc::version = '1.0';

my $SVNID = '$Id: AdHoc.yp 9351 2022-07-31 01:53:56Z antanas $';

# 0 - no debug
# 1 - only YAPP output (type -> value)
# 2 - lex & yapp output
# 3 - generated array dump
$COD::Formulae::Parser::AdHoc::debug = 0;

%}
# --------------------------------------------------------------

# --------------------------------------------------------------
# begin of body
# --------------------------------------------------------------

%%
##         :        #empty
##                 {
##                         $_[0]->{USER}->{FormulaSum} = {};
##                 }

formula
    : item
    | formula SPACE item
    | formula opt_spaces ',' opt_spaces item
    | formula opt_spaces '*' opt_spaces item
;

opt_spaces
   : spaces
   | # empty
   ;

spaces
   : SPACE
   | spaces SPACE
   ;

item
        :        ELEMENT
                {
                    ## print ">>> ELEMENT: ",$_[1],"\n";
                    $_[0]->{USER}->{FormulaSum}{$_[1]} += 1;
                }
        |        ELEMENT NUMBER
                {
                    ## print ">>> ELEMENT: ",$_[1],"\n";
                    $_[0]->{USER}->{FormulaSum}{$_[1]} += $_[2];
                }

        |        item ELEMENT
                {
                    ## print ">>> ELEMENT: ",$_[1],"\n";
                    $_[0]->{USER}->{FormulaSum}{$_[2]} += 1;
                }

        |        item ELEMENT NUMBER
                {
                    ## print ">>> ELEMENT: ",$_[2], " number: ", $_[3], "\n";
                    $_[0]->{USER}->{FormulaSum}{$_[2]} += $_[3];
                }

        |  formula_start opt_space formula opt_space ')'
                {
                    my $subformula = $_[0]->{USER}->{FormulaSum};
                    $_[0]->{USER}->{FormulaSum} =
                        pop @{$_[0]->{USER}->{FormulaStack}};

                    for my $key ( keys %{$subformula} ) {
                        $_[0]->{USER}->{FormulaSum}->{$key} +=
                            $subformula->{$key};
                    }
                }

        |  formula_start
           opt_space formula opt_space ')' NUMBER
                {
                    my $subformula = $_[0]->{USER}->{FormulaSum};
                    $_[0]->{USER}->{FormulaSum} =
                        pop @{$_[0]->{USER}->{FormulaStack}};

                    for my $key ( keys %{$subformula} ) {
                        $_[0]->{USER}->{FormulaSum}->{$key} +=
                            $subformula->{$key} * $_[6];
                    }
                }

        |       NUMBER formula_start
                opt_space formula opt_space ')'
                {
                    my $subformula = $_[0]->{USER}->{FormulaSum};
                    $_[0]->{USER}->{FormulaSum} =
                        pop @{$_[0]->{USER}->{FormulaStack}};

                    for my $key ( keys %{$subformula} ) {
                        $_[0]->{USER}->{FormulaSum}->{$key} +=
                            $subformula->{$key} * $_[1];
                    }
                }

        |  bracket_start opt_space formula opt_space ']'
                {
                    my $subformula = $_[0]->{USER}->{FormulaSum};
                    $_[0]->{USER}->{FormulaSum} =
                        pop @{$_[0]->{USER}->{FormulaStack}};

                    for my $key ( keys %{$subformula} ) {
                        $_[0]->{USER}->{FormulaSum}->{$key} +=
                            $subformula->{$key};
                    }
                }

        |  bracket_start
           opt_space formula opt_space ']' NUMBER
                {
                    my $subformula = $_[0]->{USER}->{FormulaSum};
                    $_[0]->{USER}->{FormulaSum} =
                        pop @{$_[0]->{USER}->{FormulaStack}};

                    for my $key ( keys %{$subformula} ) {
                        $_[0]->{USER}->{FormulaSum}->{$key} +=
                            $subformula->{$key} * $_[6];
                    }
                }

        |       NUMBER bracket_start
                opt_space formula opt_space ']'
                {
                    my $subformula = $_[0]->{USER}->{FormulaSum};
                    $_[0]->{USER}->{FormulaSum} =
                        pop @{$_[0]->{USER}->{FormulaStack}};

                    for my $key ( keys %{$subformula} ) {
                        $_[0]->{USER}->{FormulaSum}->{$key} +=
                            $subformula->{$key} * $_[1];
                    }
                }
;

formula_start
    : '('
        {
            push @{$_[0]->{USER}->{FormulaStack}},
                  $_[0]->{USER}->{FormulaSum};
            $_[0]->{USER}->{FormulaSum} = {}
        }
    ;

bracket_start
    : '['
        {
            push @{$_[0]->{USER}->{FormulaStack}},
                  $_[0]->{USER}->{FormulaSum};
            $_[0]->{USER}->{FormulaSum} = {}
        }
    ;

opt_space
    : SPACE
    |
    ;

%%
# --------------------------------------------------------------
# begin of footer
# --------------------------------------------------------------

sub _Error
{
        $_[0]->YYData->{ERRCOUNT}++;
        exists $_[0]->YYData->{ERRMSG}
        and do {
                warn $_[0]->YYData->{ERRMSG};
                delete $_[0]->YYData->{ERRMSG};
                return;
        };
        warn sprint_message( {
            'program'      => $0,
            'err_level'    => 'ERROR',
            'message'      => 'incorrect formula syntax',
            'line_no'      => 0,
            'column_no'    => $_[0]->YYData->{VARS}{token_prev_pos}+1,
            'line_content' => $_[0]->YYData->{LINE}
        } );
}

sub PrintFormula
{
    my ( $self ) = @_;

    my $formula = $self->SprintFormula();

    print $formula, "\n" if defined $formula;
}

sub SprintFormula
{
    my ($parser) = @_;

    # Chemical formulas, according the IUCr recommendations, should
    # use the 'Hill' system used by Chemical Abstracts:
    #
    # the order of the elements within any group or moiety depends on
    # whether carbon is present or not. If carbon is present, the
    # order should be: C, then H, then the other elements in
    # alphabetical order of their symbol. If carbon is not present,
    # the elements are listed purely in alphabetical order of their
    # symbol.

    # References:
    # 1. http://www.iucr.org/__data/iucr/cifdic_html/1/cif_core.dic/Cchemical_formula.html
    # (2009-06-25)
    #
    # 2. Dictionary of organic compounds By J. I. G. (John Ivan
    # George) Cadogan, American Chemical Society. Chemical Abstracts
    # Service, P. H. Rhodes, Steven V Ley; page 106 (found by Google
    # book search on 2009-06-25)

    my $formula;

    if( $parser->YYNberr() == 0 ) {
        my %formula = %{$parser->{USER}->{FormulaSum}};
        $formula = '';
        my $separator = '';

        if( exists $formula{C} ) {
            if( $formula{C} == 1 ) {
                $formula .= 'C';
            } else {
                $formula .= 'C' . $formula{C};
            }
            delete $formula{C};
            $separator = ' ';
            if( exists $formula{H} ) {
                if( $formula{H} == 1 ) {
                    $formula .= $separator . 'H';
                } else {
                    $formula .= $separator . 'H' . $formula{H};
                }
                delete $formula{H};
            }
        }
        for my $key (sort {$a cmp $b} keys %formula) {
            $formula .= $separator . $key . ($formula{$key} != 1 ?
                $formula{$key} : '');
            $separator = ' ';
        }
    }
    return $formula;
}

my $INTEGER  = qr/[-+]?[0-9]+/s;
my $EXPONENT = qr/e[-+]?[0-9]+/is;
my $FLOAT11  = qr/(?: $INTEGER $EXPONENT)/ix;
my $FLOAT21  = qr/(?: [+-]? [0-9]* \. [0-9]+ $EXPONENT ?)/ix;
my $FLOAT31  = qr/(?: $INTEGER \. $EXPONENT ?)/ix;
my $FLOAT    = qr/(?: (?: $FLOAT11 | $FLOAT21 | $FLOAT31))/six;
my $NUMBER   = qr/(?: $FLOAT | $INTEGER  )/ix;

sub _Lexer
{
    my($parser) = shift;

    if( !defined $parser->YYData->{INPUT} ||
        $parser->YYData->{INPUT} =~ m/^\s*$/ ) {
        ## print ">>> lexing: empty line...\n";
        return('',undef);
    } else {
        ## $parser->YYData->{INPUT} =~ s/^\s*//;
        ## print ">>> lexing: ", $parser->YYData->{INPUT}, "\n";

        $parser->YYData->{VARS}{token_prev_pos} = $parser->YYData->{VARS}{token_pos};
        for($parser->YYData->{INPUT}) {
            if( s/^([A-Za-z][a-z]?)// ) {
                $parser->YYData->{VARS}{token_pos} += length($1);
                return( 'ELEMENT', $1 );
            }
            if( s/^($NUMBER)//x ) {
                $parser->YYData->{VARS}{token_pos} += length($1);
                return( 'NUMBER', $1 );
            }
            if( s/^(\()// ) {
                $parser->YYData->{VARS}{token_pos} += length($1);
                return ( '(', $1 );
            }
            if( s/^(\))// ) {
                $parser->YYData->{VARS}{token_pos} += length($1);
                return ( ')', $1 );
            }
            if( s/^(\[)// ) {
                $parser->YYData->{VARS}{token_pos} += length($1);
                return ( '[', $1 );
            }
            if( s/^(\])// ) {
                $parser->YYData->{VARS}{token_pos} += length($1);
                return ( ']', $1 );
            }
            if( s/^([\s.]+)// ) {
                $parser->YYData->{VARS}{token_pos} += length($1);
                return ( 'SPACE', $1 );
            }
            if( s/^(.)// ) {
                $parser->YYData->{VARS}{token_pos} += length($1);
                return ( $1, $1 );
            }
            else {
                return( '', undef );
            }
        }
    }
}

sub Run
{
    my ( $self, $filename ) = @_;

    $self->ParseFile( $filename );
}

sub ParseString
{
    my ($self, $text) = @_;

    $self->YYData->{INPUT} = $text;
    $self->YYData->{LINE} = $text;

    $self->YYData->{VARS}{token_prev_pos} = 0;
    $self->YYData->{VARS}{token_pos} = 0;

    $| = 1;

    if( $COD::Formulae::Parser::AdHoc::debug >= 2 &&
        $COD::Formulae::Parser::AdHoc::debug < 3) {
        $self->YYParse( yylex => \&_Lexer,
                        yyerror => \&_Error,
                        yydebug => 0x05 );
    } else {
        $self->YYParse( yylex => \&_Lexer, yyerror => \&_Error );
    }
    if( $self->YYNberr() == 0 ) {
        if( $COD::Formulae::Parser::AdHoc::debug >= 1 &&
            $COD::Formulae::Parser::AdHoc::debug < 3 ) {
            print "File syntax is CORRECT!\n";
        }
    } else {
        if( $COD::Formulae::Parser::AdHoc::debug >= 1 &&
            $COD::Formulae::Parser::AdHoc::debug < 3 ) {
            print "Syntax check failed.\n";
        }
    }
    return $self->{USER}->{FormulaSum};
}

sub ParseFile
{
    my($self) = shift;
    my($filename) = shift;

    $filename = '-' unless $filename;

    $self->{USER}{FILENAME} = $filename;

    open( my $formula_file, $filename ) or
        die( "could not open file '$filename' for input: $!" );

    my $formula_text = <$formula_file>;

    close $formula_file;

    return $self->ParseString( $formula_text );
}

return 1;
