File Coverage

lib/Chemistry/OpenSMILES/Parser.yp

Criterion	Covered	Total	%
statement	242	247	97.9
branch	112	120	93.3
condition	53	60	88.3
subroutine	27	27	100.0
pod	1	2	50.0
total	435	456	95.3

# Header section

%{

=head1 NAME

Chemistry::OpenSMILES::Parser - OpenSMILES format reader

=head1 SYNOPSIS

    use Chemistry::OpenSMILES::Parser;

    my $parser = Chemistry::OpenSMILES::Parser->new;
    my @moieties = $parser->parse( 'C#C.c1ccccc1' );

    $\ = "\n";
    for my $moiety (@moieties) {
        #  $moiety is a Graph::Undirected object
        print scalar $moiety->vertices;
        print scalar $moiety->edges;
    }

=head1 DESCRIPTION

C is OpenSMILES format reader.

=cut

use warnings;
use 5.0100;

use Chemistry::Elements;
use Chemistry::OpenSMILES qw(
    %bond_symbol_to_order
    %normal_valence
    is_aromatic
    is_chiral
    toggle_cistrans
);
use Graph::Undirected;
use List::Util qw( any first sum0 );

=head1 METHODS

=head2 C

Parses a SMILES string and returns an array of disconnected molecular entities as separate instances of L.
Their interpretation is described in detail in L.

=head3 Options

C accepts the following options for key-value pairs in an anonymous hash for its second parameter:

=over

=item C

In OpenSMILES specification the number of attached hydrogen atoms for atoms in square brackets is limited to 9.
IUPAC SMILES+ has increased this number to 99.
With the value of C the parser can be instructed to allow other than 1 digit for attached hydrogen count.

=item C

With C set to anything evaluating to true, the parser will not convert neither implicit nor explicit hydrogen atoms in square brackets to atom hashes of their own.
Moreover, it will not attempt to unify the representations of chirality.
It should be noted, though, that many of subroutines of Chemistry::OpenSMILES expect non-raw data structures, thus processing raw output may produce distorted results.
In particular, C calls from L have to be instructed to expect raw data structure:

    write_SMILES( \@moieties, { raw => 1 } );

This option is now deprecated and may be removed in upcoming versions.

=item C

With C set to anything evaluating to true, the parser will emit warnings about bot bonds used in parentheses.
This could be used to detect the unnecessary use of dot bonds.

=back

=head1 CAVEATS

Deprecated charge notations (C<--> and C<++>) are supported.

OpenSMILES specification mandates a strict order of ring bonds and branches:

    branched_atom ::= atom ringbond* branch*

Chemistry::OpenSMILES::Parser supports both the mandated, and inverted
structure, where ring bonds follow branch descriptions.

Whitespace is not supported yet. SMILES descriptors must be cleaned of
it before attempting reading with Chemistry::OpenSMILES::Parser.

The derivation of implicit hydrogen counts for aromatic atoms is not
unambiguously defined in the OpenSMILES specification. Thus only
aromatic carbon is accounted for as if having valence of 3.

Chiral atoms with three neighbours are interpreted as having a lone pair of electrons one of its chiral neighbours.
The lone pair is always understood as being the second in the order of neighbour enumeration, except when the atom with the lone pair starts a chain.
In that case lone pair is the first.

=cut

%}

%%

# Rules section

# The top-level 'filter' rule

smiles: chain ;

