Linux ip-172-26-7-228 5.4.0-1103-aws #111~18.04.1-Ubuntu SMP Tue May 23 20:04:10 UTC 2023 x86_64
Your IP : 18.220.227.250
#! /usr/bin/env perl
# chem - a groff preprocessor for producing chemical structure diagrams
# Source file position: <groff-source>/contrib/chem/chem.pl
# Installed position: <prefix>/bin/chem
my $Copyright = 'Copyright (C) 2006-2014 Free Software Foundation, Inc.';
# Written by Bernd Warken <groff-bernd.warken-72@web.de>.
# This file is part of `chem', which is part of `groff'.
# `groff' is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License (GPL) version 2 as
# published by the Free Software Foundation.
# `groff' is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
# The GPL2 license text is available in the internet at
# <http://www.gnu.org/licenses/gpl-2.0.html>.
########################################################################
# settings
########################################################################
my $Program_Version = '1.0.5';
# this setting of the groff version is only used before make is run,
# otherwise 1.22.3 will set it.
my $Groff_Version_Preset='1.20preset';
# test on Perl version
require v5.6;
########################################################################
# begin
########################################################################
use warnings;
use strict;
use Math::Trig;
# for catfile()
use File::Spec;
# $Bin is the directory where this script is located
use FindBin;
my $Chem_Name;
my $Groff_Version;
my $File_chem_pic;
my $File_pic_tmac;
BEGIN {
{
my $before_make; # script before run of `make'
{
my $at = '@';
$before_make = 1 if '1.22.3' eq "${at}VERSION${at}";
}
my %at_at;
if ($before_make) {
my $chem_dir = $FindBin::Bin;
$at_at{'BINDIR'} = $chem_dir;
$at_at{'G'} = '';
$File_chem_pic = File::Spec->catfile($chem_dir, 'chem.pic');
$File_pic_tmac = File::Spec->catfile($chem_dir, '..', 'pic.tmac');
$Groff_Version = '';
$Chem_Name = 'chem';
} else {
$Groff_Version = '1.22.3';
$at_at{'BINDIR'} = '/usr/bin';
$at_at{'G'} = '';
$at_at{'PICDIR'} = '/usr/share/groff/1.22.3/pic';
$at_at{'TMACDIR'} = '/usr/share/groff/1.22.3/tmac';
$File_chem_pic =
File::Spec->catfile($at_at{'PICDIR'}, 'chem.pic');
$File_pic_tmac = File::Spec->catfile($at_at{'TMACDIR'}, 'pic.tmac');
$Chem_Name = $at_at{'G'} . 'chem';
}
}
}
########################################################################
# check the parameters
########################################################################
if (@ARGV) {
# process any FOO=bar switches
# eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_0-9]+=)(.*)/ && shift;
my @filespec = ();
my $dbl_minus;
my $wrong;
foreach (@ARGV) {
next unless $_;
if (/=/) {
# ignore FOO=bar switches
push @filespec, $_ if -f;
next;
}
if ($dbl_minus) {
if (-f $_) {
push @filespec, $_ if -s $_;
} else {
warn "chem: argument $_ is not an existing file.\n";
$wrong = 1;
}
next;
}
if (/^--$/) {
$dbl_minus = 1;
next;
}
if (/^-$/) {
push @filespec, $_;
next;
}
if (/^-h$/ or '--help' =~ /^$_/) {
&usage();
exit 0;
}
if (/^-v$/ or '--version' =~ /^$_/) {
&version();
exit 0;
}
if (-f $_) {
push @filespec, $_ if -s $_;
} else {
$wrong = 1;
if (/^-/) {
warn "chem: wrong option ${_}.\n";
} else {
warn "chem: argument $_ is not an existing file.\n";
}
}
}
if (@filespec) {
@ARGV = @filespec;
} else {
exit 0 if $wrong;
@ARGV = ('-');
}
} else { # @ARGV is empty
@ARGV = ('-') unless @ARGV;
}
########################################################################
# main process
########################################################################
my %Dc = ( 'up' => 0, 'right' => 90, 'down' => 180, 'left' => 270,
'ne' => 45, 'se' => 135, 'sw' => 225, 'nw' => 315,
0 => 'n', 90 => 'e', 180 => 's', 270 => 'w',
30 => 'ne', 45 => 'ne', 60 => 'ne',
120 => 'se', 135 => 'se', 150 => 'se',
210 => 'sw', 225 => 'sw', 240 => 'sw',
300 => 'nw', 315 => 'nw', 330 => 'nw',
);
my $Word_Count;
my @Words;
my $Line_No;
my $Last_Name = '';
# from init()
my $First_Time = 1;
my $Last_Type;
my $Dir; # direction
my %Types = (
'RING' => 'R',
'MOL' => 'M',
'BOND' => 'B',
'OTHER' => 'O' # manifests
);
# from setparams()
my %Params;
# from ring()
my $Nput;
my $Aromatic;
my %Put;
my %Dbl;
my %Labtype;
my %Define = ();
my $File_Name = '';
my $Line = '';
&main();
{
my $is_pic = '';
my $is_chem = '';
my $former_line = '';
##########
# main()
#
sub main {
my $count_minus = 0;
my @stdin = ();
my $stdin = 0;
# for centralizing the pic code
open TMAC, "<$File_pic_tmac" and print <TMAC>;
close TMAC;
foreach (@ARGV) {
$count_minus++ if /^-$/;
}
foreach my $arg (@ARGV) {
&setparams(1.0);
next unless $arg;
$Line_No = 0;
$is_pic = '';
$is_chem = '';
if ($arg eq '-') {
$File_Name = 'standard input';
if ($stdin) {
&main_line($_) foreach @stdin;
} else {
$stdin = 1;
if ($count_minus <= 1) {
while (<STDIN>) {
&main_line($_);
}
} else {
@stdin = ();
while (<STDIN>) {
push @stdin, $_;
&main_line($_);
}
}
}
### main()
} else { # $arg is not -
$File_Name = $arg;
open FILE, "<$arg";
&main_line($_) while <FILE>;
close FILE;
} # if $arg
if ($is_pic) {
printf ".PE\n";
}
}
} # main()
##########
# main_line()
#
sub main_line {
my $line = $_[0];
# $Last_Type = $Types{'OTHER'};
# $Last_Type = '';
my $stack;
$Line_No++;
chomp $line;
$line = $former_line . $line if $former_line;
if ($line =~ /^(.*)\\$/) {
$former_line = $1;
return 1;
} else {
$former_line = '';
}
$Line = $line;
{
@Words = ();
my $s = $line;
$s =~ s/^\s*//;
$s =~ s/\s+$//;
return 1 unless $s;
$s = " $s";
$s =~ s/\s+#.*$// if $is_pic;
return 1 unless $s;
$line = $s;
$line =~ s/^\s*|\s*$//g;
my $bool = 1;
while ($bool) {
$s =~ /^([^"]*)\s("[^"]*"?\S*)(.*)$/;
if (defined $1) {
my $s1 = $1;
my $s2 = $2;
$s = $3;
$s1 =~ s/^\s*|\s*$//g;
push @Words, split(/\s+/, $s1) if $s1;
push @Words, $s2;
}
if ($s !~ /\s"/) {
$s =~ s/^\s*|\s*$//g;
push @Words, split(/\s+/, $s) if $s;
$bool = 0;
}
}
# @Words = split(/\s+/, $s);
return 1 unless @Words;
# foreach my $i (0..$#Words) {
# if ($Words[$i] =~ /^\s*#/) {
# $#Words = $i - 1;
# last;
# }
# }
# return 1 unless @Words;
}
if ($line =~ /^([\.']\s*PS\s*)|([\.']\s*PS\s.+)$/) {
# .PS
unless ($is_pic) {
$is_pic = 'running';
print "$line\n";
}
return 1;
}
### main_line()
if ( $line =~ /^([\.']\s*PE\s*)|([\.']\s*PE\s.+)$/ ) {
# .PE
$is_chem = '';
if ($is_pic) {
$is_pic = '';
print "$line\n";
}
return 1;
}
if ($line =~ /^[\.']\s*cstart\s*$/) {
# line: `.cstart'
if ($is_chem) {
&error("additional `.cstart'; chem is already active.");
return 1;
}
unless ($is_pic) {
&print_ps();
$is_pic = 'by chem';
}
$is_chem = '.cstart';
&init();
return 1;
}
### main_line()
if ($line =~ /^\s*begin\s+chem\s*$/) {
# line: `begin chem'
if ($is_pic) {
if ($is_chem) {
&error("additional `begin chem'; chem is already active.");
return 1;
}
$is_chem = 'begin chem';
&init();
} else {
print "$line\n";
}
return 1;
}
if ($line =~ /^[\.']\s*cend\s*/) {
# line `.cend'
if ($is_chem) {
&error("you end chem with `.cend', but started it with `begin chem'.")
if $is_chem eq 'begin chem';
if ($is_pic eq 'by chem') {
&print_pe();
$is_pic = '';
}
$is_chem = '';
} else {
print "$line\n";
}
return 1;
}
if ($line =~ /^\s*end\s*$/) {
# line: `end'
if ($is_chem) {
&error("you end chem with `end', but started it with `.cstart'.")
if $is_chem eq '.cstart';
if ($is_pic eq 'by chem') {
&print_pe();
$is_pic = '';
}
$is_chem = '';
} else {
print "$line\n";
}
return 1;
}
### main_line()
if (! $is_chem) {
print "$line\n";
return 1;
}
if ($line =~ /^[.']/) {
# groff request line
print "$line\n";
return 1;
}
if ($Words[0] eq 'pic') {
# pic pass-thru
return 1 if $#Words == 0;
my $s = $line;
$s =~ /^\s*pic\s*(.*)$/;
$s = $1;
print "$s\n" if $s;
$Last_Type = $Types{'OTHER'};
$Define{ $Words[2] } = 1 if $#Words >= 2 && $Words[1] eq 'define';
return 1;
}
if ($Words[0] eq 'textht') {
if ($#Words == 0) {
&error("`textht' needs a single argument.");
return 0;
}
&error("only the last argument is taken for `textht', " .
"all others are ignored.")
unless $#Words <= 1 or ($#Words == 2 && $Words[1] =~ /^=/);
$Params{'textht'} = $Words[$#Words];
return 1;
}
### main_line()
if ($Words[0] eq 'cwid') { # character width
if ($#Words == 0) {
&error("`cwid' needs a single argument.");
return 0;
}
&error("only the last argument is taken for `cwid', " .
"all others are ignored.")
unless $#Words <= 1 or ($#Words == 2 && $Words[1] =~ /^=/);
$Params{'cwid'} = $Words[$#Words];
return 1;
}
if ($Words[0] eq 'db') { # bond length
if ($#Words == 0) {
&error("`db' needs a single argument.");
return 0;
}
&error("only the last argument is taken for `db', " .
"all others are ignored.")
unless $#Words <= 1 or ($#Words == 2 && $Words[1] =~ /^=/);
$Params{'db'} = $Words[$#Words];
return 1;
}
if ($Words[0] eq 'size') { # size for all parts of the whole diagram
my $size;
if ($#Words == 0) {
&error("`size' needs a single argument.");
return 0;
}
&error("only the last argument is taken for `size', " .
"all others are ignored.")
unless $#Words <= 1 or ($#Words == 2 && $Words[1] =~ /^=/);
if ($Words[$#Words] <= 4) {
$size = $Words[$#Words];
} else {
$size = $Words[$#Words] / 10;
}
&setparams($size);
return 1;
}
### main_line()
print "\n#", $Line, "\n"; # debugging, etc.
$Last_Name = '';
# $Last_Type = $Types{'OTHER'};
# $Last_Type = '';
if ($Words[0] =~ /^[A-Z].*:$/) {
# label; falls thru after shifting left
my $w = $Words[0];
$Last_Name = $w;
$Last_Name =~ s/:$//;
print "$w";
shift @Words;
if (@Words) {
print " ";
$line =~ s/^\s*$w\s*//;
} else {
print "\n";
return 1;
}
}
if ($Words[0] eq 'define') {
print "$line\n";
$Define{ $Words[1] } = 1 if $#Words >= 1;
$Last_Type = $Types{'OTHER'};
return 1;
}
if ($Words[0] =~ /^[\[\]{}]/) {
print "$line\n";
$Last_Type = $Types{'OTHER'};
return 1;
}
if ($Words[0] =~ /^"/) {
print 'Last: ', $line, "\n";
$Last_Type = $Types{'OTHER'};
return 1;
}
if ($Words[0] =~ /bond/) {
&bond($Words[0]);
return 1;
}
if ($#Words >= 1) {
if ($Words[0] =~ /^(double|triple|front|back)$/ &&
$Words[1] eq 'bond') {
my $w = shift @Words;
$Words[0] = $w . $Words[0];
&bond($Words[0]);
return 1;
}
if ($Words[0] eq 'aromatic') {
my $temp = $Words[0];
$Words[0] = $Words[1] ? $Words[1] : '';
$Words[1] = $temp;
}
}
if ($Words[0] =~ /ring|benz/) {
&ring($Words[0]);
return 1;
}
if ($Words[0] eq 'methyl') {
# left here as an example
$Words[0] = 'CH3';
}
### main_line()
if ($Words[0] =~ /^[A-Z]/) {
&molecule();
return 1;
}
if ($Words[0] eq 'left') {
my %left; # not used
$left{++$stack} = &fields(1, $#Words);
printf (("Last: [\n"));
return 1;
}
if ($Words[0] eq 'right') {
&bracket();
$stack--;
return 1;
}
if ($Words[0] eq 'label') { # prints the vertex numbers in a ring
if ( exists $Labtype{$Words[1]} and
$Labtype{$Words[1]} =~ /^$Types{'RING'}/ ) {
my $v = substr($Labtype{$Words[1]}, 1, 1);
$Words[1] = '' unless $Words[1];
foreach my $i ( 1..$v ) {
printf "\"\\s-3%d\\s0\" at 0.%d<%s.C,%s.V%d>\n", $i, $v + 2,
$Words[1], $Words[1], $i;
}
} else {
&error("$Words[1] is not a ring.");
}
return 1;
}
if ( exists $Define{ $Words[0] } ) {
print $line, "\n";
$Last_Type = $Types{'OTHER'};
return 1;
}
return 1 unless $line;
# print STDERR "# $Line\n";
# &error('This is not a chem command. To include a command for pic, ' .
# "add `pic' as the first word to the command.");
print $line, "\n";
$Last_Type = $Types{'OTHER'};
1;
} # main_line()
}
########################################################################
# functions
########################################################################
##########
# atom(<string>)
#
sub atom {
# convert CH3 to atom(...)
my ($s) = @_;
my ($i, $n, $nsub, $cloc, $nsubc, @s);
if ($s eq "\"\"") {
return $s;
}
$n = length($s);
$nsub = $nsubc = 0;
$cloc = index($s, 'C');
if (! defined($cloc) || $cloc < 0) {
$cloc = 0;
}
@s = split('', $s);
$i = 0;
foreach (@s) {
unless (/[A-Z]/) {
$nsub++;
$nsubc++ if $i < $cloc;
$i++;
}
}
$s =~ s/([0-9]+\.[0-9]+)|([0-9]+)/\\s-3\\d$&\\u\\s+3/g;
if ($s =~ /([^0-9]\.)|(\.[^0-9])/) { # centered dot
$s =~ s/\./\\v#-.3m#.\\v#.3m#/g;
}
sprintf( "atom(\"%s\", %g, %g, %g, %g, %g, %g)",
$s, ($n - $nsub / 2) * $Params{'cwid'}, $Params{'textht'},
($cloc - $nsubc / 2 + 0.5) * $Params{'cwid'}, $Params{'crh'},
$Params{'crw'}, $Params{'dav'}
);
} # atom()
##########
# bond(<type>)
#
sub bond {
my ($type) = @_;
my ($i, $moiety, $from, $leng);
$moiety = '';
for ($i = 1; $i <= $#Words; $i++) {
if ($Words[$i] eq ';') {
&error("a colon `;' must be followed by a space and a single word.")
if $i != $#Words - 1;
$moiety = $Words[$i + 1] if $#Words > $i;
$#Words = $i - 1;
last;
}
}
$leng = $Params{'db'}; # bond length
$from = '';
for ($Word_Count = 1; $Word_Count <= $#Words; ) {
if ($Words[$Word_Count] =~
/(\+|-)?\d+|up|down|right|left|ne|se|nw|sw/) {
$Dir = &cvtdir($Dir);
} elsif ($Words[$Word_Count] =~ /^leng/) {
$leng = $Words[$Word_Count + 1] if $#Words > $Word_Count;
$Word_Count += 2;
} elsif ($Words[$Word_Count] eq 'to') {
$leng = 0;
$from = &fields($Word_Count, $#Words);
last;
} elsif ($Words[$Word_Count] eq 'from') {
$from = &dofrom();
last;
} elsif ($Words[$Word_Count] =~ /^#/) {
$Word_Count = $#Words + 1;
last;
} else {
$from = &fields($Word_Count, $#Words);
last;
}
}
### bond()
if ($from =~ /( to )|^to/) { # said "from ... to ...", so zap length
$leng = 0;
} elsif (! $from) { # no from given at all
$from = 'from Last.' . &leave($Last_Type, $Dir) . ' ' .
&fields($Word_Count, $#Words);
}
printf "Last: %s(%g, %g, %s)\n", $type, $leng, $Dir, $from;
$Last_Type = $Types{'BOND'};
$Labtype{$Last_Name} = $Last_Type if $Last_Name;
if ($moiety) {
@Words = ($moiety);
&molecule();
}
} # bond()
##########
# bracket()
#
sub bracket {
my $t;
printf (("]\n"));
if ($Words[1] && $Words[1] eq ')') {
$t = 'spline';
} else {
$t = 'line';
}
printf "%s from last [].sw+(%g,0) to last [].sw to last [].nw to last " .
"[].nw+(%g,0)\n", $t, $Params{'dbrack'}, $Params{'dbrack'};
printf "%s from last [].se-(%g,0) to last [].se to last [].ne to last " .
"[].ne-(%g,0)\n", $t, $Params{'dbrack'}, $Params{'dbrack'};
if ($Words[2] && $Words[2] eq 'sub') {
printf "\" %s\" ljust at last [].se\n", &fields(3, $#Words);
}
} # bracket()
##########
# corner(<dir>)
#
# Return the corner name next to the given angle.
#
sub corner {
my ($d) = @_;
$Dc{ (45 * int(($d + 22.5) / 45)) % 360 };
} # corner()
##########
# cvtdir(<dir>)
#
# Maps "[pointing] somewhere" to degrees.
#
sub cvtdir {
my ($d) = @_;
if ($Words[$Word_Count] eq 'pointing') {
$Word_Count++;
}
if ($Words[$Word_Count] =~ /^[+\\-]?\d+/) {
return ( $Words[$Word_Count++] % 360 );
} elsif ($Words[$Word_Count] =~ /left|right|up|down|ne|nw|se|sw/) {
return ( $Dc{$Words[$Word_Count++]} % 360 );
} else {
$Word_Count++;
return $d;
}
} # cvtdir()
##########
# dblring(<v>)
#
sub dblring {
my ($v) = @_;
my ($d, $v1, $v2);
# should canonicalize to i,i+1 mod v
$d = $Words[$Word_Count];
for ($Word_Count++; $Word_Count <= $#Words &&
$Words[$Word_Count] =~ /^[1-9]/; $Word_Count++) {
$v1 = substr($Words[$Word_Count], 0, 1);
$v2 = substr($Words[$Word_Count], 2, 1);
if ($v2 == $v1 + 1 || $v1 == $v && $v2 == 1) { # e.g., 2,3 or 5,1
$Dbl{$v1} = $d;
} elsif ($v1 == $v2 + 1 || $v2 == $v && $v1 == 1) { # e.g., 3,2 or 1,5
$Dbl{$v2} = $d;
} else {
&error(sprintf("weird %s bond in\n\t%s", $d, $_));
}
}
} # dblring()
##########
# dofrom()
#
sub dofrom {
my $n;
$Word_Count++; # skip "from"
$n = $Words[$Word_Count];
if (defined $Labtype{$n}) { # "from Thing" => "from Thing.V.s"
return 'from ' . $n . '.' . &leave($Labtype{$n}, $Dir);
}
if ($n =~ /^\.[A-Z]/) { # "from .V" => "from Last.V.s"
return 'from Last' . $n . '.' . &corner($Dir);
}
if ($n =~ /^[A-Z][^.]*\.[A-Z][^.]*$/) { # "from X.V" => "from X.V.s"
return 'from ' . $n . '.' . &corner($Dir);
}
&fields($Word_Count - 1, $#Words);
} # dofrom()
##########
# error(<string>)
#
sub error {
my ($s) = @_;
printf STDERR "chem: error in %s on line %d: %s\n",
$File_Name, $Line_No, $s;
} # error()
##########
# fields(<n1>, <n2>)
#
sub fields {
my ($n1, $n2) = @_;
if ($n1 > $n2) {
return '';
}
my $s = '';
foreach my $i ($n1..$n2) {
if ($Words[$i] =~ /^#/) {
last;
}
$s = $s . $Words[$i] . ' ';
}
$s;
} # fields()
##########
# init()
#
sub init {
if ($First_Time) {
printf "copy \"%s\"\n", $File_chem_pic;
printf "\ttextht = %g; textwid = .1; cwid = %g\n",
$Params{'textht'}, $Params{'cwid'};
printf "\tlineht = %g; linewid = %g\n",
$Params{'lineht'}, $Params{'linewid'};
$First_Time = 0;
}
printf "Last: 0,0\n";
$Last_Type = $Types{'OTHER'};
$Dir = 90;
} # init()
##########
# leave(<last>, <d>)
#
sub leave {
my ($last, $d) = @_;
my ($c, $c1);
# return vertex of $last in direction $d
if ( $last eq $Types{'BOND'} ) {
return 'end';
}
$d %= 360;
if ( $last =~ /^$Types{'RING'}/ ) {
return &ringleave($last, $d);
}
if ( $last eq $Types{'MOL'} ) {
if ($d == 0 || $d == 180) {
$c = 'C';
} elsif ($d > 0 && $d < 180) {
$c = 'R';
} else {
$c = 'L';
}
if (defined $Dc{$d}) {
$c1 = $Dc{$d};
} else {
$c1 = &corner($d);
}
return sprintf('%s.%s', $c, $c1);
}
if ( $last eq $Types{'OTHER'} ) {
return &corner($d);
}
'c';
} # leave()
##########
# makering(<type>, <pt>, <v>)
#
sub makering {
my ($type, $pt, $v) = @_;
my ($i, $j, $a, $r, $rat, $fix, $c1, $c2);
if ($type =~ /flat/) {
$v = 6;
# vertices
;
}
$r = $Params{'ringside'} / (2 * sin(pi / $v));
printf "\tC: 0,0\n";
for ($i = 0; $i <= $v + 1; $i++) {
$a = (($i - 1) / $v * 360 + $pt) / 57.29578; # 57. is $deg
printf "\tV%d: (%g,%g)\n", $i, $r * sin($a), $r * cos($a);
}
if ($type =~ /flat/) {
printf "\tV4: V5; V5: V6\n";
$v = 5;
}
# sides
if ($Nput > 0) {
# hetero ...
for ($i = 1; $i <= $v; $i++) {
$c1 = $c2 = 0;
if ($Put{$i} ne '') {
printf "\tV%d: ellipse invis ht %g wid %g at V%d\n",
$i, $Params{'crh'}, $Params{'crw'}, $i;
printf "\t%s at V%d\n", $Put{$i}, $i;
$c1 = $Params{'cr'};
}
$j = $i + 1;
if ($j > $v) {
$j = 1;
}
### makering()
if ($Put{$j} ne '') {
$c2 = $Params{'cr'};
}
printf "\tline from V%d to V%d chop %g chop %g\n", $i, $j, $c1, $c2;
if ($Dbl{$i} ne '') {
# should check i<j
if ($type =~ /flat/ && $i == 3) {
$rat = 0.75;
$fix = 5;
} else {
$rat = 0.85;
$fix = 1.5;
}
if ($Put{$i} eq '') {
$c1 = 0;
} else {
$c1 = $Params{'cr'} / $fix;
}
if ($Put{$j} eq '') {
$c2 = 0;
} else {
$c2 = $Params{'cr'} / $fix;
}
printf "\tline from %g<C,V%d> to %g<C,V%d> chop %g chop %g\n",
$rat, $i, $rat, $j, $c1, $c2;
if ($Dbl{$i} eq 'triple') {
printf "\tline from %g<C,V%d> to %g<C,V%d> chop %g chop %g\n",
2 - $rat, $i, 2 - $rat, $j, $c1, $c2;
}
}
}
### makering()
} else {
# regular
for ($i = 1; $i <= $v; $i++) {
$j = $i + 1;
if ($j > $v) {
$j = 1;
}
printf "\tline from V%d to V%d\n", $i, $j;
if ($Dbl{$i} ne '') {
# should check i<j
if ($type =~ /flat/ && $i == 3) {
$rat = 0.75;
} else {
$rat = 0.85;
}
printf "\tline from %g<C,V%d> to %g<C,V%d>\n",
$rat, $i, $rat, $j;
if ($Dbl{$i} eq 'triple') {
printf "\tline from %g<C,V%d> to %g<C,V%d>\n",
2 - $rat, $i, 2 - $rat, $j;
}
}
}
}
### makering()
# punt on triple temporarily
# circle
if ($type =~ /benz/ || $Aromatic > 0) {
if ($type =~ /flat/) {
$r *= .4;
} else {
$r *= .5;
}
printf "\tcircle rad %g at 0,0\n", $r;
}
} # makering()
##########
# molecule()
#
sub molecule {
my ($n, $type);
if ($#Words >= 0) {
$n = $Words[0];
if ($n eq 'BP') {
$Words[0] = "\"\" ht 0 wid 0";
$type = $Types{'OTHER'};
} else {
$Words[0] = &atom($n);
$type = $Types{'MOL'};
}
}
$n =~ s/[^A-Za-z0-9]//g; # for stuff like C(OH3): zap non-alnum
if ($#Words < 1) {
printf "Last: %s: %s with .%s at Last.%s\n",
$n, join(' ', @Words), &leave($type, $Dir + 180),
&leave($Last_Type, $Dir);
### molecule()
} else {
if (! $Words[1]) {
printf "Last: %s: %s with .%s at Last.%s\n",
$n, join(' ', @Words), &leave($type, $Dir + 180),
&leave($Last_Type, $Dir);
} elsif ($#Words >= 1 and $Words[1] eq 'below') {
$Words[2] = '' if ! $Words[2];
printf "Last: %s: %s with .n at %s.s\n", $n, $Words[0], $Words[2];
} elsif ($#Words >= 1 and $Words[1] eq 'above') {
$Words[2] = '' if ! $Words[2];
printf "Last: %s: %s with .s at %s.n\n", $n, $Words[0], $Words[2];
} elsif ($#Words >= 2 and $Words[1] eq 'left' && $Words[2] eq 'of') {
$Words[3] = '' if ! $Words[3];
printf "Last: %s: %s with .e at %s.w+(%g,0)\n",
$n, $Words[0], $Words[3], $Params{'dew'};
} elsif ($#Words >= 2 and $Words[1] eq 'right' && $Words[2] eq 'of') {
$Words[3] = '' if ! $Words[3];
printf "Last: %s: %s with .w at %s.e-(%g,0)\n",
$n, $Words[0], $Words[3], $Params{'dew'};
} else {
printf "Last: %s: %s\n", $n, join(' ', @Words);
}
}
$Last_Type = $type;
if ($Last_Name) {
# $Last_Type = '';
$Labtype{$Last_Name} = $Last_Type;
}
$Labtype{$n} = $Last_Type;
} # molecule()
##########
# print_hash(<hash_or_ref>)
#
# print the elements of a hash or hash reference
#
sub print_hash {
my $hr;
my $n = scalar @_;
if ($n == 0) {
print STDERR "empty hash\n;";
return 1;
} elsif ($n == 1) {
if (ref($_[0]) eq 'HASH') {
$hr = $_[0];
} else {
warn 'print_hash(): the argument is not a hash or hash reference;';
return 0;
}
} else {
if ($n % 2) {
warn 'print_hash(): the arguments are not a hash;';
return 0;
} else {
my %h = @_;
$hr = \%h;
}
}
### print_hash()
unless (%$hr) {
print STDERR "empty hash\n";
return 1;
}
print STDERR "hash (ignore the ^ characters):\n";
for my $k (sort keys %$hr) {
my $hk = $hr->{$k};
print STDERR " $k => ";
if (defined $hk) {
print STDERR "^$hk^";
} else {
print STDERR "undef";
}
print STDERR "\n";
}
1;
} # print_hash()
##########
# print_pe()
#
sub print_pe {
print ".PE\n";
} # print_pe()
##########
# print_ps()
#
sub print_ps {
print ".PS\n";
} # print_ps()
##########
# putring(<v>)
#
sub putring {
# collect "put Mol at n"
my ($v) = @_;
my ($m, $mol, $n);
$Word_Count++;
$mol = $Words[$Word_Count++];
if ($Words[$Word_Count] eq 'at') {
$Word_Count++;
}
$n = $Words[$Word_Count];
if ($n !~ /^\d+$/) {
$n =~ s/(\d)+$/$1/;
$n = 0 if $n !~ /^\d+$/;
error('use single digit as argument for "put at"');
}
if ($n >= 1 && $n <= $v) {
$m = $mol;
$m =~ s/[^A-Za-z0-9]//g;
$Put{$n} = $m . ':' . &atom($mol);
} elsif ($n == 0) {
error('argument of "put at" must be a single digit');
} else {
error('argument of "put at" is too large');
}
$Word_Count++;
} # putring()
##########
# ring(<type>)
#
sub ring {
my ($type) = @_;
my ($typeint, $pt, $verts, $i, $other, $fused, $withat);
$pt = 0; # points up by default
if ($type =~ /([1-8])$/) {
$verts = $1;
} elsif ($type =~ /flat/) {
$verts = 5;
} else {
$verts = 6;
}
$fused = $other = '';
for ($i = 1; $i <= $verts; $i++) {
$Put{$i} = $Dbl{$i} = '';
}
$Nput = $Aromatic = $withat = 0;
for ($Word_Count = 1; $Word_Count <= $#Words; ) {
if ($Words[$Word_Count] eq 'pointing') {
$pt = &cvtdir(0);
} elsif ($Words[$Word_Count] eq 'double' ||
$Words[$Word_Count] eq 'triple') {
&dblring($verts);
} elsif ($Words[$Word_Count] =~ /arom/) {
$Aromatic++;
$Word_Count++; # handled later
### ring()
} elsif ($Words[$Word_Count] eq 'put') {
&putring($verts);
$Nput++;
} elsif ($Words[$Word_Count] =~ /^#/) {
$Word_Count = $#Words + 1;
last;
} else {
if ($Words[$Word_Count] eq 'with' || $Words[$Word_Count] eq 'at') {
$withat = 1;
}
$other = $other . ' ' . $Words[$Word_Count];
$Word_Count++;
}
}
$typeint = $Types{'RING'} . $verts . $pt; # RING | verts | dir
if ($withat == 0) {
# join a ring to something
if ( $Last_Type =~ /^$Types{'RING'}/ ) {
# ring to ring
if (substr($typeint, 2) eq substr($Last_Type, 2)) {
# fails if not 6-sided
$fused = 'with .V6 at Last.V2';
}
}
# if all else fails
$fused = sprintf('with .%s at Last.%s',
&leave($typeint, $Dir + 180), &leave($Last_Type, $Dir));
}
printf "Last: [\n";
&makering($type, $pt, $verts);
printf "] %s %s\n", $fused, $other;
$Last_Type = $typeint;
$Labtype{$Last_Name} = $Last_Type if $Last_Name;
} # ring()
##########
# ringleave(<last>, <d>)
#
sub ringleave {
my ($last, $d) = @_;
my ($rd, $verts);
# return vertex of ring in direction d
$verts = substr($last, 1, 1);
$rd = substr($last, 2);
sprintf('V%d.%s', int( (($d - $rd) % 360) / (360 / $verts)) + 1,
&corner($d));
} # ringleave()
##########
# setparams(<scale>)
#
sub setparams {
my ($scale) = @_;
$Params{'lineht'} = $scale * 0.2;
$Params{'linewid'} = $scale * 0.2;
$Params{'textht'} = $scale * 0.16;
$Params{'db'} = $scale * 0.2; # bond length
$Params{'cwid'} = $scale * 0.12; # character width
$Params{'cr'} = $scale * 0.08; # rad of invis circles at ring vertices
$Params{'crh'} = $scale * 0.16; # ht of invis ellipse at ring vertices
$Params{'crw'} = $scale * 0.12; # wid
$Params{'dav'} = $scale * 0.015; # vertical shift up for atoms in atom macro
$Params{'dew'} = $scale * 0.02; # east-west shift for left of/right of
$Params{'ringside'} = $scale * 0.3; # side of all rings
$Params{'dbrack'} = $scale * 0.1; # length of bottom of bracket
} # setparams()
##########
# usage()
#
# Print usage information for --help.
#
sub usage {
print "\n";
&version();
print <<EOF;
Usage: $Chem_Name [option]... [filespec]...
$Chem_Name is a groff preprocessor for producing chemical structure
diagrams. The output suits to the pic preprocessor.
"filespec" is one of
"filename" name of a readable file
"-" for standard input
All available options are
-h --help print this usage message.
-v --version print version information.
EOF
} # usage()
##########
# version()
#
# Get version information from version.sh and print a text with this.
#
sub version {
$Groff_Version = $Groff_Version_Preset unless $Groff_Version;
print <<EOF;
$Chem_Name $Program_Version (Perl version)
is part of groff version $Groff_Version.
$Copyright
GNU groff and chem come with ABSOLUTELY NO WARRANTY.
You may redistribute copies of groff and its subprograms
under the terms of the GNU General Public License.
EOF
} # version()
1;
### Emacs settings
# Local Variables:
# mode: CPerl
# End:
|