File Coverage

blib/lib/Chemistry/OpenSMILES/Parser.pm

Criterion	Covered	Total	%
statement	9	9	100.0
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	12	12	100.0

####################################################################
#
#    This file was generated using Parse::Yapp version 1.21.
#
#        Don't edit this file, use source file instead.
#
#             ANY CHANGE MADE HERE WILL BE LOST !
#
####################################################################
package Chemistry::OpenSMILES::Parser;
use vars qw ( @ISA );
use strict;

@ISA= qw ( Parse::Yapp::Driver );
use Parse::Yapp::Driver;

#line 3 "lib/Chemistry/OpenSMILES/Parser.yp"


use warnings;
use 5.0100;

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



sub new {
        my($class)=shift;
        ref($class)
    and $class=ref($class);

    my($self)=$class->SUPER::new( yyversion => '1.21',
                                  yystates =>
[
	{#State 0
		ACTIONS => {
			'atom' => 3
		},
		GOTOS => {
			'chain' => 2,
			'smiles' => 1
		}
	},
	{#State 1
		ACTIONS => {
			'' => 4
		}
	},
	{#State 2
		ACTIONS => {
			"-" => 13,
			"." => 12,
			"=" => 14,
			'atom' => 15,
			"#" => 16,
			"(" => 6,
			"/" => 7,
			":" => 9,
			'ringbond' => 8,
			"\\" => 11,
			"\$" => 10
		},
		DEFAULT => -1,
		GOTOS => {
			'bond' => 5
		}
	},
	{#State 3
		DEFAULT => -2
	},
	{#State 4
		DEFAULT => 0
	},
	{#State 5
		ACTIONS => {
			'atom' => 18,
			'ringbond' => 17
		}
	},
	{#State 6
		ACTIONS => {
			"/" => 7,
			":" => 9,
			"\\" => 11,
			"\$" => 10,
			"#" => 16,
			'atom' => 3,
			"-" => 13,
			"." => 21,
			"=" => 14
		},
		GOTOS => {
			'bond' => 19,
			'chain' => 20
		}
	},
	{#State 7
		DEFAULT => -16
	},
	{#State 8
		DEFAULT => -9
	},
	{#State 9
		DEFAULT => -15
	},
	{#State 10
		DEFAULT => -14
	},
	{#State 11
		DEFAULT => -17
	},
	{#State 12
		ACTIONS => {
			'atom' => 22
		}
	},
	{#State 13
		DEFAULT => -11
	},
	{#State 14
		DEFAULT => -12
	},
	{#State 15
		DEFAULT => -3
	},
	{#State 16
		DEFAULT => -13
	},
	{#State 17
		DEFAULT => -10
	},
	{#State 18
		DEFAULT => -4
	},
	{#State 19
		ACTIONS => {
			'atom' => 3
		},
		GOTOS => {
			'chain' => 23
		}
	},
	{#State 20
		ACTIONS => {
			":" => 9,
			'ringbond' => 8,
			"/" => 7,
			"\$" => 10,
			"\\" => 11,
			"(" => 6,
			'atom' => 15,
			"#" => 16,
			"-" => 13,
			")" => 24,
			"." => 12,
			"=" => 14
		},
		GOTOS => {
			'bond' => 5
		}
	},
	{#State 21
		ACTIONS => {
			'atom' => 3
		},
		GOTOS => {
			'chain' => 25
		}
	},
	{#State 22
		DEFAULT => -5
	},
	{#State 23
		ACTIONS => {
			"\$" => 10,
			"\\" => 11,
			'ringbond' => 8,
			":" => 9,
			"/" => 7,
			"(" => 6,
			"#" => 16,
			'atom' => 15,
			"=" => 14,
			"." => 12,
			")" => 26,
			"-" => 13
		},
		GOTOS => {
			'bond' => 5
		}
	},
	{#State 24
		DEFAULT => -6
	},
	{#State 25
		ACTIONS => {
			"#" => 16,
			'atom' => 15,
			")" => 27,
			"-" => 13,
			"." => 12,
			"=" => 14,
			"/" => 7,
			":" => 9,
			'ringbond' => 8,
			"\$" => 10,
			"\\" => 11,
			"(" => 6
		},
		GOTOS => {
			'bond' => 5
		}
	},
	{#State 26
		DEFAULT => -7
	},
	{#State 27
		DEFAULT => -8
	}
],
                                  yyrules  =>
[
	[#Rule 0
		 '$start', 2, undef
	],
	[#Rule 1
		 'smiles', 1, undef
	],
	[#Rule 2
		 'chain', 1,
sub
#line 29 "lib/Chemistry/OpenSMILES/Parser.yp"
{
            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] };
        }
	],
	[#Rule 3
		 'chain', 2,
sub
#line 42 "lib/Chemistry/OpenSMILES/Parser.yp"
{
            $_[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];
        }
	],
	[#Rule 4
		 'chain', 3,
sub
#line 65 "lib/Chemistry/OpenSMILES/Parser.yp"
{
            $_[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];
        }
	],
	[#Rule 5
		 'chain', 3,
sub
#line 88 "lib/Chemistry/OpenSMILES/Parser.yp"
{
            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] };
        }
	],
	[#Rule 6
		 'chain', 4,
sub
#line 101 "lib/Chemistry/OpenSMILES/Parser.yp"
{
            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];
        }
	],
	[#Rule 7
		 'chain', 5,
sub
#line 124 "lib/Chemistry/OpenSMILES/Parser.yp"
{
            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];
        }
	],
	[#Rule 8
		 'chain', 5, undef
	],
	[#Rule 9
		 'chain', 2,
sub
#line 154 "lib/Chemistry/OpenSMILES/Parser.yp"
{
            $_[0]->_add_ring_bond( $_[1]->{last}, $_[2] );
            return $_[1];
        }
	],
	[#Rule 10
		 'chain', 3,
sub
#line 159 "lib/Chemistry/OpenSMILES/Parser.yp"
{
            $_[0]->_add_ring_bond( $_[1]->{last}, $_[3], $_[2] );
            return $_[1];
        }
	],
	[#Rule 11
		 'bond', 1, undef
	],
	[#Rule 12
		 'bond', 1, undef
	],
	[#Rule 13
		 'bond', 1, undef
	],
	[#Rule 14
		 'bond', 1, undef
	],
	[#Rule 15
		 'bond', 1, undef
	],
	[#Rule 16
		 'bond', 1, undef
	],
	[#Rule 17
		 'bond', 1, undef
	]
],
                                  @_);
    bless($self,$class);
}

#line 167 "lib/Chemistry/OpenSMILES/Parser.yp"


# 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 { $_ 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 );
                    $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;

1;