chain: atom
        {
            my $g = Graph::Undirected->new( refvertexed => 1 );
            $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] );

            if( is_aromatic $_[1]->{last} && is_aromatic $_[2] ) {
                $_[2]->{graph}->set_edge_attribute( $_[1]->{last},
                                                    $_[2],
                                                    'bond',
                                                    ':' );
            }

            _push_chirality_neighbour( $_[1]->{last}, $_[2] );
            _push_chirality_neighbour( $_[2], $_[1]->{last} );

            $_[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] );
            }

            _push_chirality_neighbour( $_[1]->{last}, $_[3] );
            _push_chirality_neighbour( $_[3], $_[1]->{last} );

            $_[1]->{last} = $_[3];

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

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

            $_[1]->{last} = $_[3];

            return $_[1];
        }
     | chain '(' chain ')'
        {
            if( $_[0]->{USER}{OPTIONS}{report_unnecessary_dot_usage} &&
                $_[3]->{first}{index} != $_[3]->{last}{index} ) {
                warn 'unnecessary use of dot in parenthesis' . "\n";
            }

            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} );

            if( is_aromatic $_[1]->{last} && is_aromatic $_[3]->{first} ) {
                $_[1]->{last}{graph}->set_edge_attribute( $_[1]->{last},
                                                          $_[3]->{first},
                                                          'bond',
                                                          ':' );
            }

            _push_chirality_neighbour( $_[1]->{last}, $_[3]->{first} );
            _unshift_chirality_neighbour( $_[3]->{first}, $_[1]->{last} );

            return $_[1];
        }
     | chain '(' bond chain ')'
        {
            if( $_[0]->{USER}{OPTIONS}{report_unnecessary_dot_usage} &&
                $_[4]->{first}{index} != $_[4]->{last}{index} ) {
                warn 'unnecessary use of dot in parenthesis' . "\n";
            }

            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} );
            }

            _push_chirality_neighbour( $_[1]->{last}, $_[4]->{first} );
            _unshift_chirality_neighbour( $_[4]->{first}, $_[1]->{last} );

            return $_[1];
        }
     | chain '(' '.' chain ')'
        {
            if( $_[0]->{USER}{OPTIONS}{report_unnecessary_dot_usage} ) {
                warn 'unnecessary use of dot in parenthesis' . "\n";
            }

            return $_[1];
        }

     # 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;
    }

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

    my $hcount_re = 'H[0-9]?';
    if( defined $self->{USER}{OPTIONS}{max_hydrogen_count_digits} ) {
        $hcount_re = sprintf 'H[0-9]{0,%d}',
                             $self->{USER}{OPTIONS}{max_hydrogen_count_digits};
    }

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

        # Check for existence of the seen element
        # Due to https://github.com/briandfoy/chemistry-elements/issues/16, Chemistry::Elements < 1.079 has 'Ha' instead of 'Db'
        if(      $atom->{symbol} eq '*'  || $atom->{symbol} eq 'Db' ) {
            # OK
        } elsif( $atom->{symbol} eq lc $atom->{symbol} &&
                 $atom->{symbol} !~ /^(as|se|[bcnops])$/ ) {
            die "aromatic chemical element '$atom->{symbol}' is not allowed\n";
        } elsif( $atom->{symbol} eq 'Ha' ||
                 !Chemistry::Elements->new( $atom->{symbol} ) ) {
            die "chemical element with symbol '$atom->{symbol}' is unknown\n";
        }

        if( $atom->{charge} ) {
            $atom->{charge} =~ s/^([-+])$/${1}1/;
            $atom->{charge} =~ s/^([-+])\1$/${1}2/;
            $atom->{charge} = int $atom->{charge};
        }

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

        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->{USER}{OPTIONS}   = $options;
    $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 (sort { $a->{number} <=> $b->{number} } $graph->vertices) {
            delete $atom->{graph};
            delete $atom->{index};
            next if $options->{raw};

            # Promote implicit hydrogen atoms into explicit ones
            if( !exists $atom->{hcount} ) {
                next if !exists $normal_valence{$atom->{symbol}};
                my $degree = sum0 map { $_ ne ':' && exists $bond_symbol_to_order{$_} ? $bond_symbol_to_order{$_} : 1 }
                                  map { $graph->has_edge_attribute( $atom, $_, 'bond' )
                                            ? $graph->get_edge_attribute( $atom, $_, 'bond' )
                                            : '-' }
                                     $graph->neighbours( $atom );
                my $valence = first { $degree <= $_ }
                                    @{$normal_valence{$atom->{symbol}}};
                next unless defined $valence;
                $atom->{hcount} = $valence - $degree;
            }
            for (1..$atom->{hcount}) {
                my $hydrogen = { symbol => 'H',
                                 class  => 0,
                                 number => $self->{USER}{ATOMNO} };
                $graph->add_edge( $atom, $hydrogen );
                $self->{USER}{ATOMNO} ++;
                if( is_chiral $atom ) {
                    if( $atom->{chirality_neighbours} ) {
                        if( any { $_->{number} < $atom->{number} } @{$atom->{chirality_neighbours}} ) {
                            splice @{$atom->{chirality_neighbours}}, 1, 0, $hydrogen;
                        } else {
                            _unshift_chirality_neighbour( $atom, $hydrogen );
                        }
                    } else {
                        # This only happens if chiral atom does not have neighbours other than implicit hydrogens.
                        # This is degenerate case anyway.
                        _push_chirality_neighbour( $atom, $hydrogen );
                    }
                }
            }
            delete $atom->{hcount};

            # Unify the representation of chirality
            if( is_chiral $atom ) {
                if( $atom->{chirality} =~ /^@@?$/ ) {
                    if(      $graph->degree( $atom ) == 2 ) {
                        $atom->{chirality} =~ s/@+/'@AL' . length $&/e;
                    } elsif( $graph->degree( $atom ) == 5 ) {
                        $atom->{chirality} =~ s/@+/'@TB' . length $&/e;
                    } elsif( $graph->degree( $atom ) == 6 ) {
                        $atom->{chirality} =~ s/@+/'@OH' . length $&/e;
                    }
                }

                $atom->{chirality} =~ s/^\@TH1$/@/;
                $atom->{chirality} =~ s/^\@TH2$/@@/;
            }
        }
    }

    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 !~ /^[\\\/]$/ &&
              $bond ne $self->{USER}{RINGBONDS}{$ring_bond}{bond}) ||
             ($bond eq '\\' &&
              $self->{USER}{RINGBONDS}{$ring_bond}{bond} ne '/') ||
             ($bond eq '/' &&
              $self->{USER}{RINGBONDS}{$ring_bond}{bond} ne '\\')) ) {
            die "$0: ring bond types for ring bond $ring_bond do not match.\n";
        }
        $bond = first { defined }
                      ( $self->{USER}{RINGBONDS}{$ring_bond}{bond}, $bond );

        if( $bond && !defined $self->{USER}{RINGBONDS}{$ring_bond}{bond} ) {
            # If cis/trans marker is not specified when cis/trans bond is
            # seen first, it has to be inverted:
            $bond = toggle_cistrans $bond;
        }

        my $ring_atom = $self->{USER}{RINGBONDS}{$ring_bond}{atom};
        die "atom cannot be bonded to itself\n" if $atom == $ring_atom;
        if( !$bond && is_aromatic $ring_atom && is_aromatic $atom ) {
            $bond = ':';
        }
        if( $bond && $bond ne '-' ) {
            $atom->{graph}->set_edge_attribute( $ring_atom,
                                                $atom,
                                                'bond',
                                                $bond );
        } else {
            $atom->{graph}->add_edge( $ring_atom, $atom );
        }
        delete $self->{USER}{RINGBONDS}{$ring_bond};

        if( is_chiral $ring_atom && $ring_atom->{chirality_neighbours} ) {
            my $pos = first { !ref  $ring_atom->{chirality_neighbours}[$_] &&
                              $ring_atom->{chirality_neighbours}[$_] == $ring_bond }
                            0..$#{$ring_atom->{chirality_neighbours}};
            $ring_atom->{chirality_neighbours}[$pos] = $atom if defined $pos;
        }
        _push_chirality_neighbour( $atom, $ring_atom );
    } else {
        $self->{USER}{RINGBONDS}{$ring_bond} =
            { atom => $atom, $bond ? ( bond => $bond ) : () };

        # Record a placeholder for later addition of real chirality
        # neighbour, which will be identified by the ring bond number
        _push_chirality_neighbour( $atom, $ring_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 _push_chirality_neighbour
{
    my( $atom1, $atom2 ) = @_;
    return unless is_chiral $atom1;
    push @{$atom1->{chirality_neighbours}}, $atom2;
}

sub _unshift_chirality_neighbour
{
    my( $atom1, $atom2 ) = @_;
    return unless is_chiral $atom1;
    unshift @{$atom1->{chirality_neighbours}}, $atom2;
}

1;

=head1 AUTHORS

Andrius Merkys, [e-mail]

=cut