view release on metacpan or  search on metacpan

lib/Chemistry/Harmonia.pm  view on Meta::CPAN

	    if( $l > 1 ){
		$k{ $_ } *= $l for keys %k;
	    }
	    # by GCD reduce order of coefficients
	    my $gcd = bgcd(values %k);

	    if( $gcd > 1 ){
		$k{ $_ } /= $gcd for keys %k;
	    }

	    my $f;
	    for my $i (split /\*/){
		$i =~ s/^(\d*\.?\d*)([\w\(\)\[\]\{\}]+)$/$k{$1}>1?"{$2}".$k{$1}:"{$2}"/e;
		$f .= $i;
	    }
	    $_ = $f;
	}

	1 while s/[\(\{\[][\)\}\]]//g;	# clean empty brackets
    }

    my $cf = [''];
    for my $s (split /((?:\$|\d|\(|\)|\[|\]|\{|\})+)/,$substance){

	if( $s =~ /[$sas]/i ){ # Atom symbols
	    &_in_gf($s, \@maU, \@maUl, $cf);

	}elsif( $s =~ /\$/ ){ # Zero symbols: 'o' && 'O'
	    $s =~ s/^\$//;
	    &_add_zero( $cf, "O$s", "o$s" ); # add oxigen to { C H N P } -> { CO HO NO PO }
					 # add 'o' to { C H N P } -> { Co Ho No Po }

	}elsif($s =~ /$mz/ && exists( $opts->{'zero2oxi'} ) ){ # Zero symbols
	    my $z = $s;		# zero
	    $s =~ s/$mz/O/g;	# oxigen

	    &_add_zero( $cf, $s, $z );

	}else{ # Others
	    $_ .= $s for @$cf;
	}
    }

    $cf->[0] =~ /\w/ ? return $cf : return;
}

sub _add_zero{
    my( $cf, $oxi, $z ) = @_;
    my $n = $#{$cf};

    for( my $i = 0; $i <= $n; $i++ ){
	$cf->[$i + $n + 1] = $cf->[$i].$oxi;	# add oxigen to { C H N P } -> { CO HO NO PO }
	$cf->[$i] .= $z;	# add 'o' to { C H N P } -> { Co Ho No Po }
    }
}

