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