# Header section

%{

use warnings;
use 5.0100;

use Graph::Undirected;

%}

%%

# Rules section

# The top-level 'filter' rule

smiles: chain ;

chain: atom
        {
            my $g = Graph::Undirected->new;
            $g->add_vertex( $_[1] );
            push @{$_[0]->{USER}{GRAPHS}}, $g;

            $_[1]->{graph} = $g;
            $_[1]->{index} = @{$_[0]->{USER}{GRAPHS}}-1;

            return { first => $_[1],
                     last  => $_[1] };
        }
     | chain atom
        {
            $_[2]->{graph} = $_[1]->{last}{graph};
            $_[2]->{index} = $_[1]->{last}{index};

            $_[2]->{graph}->add_edge( $_[1]->{last}, $_[2] );
            $_[1]->{last} = $_[2];

            return $_[1];
        }
     | chain bond atom
        {
            $_[3]->{graph} = $_[1]->{last}{graph};
            $_[3]->{index} = $_[1]->{last}{index};

            if( $_[2] ne '-' ) {
                $_[3]->{graph}->set_edge_attribute( $_[1]->{last},
                                                    $_[3],
                                                    'bond',
                                                    $_[2] );
            } else {
                $_[3]->{graph}->add_edge( $_[1]->{last}, $_[3] );
            }
            $_[1]->{last} = $_[3];

            return $_[1];
        }
     | chain '.' atom
        {
            my $g = Graph::Undirected->new;
            $g->add_vertex( $_[3] );
            push @{$_[0]->{USER}{GRAPHS}}, $g;

            $_[3]->{graph} = $g;
            $_[3]->{index} = @{$_[0]->{USER}{GRAPHS}}-1;

            return { first => $_[3],
                     last  => $_[3] };
        }
     | chain '(' chain ')'
        {
            if( $_[1]->{last}{index} != $_[3]->{first}{index} ) {
                $_[0]->_merge_graphs( $_[1]->{last}{index},
                                      $_[3]->{first}{index} );
            }

            $_[1]->{last}{graph}->add_edge( $_[1]->{last}, $_[3]->{first} );
            return $_[1];
        }
     | chain '(' bond chain ')'
        {
            if( $_[1]->{last}{index} != $_[4]->{first}{index} ) {
                $_[0]->_merge_graphs( $_[1]->{last}{index},
                                      $_[4]->{first}{index} );
            }

            if( $_[3] ne '-' ) {
                $_[1]->{last}{graph}->set_edge_attribute( $_[1]->{last},
                                                          $_[4]->{first},
                                                          'bond',
                                                          $_[3] );
            } else {
                $_[1]->{last}{graph}->add_edge( $_[1]->{last},
                                                $_[4]->{first} );
            }

            return $_[1];
        }
     | chain '(' '.' chain ')'

     # According to the specification of OpenSMILES, ring bonds are
     # allowed only before the branch enumeration. However, I think this
     # is too strict.

     | chain ringbond
        {
            $_[0]->_add_ring_bond( $_[1]->{last}, $_[2] );
            return $_[1];
        }
     | chain bond ringbond
        {
            $_[0]->_add_ring_bond( $_[1]->{last}, $_[3], $_[2] );
            return $_[1];
        }
     ;

bond: '-' | '=' | '#' | '$' | ':' | '/' | '\\' ;

%%

# Footer section

sub _Error
{
    my( $self ) = @_;
    close $self->{USER}{FILEIN} if $self->{USER}{FILEIN};

    if( ${$self->{TOKEN}} eq '' &&
        grep { defined $_ && !ref $_ && $_ eq '(' }
        map { $_->[1] } @{$self->{STACK}} ) {
        die "$0: syntax error: missing closing parenthesis.\n";
    }

    if( ${$self->{TOKEN}} eq ')' ) {
        die "$0: syntax error: unbalanced parentheses.\n";
    }

    my $msg = "$0: syntax error at position $self->{USER}{CHARNO}";
    if( $self->YYData->{INPUT} ) {
        $self->YYData->{INPUT} =~ s/\n$//;
        die "$msg: '" . $self->YYData->{INPUT} . "'.\n";
    } else {
        die "$msg.\n";
    }
}

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

    # If the line is empty and the input is originating from the file,
    # another line is read.
    if( !$self->YYData->{INPUT} && $self->{USER}{FILEIN} ) {
        my $filein = $self->{USER}{FILEIN};
        $self->YYData->{INPUT} = <$filein>;
        $self->{USER}{CHARNO} = 0;
    }

    $self->YYData->{INPUT} =~ s/^(\s+)//;
    $self->{USER}{CHARNO} += length $1 if defined $1;

    # Bracket atoms
    if( $self->YYData->{INPUT} =~ s/^\[ (?<isotope>[0-9]+)?
                                        (?<symbol>[A-Za-z][a-z]?|\*)
                                        (?<chirality>@(
                                         (TH|AL)[12]       |
                                         SP     [123]      |
                                         (TB|OH)[0-9]{1,2} |
                                         @?
                                         ))?
                                        (?<hcount>H[0-9]?)?
                                        (?<charge>--|\+\+|[-+][0-9]{0,2})?
                                        (:(?<class>[0-9]+))? \]//x ) {
        my $atom = { %+, number => $self->{USER}{ATOMNO} };
        $self->{USER}{ATOMNO} ++;
        $self->{USER}{CHARNO} += length $&;

        if( $atom->{hcount} ) {
            $atom->{hcount} =~ s/^H//;
            $atom->{hcount} = $atom->{hcount} ? int $atom->{hcount} : 1;
        }

        if( $atom->{isotope} ) {
            $atom->{isotope} = int $atom->{isotope};
        }

        # Atom class is an arbitrary number, 0 by default
        $atom->{class} = exists $atom->{class} ? int $atom->{class} : 0;

        return ( 'atom', $atom );
    }

    # Bracketless atoms
    if( $self->YYData->{INPUT} =~ s/^(Br|Cl|[BCINOPSFbcnops])// ) {
        my $atom = { symbol => $1,
                     class  => 0,
                     number => $self->{USER}{ATOMNO} };
        $self->{USER}{ATOMNO} ++;
        $self->{USER}{CHARNO} += length $&;
        return ( 'atom', $atom );
    }

    # Ring bonds
    if( $self->YYData->{INPUT} =~ s/^%([0-9]{2})// ||
        $self->YYData->{INPUT} =~ s/^([0-9])// ) {
        $self->{USER}{CHARNO} += length $&;
        return ( 'ringbond', int $1 );
    }

    my $char = substr( $self->YYData->{INPUT}, 0, 1 );
    if( $char ne '' ) {
        $self->YYData->{INPUT} = substr( $self->YYData->{INPUT}, 1 );
    }
    $self->{USER}{CHARNO} ++;
    return( $char, $char );
}

sub parse
{
    my( $self, $string, $options ) = @_;
    $options = {} unless $options;

    $self->YYData->{INPUT}   = $string;
    $self->{USER}{GRAPHS}    = [];
    $self->{USER}{RINGBONDS} = {};
    $self->{USER}{ATOMNO}    = 0;
    $self->{USER}{CHARNO}    = 0;
    $self->YYParse( yylex => \&_Lexer,
                    yyerror => \&_Error,
                    yydebug => $options->{debug} );

    if( scalar keys %{$self->{USER}{RINGBONDS}} ) {
        die "$0: unclosed ring bond(s) detected: " .
            join( ', ', sort { $a <=> $b } keys %{$self->{USER}{RINGBONDS}} ) .
            ".\n";
    }

    my @graphs = grep { defined } @{$self->{USER}{GRAPHS}};
    for my $graph (@graphs) {
        for my $atom ($graph->vertices) {
            delete $atom->{graph};
            delete $atom->{index};
            if( !$options->{raw} ) {
                next unless exists $atom->{hcount};
                for (1..$atom->{hcount}) {
                    $graph->add_edge( $atom,
                                      { symbol => 'H',
                                        class  => 0,
                                        number => $self->{USER}{ATOMNO} } );
                    $self->{USER}{ATOMNO} ++;
                }
                delete $atom->{hcount};
            }
        }
    }

    return @graphs;
}

sub _add_ring_bond
{
    my( $self, $atom, $ring_bond, $bond ) = @_;
    if( $self->{USER}{RINGBONDS}{$ring_bond} ) {
        $self->_merge_graphs( $self->{USER}{RINGBONDS}{$ring_bond}{atom}{index},
                              $atom->{index} );

        if( $bond && $self->{USER}{RINGBONDS}{$ring_bond}{bond} &&
            $bond ne $self->{USER}{RINGBONDS}{$ring_bond}{bond} ) {
            die "$0: ring bond types for ring bond $ring_bond do not match.\n";
        }
        ( $bond ) = grep { defined }
                         ( $bond, $self->{USER}{RINGBONDS}{$ring_bond}{bond} );
        if( $bond && $bond ne '-' ) {
            $atom->{graph}->set_edge_attribute( $self->{USER}{RINGBONDS}{$ring_bond}{atom},
                                                $atom,
                                                'bond',
                                                $bond );
        } else {
            $atom->{graph}->add_edge( $self->{USER}{RINGBONDS}{$ring_bond}{atom},
                                      $atom );
        }
        delete $self->{USER}{RINGBONDS}{$ring_bond};
    } else {
        $self->{USER}{RINGBONDS}{$ring_bond} =
            { atom => $atom, $bond ? ( bond => $bond ) : () };
    }
}

sub _merge_graphs
{
    my( $self, $index1, $index2 ) = @_;
    return if $index1 == $index2;

    my $g1 = $self->{USER}{GRAPHS}[$index1];
    my $g2 = $self->{USER}{GRAPHS}[$index2];

    for ($g2->vertices) {
        $_->{graph} = $g1;
        $_->{index} = $index1;
    }
    $g1->add_vertices( $g2->vertices );

    for ($g2->edges) {
        my  $attributes = $g2->get_edge_attributes( @$_ );
        if( $attributes ) {
            $g1->set_edge_attributes( @$_, $attributes );
        } else {
            $g1->add_edge( @$_ );
        }
    }

    $self->{USER}{GRAPHS}[$index2] = undef;
}

sub _sprint_atom
{
    my( $atom ) = @_;
    return '[' . (exists $atom->{isotope}   ? $atom->{isotope}   : '') .
                 $atom->{symbol} .
                 (exists $atom->{chirality} ? $atom->{chirality} : '') .
                 (exists $atom->{hcount}    ? 'H' . $atom->{hcount} : '') .
                 (exists $atom->{charge}    ? $atom->{charge}    : '') .
                 (exists $atom->{class} && $atom->{class}
                    ? ':' . $atom->{class} : '') .
           ']';
}

1;