| Current File : //bin/gchem |
#! /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
# Copyright (C) 2006, 2009 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 as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
# `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.
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <http://www.gnu.org/licenses/>.
########################################################################
# settings
########################################################################
my $Program_Version = '0.3.1';
my $Last_Update = '03 Jan 2009';
# this setting of the groff version is only used before make is run,
# otherwise 1.22.2 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.2' 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.2';
$at_at{'BINDIR'} = '/usr/bin';
$at_at{'G'} = 'g';
$at_at{'PICDIR'} = '/usr/share/groff/1.22.2/pic';
$at_at{'TMACDIR'} = '/usr/share/groff/1.22.2/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;
my $year = $Last_Update;
$year =~ s/^.* //;
print <<EOF;
$Chem_Name $Program_Version of $Last_Update (Perl version)
is part of groff version $Groff_Version.
Copyright (C) $year Free Software Foundation, Inc.
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: