File Coverage

lib/Chemistry/OpenSMILES/Parser.yp

Criterion	Covered	Total	%
statement	231	235	98.3
branch	94	102	92.1
condition	53	60	88.3
subroutine	22	22	100.0
pod	0	2	0.0
total	400	421	95.0

# Header section

%{

use warnings;
use 5.0100;

use Chemistry::OpenSMILES qw(
    is_aromatic
    is_chiral
    %normal_valence
    toggle_cistrans
);
use Graph::Undirected;
use List::Util qw(any sum);

my %bond_order = (
    '-' => 1,
    '=' => 2,
    '#' => 3,
    '$' => 4,
);

%}

%%

# 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;
            $_[1]->{first_of_chain} = 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',
                                                    ':' );
            }

            delete $_[2]->{first_of_chain};

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

            delete $_[3]->{first_of_chain};

            _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;
            $_[3]->{first_of_chain} = 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} );

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

            delete $_[3]->{first}{first_of_chain};

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

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

            delete $_[4]->{first}{first_of_chain};

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

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

    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 $&;

        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};
            if( !$options->{raw} ) {
                # Promote implicit hydrogen atoms into explicit ones
                if( !exists $atom->{hcount} ) {
                    next if !exists $normal_valence{$atom->{symbol}};
                    my $degree = sum map { exists $bond_order{$_} ? $bond_order{$_} : 1 }
                                     map { $graph->has_edge_attribute( $atom, $_, 'bond' )
                                            ? $graph->get_edge_attribute( $atom, $_, 'bond' )
                                            : '-' }
                                         $graph->neighbours( $atom );
                    $degree = 0 unless $degree;
                    my( $valence ) = grep { $degree <= $_ }
                                          @{$normal_valence{$atom->{symbol}}};
                    next if !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( $atom->{first_of_chain} ) {
                        _unshift_chirality_neighbour( $atom, $hydrogen );
                    } else {
                        _push_chirality_neighbour( $atom, $hydrogen );
                    }
                }
                delete $atom->{hcount};

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

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

                # Adjust chirality for centers having lone pairs
                if( is_chiral $atom &&
                    $atom->{first_of_chain} &&
                    $atom->{chirality} =~ /^@@?$/ &&
                    $atom->{chirality_neighbours} &&
                    scalar @{$atom->{chirality_neighbours}} == 3 ) {
                    $atom->{chirality} = $atom->{chirality} eq '@' ? '@@' : '@';
                }
            }
            delete $atom->{first_of_chain};
        }
    }

    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 ) = grep { defined }
                         ( $self->{USER}{RINGBONDS}{$ring_bond}{bond}, $bond );

        if( $bond && $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};
        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 ) = grep { !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;