sub _in_gf{
    my($s, $maU, $maUl, $cf) = @_;

    # Unary symbols of fragment
    my @i_maU = grep $s =~ /$_/i, @$maU;

    if( length($s) == 1 ){	# Unary atom symbol
	@i_maU || return;

	$_ .= $i_maU[0] for @$cf;
	return 1;
    }

    # Double symbols of fragment
    ( my @i_maUl = grep $s =~ /$_/i, @$maUl ) || @i_maU || return; # not present

    # Strings of unary and double atom letters
    my $saU = join '', @i_maU;	# String of unary atom letters
    my $saUl = join '|', @i_maUl; # 1th - CAPITAL, 2th - small

    my @w;	# Anchor symbols

    # Unique unary symbols (is not present in double)
    for( @i_maU ){
	next if $saUl =~ /$_/i;
	$s =~ s/\L$_/$_/g;	# to CAPITAL
	push @w, $_;
    }

    # Unique double (is not present in others)
    for my $ul (@i_maUl){
	(my $m = $saUl) =~ s/$ul//; # To copy and clean the tested

	for(split //,$ul){
	    next if $m =~ /$_/i || $saU =~ /$_/i;

	    $s =~ s/$ul/$ul/ig;
	    push @w, $ul;
	    last;
	}
    }

    $_ = $s;

    if( length == 2){ # Two symbols

	(my $salU = $saUl) =~ s/(\w+)/\l\U$1/g;	# 1th - small, 2th - CAPITAL

	# The order is important!!!
	my @in_cf;
	if( /$saUl/ || /[$saU]{2}/ ){	# Usual writing of atom: 1th - CAPITAL, 2th - small
				# or both - CAPITAL unary letters
	    push @in_cf, $_;

	}elsif( /\U$saUl/ ){ # 1th and 2th - CAPITAL letters of double symbol
	    push @in_cf, ucfirst lc;

	}elsif( @i_maU && ( /[$saU][\L$saU\E]/ || /[\L$saU\E][$saU]/ ) ){ # For unary symbols:
		    # 1th - CAPITAL, 2th - small or 1th - small, 2th - CAPITAL letter
	    push @in_cf, uc;

	}elsif( /$salU/ ){ # 1th - small, 2th - CAPITAL letter of double symbol
	    push @in_cf, ucfirst lc;

	}elsif( length($saUl) == 0 ){ # Without double symbol
	    s/.?([$saU]+).?/$1/i; # unary symbol(s)
	    push @in_cf, uc;

	}else{	# 1th and 2th small letters - two alternative variants
	    if( /[\L$saU]{2}/ ){ # unary symbols
		push @in_cf, uc;
	    }
	    if( /\L$saUl/ ){ # double symbol
		push @in_cf, ucfirst;
	    }

	    @in_cf || return;

	    if( @in_cf == 2 ){

		my $n = $#{$cf};
		for( my $i = 0; $i <= $n; $i++ ){
		    $cf->[$i + $n + 1] = $cf->[$i].$in_cf[1];
		    $cf->[$i] .= $in_cf[0];
		}
		return 1;
	    }
	}

	$_ .= $in_cf[0] for @$cf;
	return 1;
    }

    # More 2 symbols

    for( $s ){
	my $m = join '|', $saUl, @i_maU;

	while( ! /^(?:$m)/i ){ s/^.// } # Clear head
	while( ! /(?:$m)$/i ){ s/.$// } # Clear tail

	# Search double and unary symbols
	my $z = '';
	while( /^((?:$m)+)/g ){ $z .= $1 } 

	if( length $z ){

	    $_ .= $z for @$cf;
	    return 1 if length($z) == length;	# The end

	    s/^$z//;
	    return &_in_gf($_, \@i_maU, \@i_maUl, $cf) if 3 > length;
	}
    }

    if( @w ){	# Search by fragments of anchor symbols 
	my $m = join '|', @w;

	for my $f (split /($m)/, $s){

	    &_in_gf($f, \@i_maU, \@i_maUl, $cf);

	    if( $#{$cf} ){ # For >1 formula
		# To leave the longest fragments
		for( my $i = $#$cf; $i > 0; $i-- ){
		    splice @$cf, $i, 1 if length( $cf->[$i] ) < length( $cf->[0] );
		}
	    }
	}
	return 1;
    }

    # Difficult fragment
    my $cf_copy = [ @$cf ];
    $#{$cf} = -1;	# Reset

_M_gf_1: # Letter by letter search
    for( my $i = 1; $i < length($s); $i++ ){

        my $cf_new = [ @$cf_copy ];

	for( $s =~ /^(\w{$i})(\w+)/ ){
	    &_in_gf($_, \@i_maU, \@i_maUl, $cf_new) || next _M_gf_1;
	}
	# To accumulate only unique, big fragments
	for my $k ( @$cf_new ){
	    scalar( grep length($_) > length($k) || $_ eq $k, @$cf ) || push @$cf, $k;
	}
    }
    return 1;
}


# Tactico-technical characteristics of chemical reaction.
# Return quantity hash (SAR):
#	's'ubstance
#	'a'toms
#	'r'ank
sub ttc_reaction{
    my $ce = shift || return;
    
    # Hash atom matrix and quantity of atoms
    my( $atoms_substance, $atoms ) = &_search_atoms_subs( $ce );

    my $rank = Rank( [ values %$atoms_substance ] ) || return;

    return { 's' => scalar( keys %$atoms_substance ),
	    'a' => $atoms,
	    'r' => $rank,
	    };
}

# Calculation common identifier for reaction:
#	Alphabetic CLASS
# and
#	Chemical Interger Reaction (CIR) identifier
# also
#	brutto (gross) formulas of substances
sub class_cir_brutto{
    my( $ce, $coef ) = @_;
    $ce || return;

    my( %elm, %bf, @cir );

    for my $c ( @$ce ){
	for my $s ( @$c ){

	    # stoichiometry coefficient
	    my $k = exists $coef->{$s} ? $coef->{$s} : 1; 

	    my %e = Chemistry::File::Formula->parse_formula( $s );

	    # for brutto
	    $bf{ $s } = join '', map( "$_$e{$_}", sort{ $a cmp $b } keys %e );

	    # for cir
	    push @cir, $k.$bf{ $s };

	    # For class
	    @elm{ keys %e } = ''; # reaction atoms
	}
    }

    # CLASS, CIR of reaction and hash: formula => brutto of substances
    return [ join( '', sort { $a cmp $b } keys %elm ),