contrib/groff/contrib/chem/chem.pl

   1 #! /usr/bin/env perl
   2
   3 # chem - a groff preprocessor for producing chemical structure diagrams
   4
   5 # Source file position: <groff-source>/contrib/chem/chem.pl
   6 # Installed position: <prefix>/bin/chem
   7
   8 # Copyright (C) 2006, 2009 Free Software Foundation, Inc.
   9 # Written by Bernd Warken.
  10
  11 # This file is part of `chem', which is part of `groff'.
  12
  13 # `groff' is free software; you can redistribute it and/or modify it
  14 # under the terms of the GNU General Public License as published by
  15 # the Free Software Foundation, either version 3 of the License, or
  16 # (at your option) any later version.
  17
  18 # `groff' is distributed in the hope that it will be useful, but
  19 # WITHOUT ANY WARRANTY; without even the implied warranty of
  20 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21 # General Public License for more details.
  22
  23 # You should have received a copy of the GNU General Public License
  24 # along with this program. If not, see <http://www.gnu.org/licenses/>.
  25
  26 ########################################################################
  27 # settings
  28 ########################################################################
  29
  30 my $Program_Version = '0.3.1';
  31 my $Last_Update = '03 Jan 2009';
  32
  33 # this setting of the groff version is only used before make is run,
  34 # otherwise @VERSION@ will set it.
  35 my $Groff_Version_Preset='1.20preset';
  36
  37 # test on Perl version
  38 require v5.6;
  39
  40
  41 ########################################################################
  42 # begin
  43 ########################################################################
  44
  45 use warnings;
  46 use strict;
  47 use Math::Trig;
  48
  49 # for catfile()
  50 use File::Spec;
  51
  52 # $Bin is the directory where this script is located
  53 use FindBin;
  54
  55 my $Chem_Name;
  56 my $Groff_Version;
  57 my $File_chem_pic;
  58 my $File_pic_tmac;
  59
  60 BEGIN {
  61   {
  62     my $before_make;            # script before run of `make'
  63     {
  64       my $at = '@';
  65       $before_make = 1 if '@VERSION@' eq "${at}VERSION${at}";
  66     }
  67
  68     my %at_at;
  69
  70     if ($before_make) {
  71       my $chem_dir = $FindBin::Bin;
  72       $at_at{'BINDIR'} = $chem_dir;
  73       $at_at{'G'} = '';
  74       $File_chem_pic = File::Spec->catfile($chem_dir, 'chem.pic');
  75       $File_pic_tmac = File::Spec->catfile($chem_dir, '..', 'pic.tmac');
  76       $Groff_Version = '';
  77       $Chem_Name = 'chem';
  78     } else {
  79       $Groff_Version = '@VERSION@';
  80       $at_at{'BINDIR'} = '@BINDIR@';
  81       $at_at{'G'} = '@g@';
  82       $at_at{'PICDIR'} = '@PICDIR@';
  83       $at_at{'TMACDIR'} = '@MACRODIR@';
  84       $File_chem_pic =
  85         File::Spec->catfile($at_at{'PICDIR'}, 'chem.pic');
  86       $File_pic_tmac = File::Spec->catfile($at_at{'TMACDIR'}, 'pic.tmac');
  87       $Chem_Name = $at_at{'G'} . 'chem';
  88     }
  89   }
  90 }
  91
  92
  93 ########################################################################
  94 # check the parameters
  95 ########################################################################
  96
  97 if (@ARGV) {
  98   # process any FOO=bar switches
  99   # eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_0-9]+=)(.*)/ && shift;
 100   my @filespec = ();
 101   my $dbl_minus;
 102   my $wrong;
 103   foreach (@ARGV) {
 104     next unless $_;
 105     if (/=/) {
 106       # ignore FOO=bar switches
 107       push @filespec, $_ if -f;
 108       next;
 109     }
 110     if ($dbl_minus) {
 111       if (-f $_) {
 112         push @filespec, $_ if -s $_;
 113       } else {
 114         warn "chem: argument $_ is not an existing file.\n";
 115         $wrong = 1;
 116       }
 117       next;
 118     }
 119     if (/^--$/) {
 120       $dbl_minus = 1;
 121       next;
 122     }
 123     if (/^-$/) {
 124       push @filespec, $_;
 125       next;
 126     }
 127     if (/^-h$/ or '--help' =~ /^$_/) {
 128       &usage();
 129       exit 0;
 130     }
 131     if (/^-v$/ or '--version' =~ /^$_/) {
 132       &version();
 133       exit 0;
 134     }
 135     if (-f $_) {
 136       push @filespec, $_ if -s $_;
 137     } else {
 138       $wrong = 1;
 139       if (/^-/) {
 140         warn "chem: wrong option ${_}.\n";
 141       } else {
 142         warn "chem: argument $_ is not an existing file.\n";
 143       }
 144     }
 145   }
 146   if (@filespec) {
 147     @ARGV = @filespec;
 148   } else {
 149     exit 0 if $wrong;
 150     @ARGV = ('-');
 151   }
 152 } else {                        # @ARGV is empty
 153   @ARGV = ('-') unless @ARGV;
 154 }
 155
 156
 157 ########################################################################
 158 # main process
 159 ########################################################################
 160
 161 my %Dc = ( 'up' => 0, 'right' => 90, 'down' => 180, 'left' => 270,
 162            'ne' => 45, 'se' => 135, 'sw' => 225, 'nw' => 315,
 163            0 => 'n', 90 => 'e', 180 => 's', 270 => 'w',
 164            30 => 'ne', 45 => 'ne', 60 => 'ne',
 165            120 => 'se', 135 => 'se', 150 => 'se',
 166            210 => 'sw', 225 => 'sw', 240 => 'sw',
 167            300 => 'nw', 315 => 'nw', 330 => 'nw',
 168          );
 169
 170 my $Word_Count;
 171 my @Words;
 172
 173 my $Line_No;
 174 my $Last_Name = '';
 175
 176 # from init()
 177 my $First_Time = 1;
 178 my $Last_Type;
 179 my $Dir;                        # direction
 180 my %Types = (
 181              'RING' => 'R',
 182              'MOL' => 'M',
 183              'BOND' => 'B',
 184              'OTHER' => 'O'     # manifests
 185             );
 186
 187 # from setparams()
 188 my %Params;
 189
 190 # from ring()
 191 my $Nput;
 192 my $Aromatic;
 193 my %Put;
 194 my %Dbl;
 195
 196 my %Labtype;
 197 my %Define = ();
 198
 199 my $File_Name = '';
 200 my $Line = '';
 201
 202 &main();
 203
 204 {
 205   my $is_pic = '';
 206   my $is_chem = '';
 207   my $former_line = '';
 208
 209   ##########
 210   # main()
 211   #
 212   sub main {
 213     my $count_minus = 0;
 214     my @stdin = ();
 215     my $stdin = 0;
 216
 217     # for centralizing the pic code
 218     open TMAC, "<$File_pic_tmac" and print <TMAC>;
 219     close TMAC;
 220
 221     foreach (@ARGV) {
 222       $count_minus++ if /^-$/;
 223     }
 224
 225     foreach my $arg (@ARGV) {
 226       &setparams(1.0);
 227       next unless $arg;
 228       $Line_No = 0;
 229       $is_pic = '';
 230       $is_chem = '';
 231       if ($arg eq '-') {
 232         $File_Name = 'standard input';
 233         if ($stdin) {
 234           &main_line($_) foreach @stdin;
 235         } else {
 236           $stdin = 1;
 237           if ($count_minus <= 1) {
 238             while (<STDIN>) {
 239               &main_line($_);
 240             }
 241           } else {
 242             @stdin = ();
 243             while (<STDIN>) {
 244               push @stdin, $_;
 245               &main_line($_);
 246             }
 247           }
 248         }
 249 ### main()
 250       } else {                  # $arg is not -
 251         $File_Name = $arg;
 252         open FILE, "<$arg";
 253         &main_line($_) while <FILE>;
 254         close FILE;
 255       }                         # if $arg
 256       if ($is_pic) {
 257         printf ".PE\n";
 258       }
 259     }
 260   } # main()
 261
 262
 263   ##########
 264   # main_line()
 265   #
 266   sub main_line {
 267     my $line = $_[0];
 268 #    $Last_Type = $Types{'OTHER'};
 269 #    $Last_Type = '';
 270     my $stack;
 271     $Line_No++;
 272     chomp $line;
 273
 274     $line = $former_line . $line if $former_line;
 275     if ($line =~ /^(.*)\\$/) {
 276       $former_line = $1;
 277       return 1;
 278     } else {
 279       $former_line = '';
 280     }
 281     $Line = $line;
 282
 283     {
 284       @Words = ();
 285       my $s = $line;
 286       $s =~ s/^\s*//;
 287       $s =~ s/\s+$//;
 288       return 1 unless $s;
 289       $s = " $s";
 290       $s =~ s/\s+#.*$// if $is_pic;
 291       return 1 unless $s;
 292       $line = $s;
 293       $line =~ s/^\s*|\s*$//g;
 294       my $bool = 1;
 295       while ($bool) {
 296         $s =~ /^([^"]*)\s("[^"]*"?\S*)(.*)$/;
 297         if (defined $1) {
 298           my $s1 = $1;
 299           my $s2 = $2;
 300           $s = $3;
 301           $s1 =~ s/^\s*|\s*$//g;
 302           push @Words, split(/\s+/, $s1) if $s1;
 303           push @Words, $s2;
 304         }
 305         if ($s !~ /\s"/) {
 306           $s =~ s/^\s*|\s*$//g;
 307           push @Words, split(/\s+/, $s) if $s;
 308           $bool = 0;
 309         }
 310       }
 311
 312 #      @Words = split(/\s+/, $s);
 313       return 1 unless @Words;
 314 #      foreach my $i (0..$#Words) {
 315 #       if ($Words[$i] =~ /^\s*#/) {
 316 #         $#Words = $i - 1;
 317 #         last;
 318 #       }
 319 #      }
 320 #      return 1 unless @Words;
 321     }
 322
 323     if ($line =~ /^([\.']\s*PS\s*)|([\.']\s*PS\s.+)$/) {
 324       # .PS
 325       unless ($is_pic) {
 326         $is_pic = 'running';
 327         print "$line\n";
 328       }
 329       return 1;
 330     }
 331 ### main_line()
 332     if ( $line =~ /^([\.']\s*PE\s*)|([\.']\s*PE\s.+)$/ ) {
 333       # .PE
 334       $is_chem = '';
 335       if ($is_pic) {
 336         $is_pic = '';
 337         print "$line\n";
 338       }
 339       return 1;
 340     }
 341     if ($line =~ /^[\.']\s*cstart\s*$/) {
 342       # line: `.cstart'
 343       if ($is_chem) {
 344         &error("additional `.cstart'; chem is already active.");
 345         return 1;
 346       }
 347       unless ($is_pic) {
 348         &print_ps();
 349         $is_pic = 'by chem';
 350       }
 351       $is_chem = '.cstart';
 352       &init();
 353       return 1;
 354     }
 355 ### main_line()
 356     if ($line =~ /^\s*begin\s+chem\s*$/) {
 357       # line: `begin chem'
 358       if ($is_pic) {
 359         if ($is_chem) {
 360           &error("additional `begin chem'; chem is already active.");
 361           return 1;
 362         }
 363         $is_chem = 'begin chem';
 364         &init();
 365       } else {
 366         print "$line\n";
 367       }
 368       return 1;
 369     }
 370     if ($line =~ /^[\.']\s*cend\s*/) {
 371       # line `.cend'
 372       if ($is_chem) {
 373         &error("you end chem with `.cend', but started it with `begin chem'.")
 374           if $is_chem eq 'begin chem';
 375         if ($is_pic eq 'by chem') {
 376           &print_pe();
 377           $is_pic = '';
 378         }
 379         $is_chem = '';
 380       } else {
 381         print "$line\n";
 382       }
 383       return 1;
 384     }
 385     if ($line =~ /^\s*end\s*$/) {
 386       # line: `end'
 387       if ($is_chem) {
 388         &error("you end chem with `end', but started it with `.cstart'.")
 389           if $is_chem eq '.cstart';
 390         if ($is_pic eq 'by chem') {
 391           &print_pe();
 392           $is_pic = '';
 393         }
 394         $is_chem = '';
 395       } else {
 396         print "$line\n";
 397       }
 398       return 1;
 399     }
 400
 401 ### main_line()
 402     if (! $is_chem) {
 403       print "$line\n";
 404       return 1;
 405     }
 406     if ($line =~ /^[.']/) {
 407       # groff request line
 408       print "$line\n";
 409       return 1;
 410     }
 411
 412     if ($Words[0] eq 'pic') {
 413       # pic pass-thru
 414       return 1 if $#Words == 0;
 415       my $s = $line;
 416       $s =~ /^\s*pic\s*(.*)$/;
 417       $s = $1;
 418       print "$s\n" if $s;
 419       $Last_Type = $Types{'OTHER'};
 420       $Define{ $Words[2] } = 1 if $#Words >= 2 && $Words[1] eq 'define';
 421       return 1;
 422     }
 423
 424     if ($Words[0] eq 'textht') {
 425       if ($#Words == 0) {
 426         &error("`textht' needs a single argument.");
 427         return 0;
 428       }
 429       &error("only the last argument is taken for `textht', " .
 430              "all others are ignored.")
 431         unless $#Words <= 1 or ($#Words == 2 && $Words[1] =~ /^=/);
 432       $Params{'textht'} = $Words[$#Words];
 433       return 1;
 434     }
 435 ### main_line()
 436     if ($Words[0] eq 'cwid') {  # character width
 437       if ($#Words == 0) {
 438         &error("`cwid' needs a single argument.");
 439         return 0;
 440       }
 441       &error("only the last argument is taken for `cwid', " .
 442              "all others are ignored.")
 443         unless $#Words <= 1 or ($#Words == 2 && $Words[1] =~ /^=/);
 444       $Params{'cwid'} = $Words[$#Words];
 445       return 1;
 446     }
 447     if ($Words[0] eq 'db') {    # bond length
 448       if ($#Words == 0) {
 449         &error("`db' needs a single argument.");
 450         return 0;
 451       }
 452       &error("only the last argument is taken for `db', " .
 453              "all others are ignored.")
 454         unless $#Words <= 1 or ($#Words == 2 && $Words[1] =~ /^=/);
 455       $Params{'db'} = $Words[$#Words];
 456       return 1;
 457     }
 458     if ($Words[0] eq 'size') {  # size for all parts of the whole diagram
 459       my $size;
 460       if ($#Words == 0) {
 461         &error("`size' needs a single argument.");
 462         return 0;
 463       }
 464       &error("only the last argument is taken for `size', " .
 465              "all others are ignored.")
 466         unless $#Words <= 1 or ($#Words == 2 && $Words[1] =~ /^=/);
 467       if ($Words[$#Words] <= 4) {
 468         $size = $Words[$#Words];
 469       } else {
 470         $size = $Words[$#Words] / 10;
 471       }
 472       &setparams($size);
 473       return 1;
 474     }
 475
 476 ### main_line()
 477     print "\n#", $Line, "\n";                 # debugging, etc.
 478     $Last_Name = '';
 479 #    $Last_Type = $Types{'OTHER'};
 480 #    $Last_Type = '';
 481
 482     if ($Words[0] =~ /^[A-Z].*:$/) {
 483       # label;  falls thru after shifting left
 484       my $w = $Words[0];
 485       $Last_Name = $w;
 486       $Last_Name =~ s/:$//;
 487       print "$w";
 488       shift @Words;
 489       if (@Words) {
 490         print " ";
 491         $line =~ s/^\s*$w\s*//;
 492       } else {
 493         print "\n";
 494         return 1;
 495       }
 496     }
 497
 498     if ($Words[0] eq 'define') {
 499       print "$line\n";
 500       $Define{ $Words[1] } = 1 if $#Words >= 1;
 501       $Last_Type = $Types{'OTHER'};
 502       return 1;
 503     }
 504     if ($Words[0] =~ /^[\[\]{}]/) {
 505       print "$line\n";
 506       $Last_Type = $Types{'OTHER'};
 507       return 1;
 508     }
 509
 510     if ($Words[0] =~ /^"/) {
 511       print 'Last: ', $line, "\n";
 512       $Last_Type = $Types{'OTHER'};
 513       return 1;
 514     }
 515
 516     if ($Words[0] =~ /bond/) {
 517       &bond($Words[0]);
 518       return 1;
 519     }
 520
 521     if ($#Words >= 1) {
 522       if ($Words[0] =~ /^(double|triple|front|back)$/ &&
 523           $Words[1] eq 'bond') {
 524         my $w = shift @Words;
 525         $Words[0] = $w . $Words[0];
 526         &bond($Words[0]);
 527         return 1;
 528       }
 529       if ($Words[0] eq 'aromatic') {
 530         my $temp = $Words[0];
 531         $Words[0] = $Words[1] ? $Words[1] : '';
 532         $Words[1] = $temp;
 533       }
 534     }
 535
 536     if ($Words[0] =~ /ring|benz/) {
 537       &ring($Words[0]);
 538       return 1;
 539     }
 540     if ($Words[0] eq 'methyl') {
 541       # left here as an example
 542       $Words[0] = 'CH3';
 543     }
 544 ### main_line()
 545     if ($Words[0] =~ /^[A-Z]/) {
 546       &molecule();
 547       return 1;
 548     }
 549     if ($Words[0] eq 'left') {
 550       my %left;                 # not used
 551       $left{++$stack} = &fields(1, $#Words);
 552       printf (("Last: [\n"));
 553       return 1;
 554     }
 555     if ($Words[0] eq 'right') {
 556       &bracket();
 557       $stack--;
 558       return 1;
 559     }
 560     if ($Words[0] eq 'label') { # prints the vertex numbers in a ring
 561       if ( exists $Labtype{$Words[1]} and
 562            $Labtype{$Words[1]} =~ /^$Types{'RING'}/ ) {
 563         my $v = substr($Labtype{$Words[1]}, 1, 1);
 564         $Words[1] = '' unless $Words[1];
 565         foreach my $i ( 1..$v ) {
 566           printf "\"\\s-3%d\\s0\" at 0.%d<%s.C,%s.V%d>\n", $i, $v + 2,
 567             $Words[1], $Words[1], $i;
 568         }
 569       } else {
 570         &error("$Words[1] is not a ring.");
 571       }
 572       return 1;
 573     }
 574
 575     if ( exists $Define{ $Words[0] } ) {
 576       print $line, "\n";
 577       $Last_Type = $Types{'OTHER'};
 578       return 1;
 579     }
 580     return 1 unless $line;
 581 #    print STDERR "# $Line\n";
 582 #    &error('This is not a chem command.  To include a command for pic, ' .
 583 #          "add `pic' as the first word to the command.");
 584     print $line, "\n";
 585     $Last_Type = $Types{'OTHER'};
 586     1;
 587   } # main_line()
 588
 589 }
 590
 591 ########################################################################
 592 # functions
 593 ########################################################################
 594
 595 ##########
 596 # atom(<string>)
 597 #
 598 sub atom {
 599   # convert CH3 to atom(...)
 600   my ($s) = @_;
 601   my ($i, $n, $nsub, $cloc, $nsubc, @s);
 602   if ($s eq "\"\"") {
 603     return $s;
 604   }
 605   $n = length($s);
 606   $nsub = $nsubc = 0;
 607   $cloc = index($s, 'C');
 608   if (! defined($cloc) || $cloc < 0) {
 609     $cloc = 0;
 610   }
 611   @s = split('', $s);
 612   $i = 0;
 613   foreach (@s) {
 614     unless (/[A-Z]/) {
 615       $nsub++;
 616       $nsubc++ if $i < $cloc;
 617       $i++;
 618     }
 619   }
 620   $s =~ s/([0-9]+\.[0-9]+)|([0-9]+)/\\s-3\\d$&\\u\\s+3/g;
 621   if ($s =~ /([^0-9]\.)|(\.[^0-9])/) { # centered dot
 622     $s =~ s/\./\\v#-.3m#.\\v#.3m#/g;
 623   }
 624   sprintf( "atom(\"%s\", %g, %g, %g, %g, %g, %g)",
 625            $s, ($n - $nsub / 2) * $Params{'cwid'}, $Params{'textht'},
 626            ($cloc - $nsubc / 2 + 0.5) * $Params{'cwid'}, $Params{'crh'},
 627            $Params{'crw'}, $Params{'dav'}
 628          );
 629 } # atom()
 630
 631
 632 ##########
 633 # bond(<type>)
 634 #
 635 sub bond {
 636   my ($type) = @_;
 637   my ($i, $moiety, $from, $leng);
 638   $moiety = '';
 639   for ($i = 1; $i <= $#Words; $i++) {
 640     if ($Words[$i] eq ';') {
 641       &error("a colon `;' must be followed by a space and a single word.")
 642        if $i != $#Words - 1;
 643       $moiety = $Words[$i + 1] if $#Words > $i;
 644       $#Words = $i - 1;
 645       last;
 646     }
 647   }
 648   $leng = $Params{'db'};        # bond length
 649   $from = '';
 650   for ($Word_Count = 1; $Word_Count <= $#Words; ) {
 651     if ($Words[$Word_Count] =~
 652         /(\+|-)?\d+|up|down|right|left|ne|se|nw|sw/) {
 653       $Dir = &cvtdir($Dir);
 654     } elsif ($Words[$Word_Count] =~ /^leng/) {
 655       $leng = $Words[$Word_Count + 1] if $#Words > $Word_Count;
 656       $Word_Count += 2;
 657     } elsif ($Words[$Word_Count] eq 'to') {
 658       $leng = 0;
 659       $from = &fields($Word_Count, $#Words);
 660       last;
 661     } elsif ($Words[$Word_Count] eq 'from') {
 662       $from = &dofrom();
 663       last;
 664     } elsif ($Words[$Word_Count] =~ /^#/) {
 665       $Word_Count = $#Words + 1;
 666       last;
 667     } else {
 668       $from = &fields($Word_Count, $#Words);
 669       last;
 670     }
 671   }
 672 ### bond()
 673   if ($from =~ /( to )|^to/) {  # said "from ... to ...", so zap length
 674     $leng = 0;
 675   } elsif (! $from) {           # no from given at all
 676     $from = 'from Last.' . &leave($Last_Type, $Dir) . ' ' .
 677       &fields($Word_Count, $#Words);
 678   }
 679   printf "Last: %s(%g, %g, %s)\n", $type, $leng, $Dir, $from;
 680   $Last_Type = $Types{'BOND'};
 681   $Labtype{$Last_Name} = $Last_Type if $Last_Name;
 682   if ($moiety) {
 683     @Words = ($moiety);
 684     &molecule();
 685   }
 686 } # bond()
 687
 688
 689 ##########
 690 # bracket()
 691 #
 692 sub bracket {
 693   my $t;
 694   printf (("]\n"));
 695   if ($Words[1] && $Words[1] eq ')') {
 696     $t = 'spline';
 697   } else {
 698     $t = 'line';
 699   }
 700   printf "%s from last [].sw+(%g,0) to last [].sw to last [].nw to last " .
 701     "[].nw+(%g,0)\n", $t, $Params{'dbrack'}, $Params{'dbrack'};
 702   printf "%s from last [].se-(%g,0) to last [].se to last [].ne to last " .
 703     "[].ne-(%g,0)\n", $t, $Params{'dbrack'}, $Params{'dbrack'};
 704   if ($Words[2] && $Words[2] eq 'sub') {
 705     printf "\" %s\" ljust at last [].se\n", &fields(3, $#Words);
 706   }
 707 } # bracket()
 708
 709
 710 ##########
 711 # corner(<dir>)
 712 #
 713 # Return the corner name next to the given angle.
 714 #
 715 sub corner {
 716   my ($d) = @_;
 717   $Dc{ (45 * int(($d + 22.5) / 45)) % 360 };
 718 } # corner()
 719
 720
 721 ##########
 722 # cvtdir(<dir>)
 723 #
 724 # Maps "[pointing] somewhere" to degrees.
 725 #
 726 sub cvtdir {
 727   my ($d) = @_;
 728   if ($Words[$Word_Count] eq 'pointing') {
 729     $Word_Count++;
 730   }
 731   if ($Words[$Word_Count] =~ /^[+\\-]?\d+/) {
 732     return ( $Words[$Word_Count++] % 360 );
 733   } elsif ($Words[$Word_Count] =~ /left|right|up|down|ne|nw|se|sw/) {
 734     return ( $Dc{$Words[$Word_Count++]} % 360 );
 735   } else {
 736     $Word_Count++;
 737     return $d;
 738   }
 739 } # cvtdir()
 740
 741
 742 ##########
 743 # dblring(<v>)
 744 #
 745 sub dblring {
 746   my ($v) = @_;
 747   my ($d, $v1, $v2);
 748   # should canonicalize to i,i+1 mod v
 749   $d = $Words[$Word_Count];
 750   for ($Word_Count++; $Word_Count <= $#Words &&
 751        $Words[$Word_Count] =~ /^[1-9]/; $Word_Count++) {
 752     $v1 = substr($Words[$Word_Count], 0, 1);
 753     $v2 = substr($Words[$Word_Count], 2, 1);
 754     if ($v2 == $v1 + 1 || $v1 == $v && $v2 == 1) { # e.g., 2,3 or 5,1
 755       $Dbl{$v1} = $d;
 756     } elsif ($v1 == $v2 + 1 || $v2 == $v && $v1 == 1) { # e.g., 3,2 or 1,5
 757       $Dbl{$v2} = $d;
 758     } else {
 759       &error(sprintf("weird %s bond in\n\t%s", $d, $_));
 760     }
 761   }
 762 } # dblring()
 763
 764
 765 ##########
 766 # dofrom()
 767 #
 768 sub dofrom {
 769   my $n;
 770   $Word_Count++;                        # skip "from"
 771   $n = $Words[$Word_Count];
 772   if (defined $Labtype{$n}) {   # "from Thing" => "from Thing.V.s"
 773     return 'from ' . $n . '.' . &leave($Labtype{$n}, $Dir);
 774   }
 775   if ($n =~ /^\.[A-Z]/) {       # "from .V" => "from Last.V.s"
 776     return 'from Last' . $n . '.' . &corner($Dir);
 777   }
 778   if ($n =~ /^[A-Z][^.]*\.[A-Z][^.]*$/) { # "from X.V" => "from X.V.s"
 779     return 'from ' . $n . '.' . &corner($Dir);
 780   }
 781   &fields($Word_Count - 1, $#Words);
 782 } # dofrom()
 783
 784
 785 ##########
 786 # error(<string>)
 787 #
 788 sub error {
 789   my ($s) = @_;
 790   printf STDERR "chem: error in %s on line %d: %s\n",
 791     $File_Name, $Line_No, $s;
 792 } # error()
 793
 794
 795 ##########
 796 # fields(<n1>, <n2>)
 797 #
 798 sub fields {
 799   my ($n1, $n2) = @_;
 800   if ($n1 > $n2) {
 801     return '';
 802   }
 803   my $s = '';
 804   foreach my $i ($n1..$n2) {
 805     if ($Words[$i] =~ /^#/) {
 806       last;
 807     }
 808     $s = $s . $Words[$i] . ' ';
 809   }
 810   $s;
 811 } # fields()
 812
 813
 814 ##########
 815 # init()
 816 #
 817 sub init {
 818   if ($First_Time) {
 819     printf "copy \"%s\"\n", $File_chem_pic;
 820     printf "\ttextht = %g; textwid = .1; cwid = %g\n",
 821       $Params{'textht'}, $Params{'cwid'};
 822     printf "\tlineht = %g; linewid = %g\n",
 823       $Params{'lineht'}, $Params{'linewid'};
 824     $First_Time = 0;
 825   }
 826   printf "Last: 0,0\n";
 827   $Last_Type = $Types{'OTHER'};
 828   $Dir = 90;
 829 } # init()
 830
 831
 832 ##########
 833 # leave(<last>, <d>)
 834 #
 835 sub leave {
 836   my ($last, $d) = @_;
 837   my ($c, $c1);
 838   # return vertex of $last in direction $d
 839   if ( $last eq $Types{'BOND'} ) {
 840     return 'end';
 841   }
 842   $d %= 360;
 843   if ( $last =~ /^$Types{'RING'}/ ) {
 844     return &ringleave($last, $d);
 845   }
 846   if ( $last eq $Types{'MOL'} ) {
 847     if ($d == 0 || $d == 180) {
 848       $c = 'C';
 849     } elsif ($d > 0 && $d < 180) {
 850       $c = 'R';
 851     } else {
 852       $c = 'L';
 853     }
 854     if (defined $Dc{$d}) {
 855       $c1 = $Dc{$d};
 856     } else {
 857       $c1 = &corner($d);
 858     }
 859     return sprintf('%s.%s', $c, $c1);
 860   }
 861   if ( $last eq $Types{'OTHER'} ) {
 862     return &corner($d);
 863   }
 864   'c';
 865 } # leave()
 866
 867
 868 ##########
 869 # makering(<type>, <pt>, <v>)
 870 #
 871 sub makering {
 872   my ($type, $pt, $v) = @_;
 873   my ($i, $j, $a, $r, $rat, $fix, $c1, $c2);
 874   if ($type =~ /flat/) {
 875     $v = 6;
 876     # vertices
 877     ;
 878   }
 879   $r = $Params{'ringside'} / (2 * sin(pi / $v));
 880   printf "\tC: 0,0\n";
 881   for ($i = 0; $i <= $v + 1; $i++) {
 882     $a = (($i - 1) / $v * 360 + $pt) / 57.29578; # 57. is $deg
 883     printf "\tV%d: (%g,%g)\n", $i, $r * sin($a), $r * cos($a);
 884   }
 885   if ($type =~ /flat/) {
 886     printf "\tV4: V5; V5: V6\n";
 887     $v = 5;
 888   }
 889   # sides
 890   if ($Nput > 0) {
 891     # hetero ...
 892     for ($i = 1; $i <= $v; $i++) {
 893       $c1 = $c2 = 0;
 894       if ($Put{$i} ne '') {
 895         printf "\tV%d: ellipse invis ht %g wid %g at V%d\n",
 896           $i, $Params{'crh'}, $Params{'crw'}, $i;
 897         printf "\t%s at V%d\n", $Put{$i}, $i;
 898         $c1 = $Params{'cr'};
 899       }
 900       $j = $i + 1;
 901       if ($j > $v) {
 902         $j = 1;
 903       }
 904 ### makering()
 905       if ($Put{$j} ne '') {
 906         $c2 = $Params{'cr'};
 907       }
 908       printf "\tline from V%d to V%d chop %g chop %g\n", $i, $j, $c1, $c2;
 909       if ($Dbl{$i} ne '') {
 910         # should check i<j
 911         if ($type =~ /flat/ && $i == 3) {
 912           $rat = 0.75;
 913           $fix = 5;
 914         } else {
 915           $rat = 0.85;
 916           $fix = 1.5;
 917         }
 918         if ($Put{$i} eq '') {
 919           $c1 = 0;
 920         } else {
 921           $c1 = $Params{'cr'} / $fix;
 922         }
 923         if ($Put{$j} eq '') {
 924           $c2 = 0;
 925         } else {
 926           $c2 = $Params{'cr'} / $fix;
 927         }
 928         printf "\tline from %g<C,V%d> to %g<C,V%d> chop %g chop %g\n",
 929           $rat, $i, $rat, $j, $c1, $c2;
 930         if ($Dbl{$i} eq 'triple') {
 931           printf "\tline from %g<C,V%d> to %g<C,V%d> chop %g chop %g\n",
 932             2 - $rat, $i, 2 - $rat, $j, $c1, $c2;
 933         }
 934       }
 935     }
 936 ### makering()
 937   } else {
 938     # regular
 939     for ($i = 1; $i <= $v; $i++) {
 940       $j = $i + 1;
 941       if ($j > $v) {
 942         $j = 1;
 943       }
 944       printf "\tline from V%d to V%d\n", $i, $j;
 945       if ($Dbl{$i} ne '') {
 946         # should check i<j
 947         if ($type =~ /flat/ && $i == 3) {
 948           $rat = 0.75;
 949         } else {
 950           $rat = 0.85;
 951         }
 952         printf "\tline from %g<C,V%d> to %g<C,V%d>\n",
 953           $rat, $i, $rat, $j;
 954         if ($Dbl{$i} eq 'triple') {
 955           printf "\tline from %g<C,V%d> to %g<C,V%d>\n",
 956             2 - $rat, $i, 2 - $rat, $j;
 957         }
 958       }
 959     }
 960   }
 961 ### makering()
 962   # punt on triple temporarily
 963   # circle
 964   if ($type =~ /benz/ || $Aromatic > 0) {
 965     if ($type =~ /flat/) {
 966       $r *= .4;
 967     } else {
 968       $r *= .5;
 969     }
 970     printf "\tcircle rad %g at 0,0\n", $r;
 971   }
 972 } # makering()
 973
 974
 975 ##########
 976 # molecule()
 977 #
 978 sub molecule {
 979   my ($n, $type);
 980   if ($#Words >= 0) {
 981     $n = $Words[0];
 982     if ($n eq 'BP') {
 983       $Words[0] = "\"\" ht 0 wid 0";
 984       $type = $Types{'OTHER'};
 985     } else {
 986       $Words[0] = &atom($n);
 987       $type = $Types{'MOL'};
 988     }
 989   }
 990   $n =~ s/[^A-Za-z0-9]//g;      # for stuff like C(OH3): zap non-alnum
 991   if ($#Words < 1) {
 992     printf "Last: %s: %s with .%s at Last.%s\n",
 993       $n, join(' ', @Words), &leave($type, $Dir + 180),
 994         &leave($Last_Type, $Dir);
 995 ### molecule()
 996   } else {
 997     if (! $Words[1]) {
 998       printf "Last: %s: %s with .%s at Last.%s\n",
 999         $n, join(' ', @Words), &leave($type, $Dir + 180),
1000           &leave($Last_Type, $Dir);
1001     } elsif ($#Words >= 1 and $Words[1] eq 'below') {
1002       $Words[2] = '' if ! $Words[2];
1003       printf "Last: %s: %s with .n at %s.s\n", $n, $Words[0], $Words[2];
1004     } elsif ($#Words >= 1 and $Words[1] eq 'above') {
1005       $Words[2] = '' if ! $Words[2];
1006       printf "Last: %s: %s with .s at %s.n\n", $n, $Words[0], $Words[2];
1007     } elsif ($#Words >= 2 and $Words[1] eq 'left' && $Words[2] eq 'of') {
1008       $Words[3] = '' if ! $Words[3];
1009       printf "Last: %s: %s with .e at %s.w+(%g,0)\n",
1010         $n, $Words[0], $Words[3], $Params{'dew'};
1011     } elsif ($#Words >= 2 and $Words[1] eq 'right' && $Words[2] eq 'of') {
1012       $Words[3] = '' if ! $Words[3];
1013       printf "Last: %s: %s with .w at %s.e-(%g,0)\n",
1014         $n, $Words[0], $Words[3], $Params{'dew'};
1015     } else {
1016       printf "Last: %s: %s\n", $n, join(' ', @Words);
1017     }
1018   }
1019
1020   $Last_Type = $type;
1021   if ($Last_Name) {
1022     #    $Last_Type = '';
1023     $Labtype{$Last_Name} = $Last_Type;
1024   }
1025  $Labtype{$n} = $Last_Type;
1026 } # molecule()
1027
1028
1029 ##########
1030 # print_hash(<hash_or_ref>)
1031 #
1032 # print the elements of a hash or hash reference
1033 #
1034 sub print_hash {
1035   my $hr;
1036   my $n = scalar @_;
1037   if ($n == 0) {
1038     print STDERR "empty hash\n;";
1039     return 1;
1040   } elsif ($n == 1) {
1041     if (ref($_[0]) eq 'HASH') {
1042       $hr = $_[0];
1043     } else {
1044       warn 'print_hash(): the argument is not a hash or hash reference;';
1045       return 0;
1046     }
1047   } else {
1048     if ($n % 2) {
1049       warn 'print_hash(): the arguments are not a hash;';
1050       return 0;
1051     } else {
1052       my %h = @_;
1053       $hr = \%h;
1054     }
1055   }
1056
1057 ### print_hash()
1058   unless (%$hr) {
1059     print STDERR "empty hash\n";
1060     return 1;
1061   }
1062   print STDERR "hash (ignore the ^ characters):\n";
1063   for my $k (sort keys %$hr) {
1064     my $hk = $hr->{$k};
1065     print STDERR "  $k => ";
1066     if (defined $hk) {
1067       print STDERR "^$hk^";
1068     } else {
1069       print STDERR "undef";
1070     }
1071     print STDERR "\n";
1072   }
1073
1074   1;
1075 }                               # print_hash()
1076
1077
1078 ##########
1079 # print_pe()
1080 #
1081 sub print_pe {
1082   print ".PE\n";
1083 } # print_pe()
1084
1085
1086 ##########
1087 # print_ps()
1088 #
1089 sub print_ps {
1090   print ".PS\n";
1091 } # print_ps()
1092
1093 ##########
1094 # putring(<v>)
1095 #
1096 sub putring {
1097   # collect "put Mol at n"
1098   my ($v) = @_;
1099   my ($m, $mol, $n);
1100   $Word_Count++;
1101   $mol = $Words[$Word_Count++];
1102   if ($Words[$Word_Count] eq 'at') {
1103     $Word_Count++;
1104   }
1105   $n = $Words[$Word_Count];
1106   if ($n !~ /^\d+$/) {
1107     $n =~ s/(\d)+$/$1/;
1108     $n = 0 if $n !~ /^\d+$/;
1109     error('use single digit as argument for "put at"');
1110   }
1111   if ($n >= 1 && $n <= $v) {
1112     $m = $mol;
1113     $m =~ s/[^A-Za-z0-9]//g;
1114     $Put{$n} = $m . ':' . &atom($mol);
1115   } elsif ($n == 0) {
1116     error('argument of "put at" must be a single digit');
1117   } else {
1118     error('argument of "put at" is too large');
1119   }
1120   $Word_Count++;
1121 } # putring()
1122
1123
1124 ##########
1125 # ring(<type>)
1126 #
1127 sub ring {
1128   my ($type) = @_;
1129   my ($typeint, $pt, $verts, $i, $other, $fused, $withat);
1130   $pt = 0;                      # points up by default
1131   if ($type =~ /([1-8])$/) {
1132     $verts = $1;
1133   } elsif ($type =~ /flat/) {
1134     $verts = 5;
1135   } else {
1136     $verts = 6;
1137   }
1138   $fused = $other = '';
1139   for ($i = 1; $i <= $verts; $i++) {
1140     $Put{$i} = $Dbl{$i} = '';
1141   }
1142   $Nput = $Aromatic = $withat = 0;
1143   for ($Word_Count = 1; $Word_Count <= $#Words; ) {
1144     if ($Words[$Word_Count] eq 'pointing') {
1145       $pt = &cvtdir(0);
1146     } elsif ($Words[$Word_Count] eq 'double' ||
1147              $Words[$Word_Count] eq 'triple') {
1148       &dblring($verts);
1149     } elsif ($Words[$Word_Count] =~ /arom/) {
1150       $Aromatic++;
1151       $Word_Count++;            # handled later
1152 ### ring()
1153     } elsif ($Words[$Word_Count] eq 'put') {
1154       &putring($verts);
1155       $Nput++;
1156     } elsif ($Words[$Word_Count] =~ /^#/) {
1157       $Word_Count = $#Words + 1;
1158       last;
1159     } else {
1160       if ($Words[$Word_Count] eq 'with' || $Words[$Word_Count] eq 'at') {
1161         $withat = 1;
1162       }
1163       $other = $other . ' ' . $Words[$Word_Count];
1164       $Word_Count++;
1165     }
1166   }
1167   $typeint = $Types{'RING'} . $verts . $pt; # RING | verts | dir
1168   if ($withat == 0) {
1169     # join a ring to something
1170     if ( $Last_Type =~ /^$Types{'RING'}/ ) {
1171       # ring to ring
1172       if (substr($typeint, 2) eq substr($Last_Type, 2)) {
1173         # fails if not 6-sided
1174         $fused = 'with .V6 at Last.V2';
1175       }
1176     }
1177     # if all else fails
1178     $fused = sprintf('with .%s at Last.%s',
1179           &leave($typeint, $Dir + 180), &leave($Last_Type, $Dir));
1180   }
1181   printf "Last: [\n";
1182   &makering($type, $pt, $verts);
1183   printf "] %s %s\n", $fused, $other;
1184   $Last_Type = $typeint;
1185   $Labtype{$Last_Name} = $Last_Type if $Last_Name;
1186 } # ring()
1187
1188
1189 ##########
1190 # ringleave(<last>, <d>)
1191 #
1192 sub ringleave {
1193   my ($last, $d) = @_;
1194   my ($rd, $verts);
1195   # return vertex of ring in direction d
1196   $verts = substr($last, 1, 1);
1197   $rd = substr($last, 2);
1198   sprintf('V%d.%s', int( (($d - $rd) % 360) / (360 / $verts)) + 1,
1199           &corner($d));
1200 } # ringleave()
1201
1202
1203 ##########
1204 # setparams(<scale>)
1205 #
1206 sub setparams {
1207   my ($scale) = @_;
1208   $Params{'lineht'} = $scale * 0.2;
1209   $Params{'linewid'} = $scale * 0.2;
1210   $Params{'textht'} = $scale * 0.16;
1211   $Params{'db'} = $scale * 0.2; # bond length
1212   $Params{'cwid'} = $scale * 0.12;      # character width
1213   $Params{'cr'} = $scale * 0.08; # rad of invis circles at ring vertices
1214   $Params{'crh'} = $scale * 0.16; # ht of invis ellipse at ring vertices
1215   $Params{'crw'} = $scale * 0.12; # wid
1216   $Params{'dav'} = $scale * 0.015; # vertical shift up for atoms in atom macro
1217   $Params{'dew'} = $scale * 0.02; # east-west shift for left of/right of
1218   $Params{'ringside'} = $scale * 0.3; # side of all rings
1219   $Params{'dbrack'} = $scale * 0.1; # length of bottom of bracket
1220 } # setparams()
1221
1222
1223 ##########
1224 # usage()
1225 #
1226 # Print usage information for --help.
1227 #
1228 sub usage {
1229   print "\n";
1230   &version();
1231   print <<EOF;
1232
1233 Usage: $Chem_Name [option]... [filespec]...
1234
1235 $Chem_Name is a groff preprocessor for producing chemical structure
1236 diagrams.  The output suits to the pic preprocessor.
1237
1238 "filespec" is one of
1239   "filename"       name of a readable file
1240   "-"              for standard input
1241
1242 All available options are
1243
1244 -h --help         print this usage message.
1245 -v --version      print version information.
1246
1247 EOF
1248 } # usage()
1249
1250
1251 ##########
1252 # version()
1253 #
1254 # Get version information from version.sh and print a text with this.
1255 #
1256 sub version {
1257   $Groff_Version = $Groff_Version_Preset unless $Groff_Version;
1258   my $year = $Last_Update;
1259   $year =~ s/^.* //;
1260   print <<EOF;
1261 $Chem_Name $Program_Version of $Last_Update (Perl version)
1262 is part of groff version $Groff_Version.
1263 Copyright (C) $year Free Software Foundation, Inc.
1264 GNU groff and chem come with ABSOLUTELY NO WARRANTY.
1265 You may redistribute copies of groff and its subprograms
1266 under the terms of the GNU General Public License.
1267 EOF
1268 } # version()
1269
1270 1;
1271 ### Emacs settings
1272 # Local Variables:
1273 # mode: CPerl
1274 # End: