summaryrefslogtreecommitdiff
path: root/support/ochem/chemie.pl
diff options
context:
space:
mode:
authorNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
committerNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
commite0c6872cf40896c7be36b11dcc744620f10adf1d (patch)
tree60335e10d2f4354b0674ec22d7b53f0f8abee672 /support/ochem/chemie.pl
Initial commit
Diffstat (limited to 'support/ochem/chemie.pl')
-rwxr-xr-xsupport/ochem/chemie.pl2727
1 files changed, 2727 insertions, 0 deletions
diff --git a/support/ochem/chemie.pl b/support/ochem/chemie.pl
new file mode 100755
index 0000000000..70a1cc55af
--- /dev/null
+++ b/support/ochem/chemie.pl
@@ -0,0 +1,2727 @@
+#!/usr/bin/perl -w
+#
+# CHEM.PL
+#
+# reads chemistry program and generates LaTeX picture environment
+# with PostScript drawing and LaTeX text. Backend can be configured
+# for easy generation of PS and other formats.
+# (c) 1999 Ingo Kloeckl
+#
+# Modification history
+# 1999-03-20 I.Kloeckl file creation
+# 1999-03-26 I.Kloeckl new design
+# 1999-04-03 I.Kloeckl generic output (PS, PS/LaTeX, LaTeX)
+# 1999-04-11 I.Kloeckl code consolidation
+# 1999-05-02 I.Kloeckl bugs fixed, goodies added
+# 1999-10-20 I.Kloeckl setting \unitlength in a group before opening chem picture
+# 2000-01-19 I.Kloeckl LaTeX packages can be given to be preloaded
+# 2001-01-22 I.Kloeckl close LaTeX environments after error exit
+# 2001-04-06 I.Kloeckl resize picture to its natural size for EPS generation
+# to-do wish list
+# o are t/r/b angles with type="chair",0/-1 ok?
+# o let bicyclic ring systems (bc221h, bc311h, bc222o, bc321o) rotate
+# o better parsing of p1 of bond (direction argument)
+# o make pure LaTeX output better looking
+# o pure PS output WITH text
+#
+
+use lib '.';
+use Getopt::Long;
+
+# ### load helper classes ##################
+use loc; # point class
+use bbox; # (bounding) box class
+use streambuf; # source stream/tokenizer class
+use be; # generic output
+
+# #### error codes #########################
+$lberr = 1; $errmsg[$lberr] = "left brace missing";
+$rberr = 2; $errmsg[$rberr] = "right brace missing";
+$komma = 3; $errmsg[$komma] = "Komma missing";
+$interr = 4; $errmsg[$interr] = "error parsing integer";
+$texterr = 5; $errmsg[$texterr] = "error parsing text";
+$texerr = 6; $errmsg[$texerr] = "error parsing TeX text";
+$poserr = 7; $errmsg[$poserr] = "error parsing position marker";
+$bonderr = 8; $errmsg[$bonderr] = "error parsing bond type";
+$colonerr = 9; $errmsg[$colonerr] = "colon missing";
+$synterr = 10; $errmsg[$synterr] = "syntax error";
+$badargerr = 11; $errmsg[$badargerr] = "bad argument";
+$incargerr = 12; $errmsg[$incargerr] = "inconsistent arguments";
+$realerr = 13; $errmsg[$realerr] = "error parsing fix float number";
+$typerr = 14; $errmsg[$typerr] = "unknown ring type";
+$liberr = 15; $errmsg[$liberr] = "unknown library";
+$nexerr = 16; $errmsg[$nexerr] = "non-existing index";
+
+$true = (1==1);
+$false = (1==0);
+$pi = 3.1415927;
+
+# global functional vars
+$iAngleR = 0;
+$iAngleT = 0;
+$iAngleB = 0;
+$iAngle_v = 0;
+$iAngleBond = 0; # angle of last drawn bond
+
+$trace = 0;
+$level = 0;
+
+# ### the code #############################
+
+#////////////////////////////////////////////////////////
+#
+# set parameter (dimens in pt)
+#
+sub init_param
+{
+ $rLenS = 8; # short bond 8 pt
+ $rLenN = 12; # normal bond 12 pt
+ $rLenL = 18; # long bond 18 pt
+ $rLW = 0.7; # line width
+ $rBW = 2.5; # bond width
+ $rBD = 1; # bond dash pattern
+ $rAW = 5; # arrow width
+
+ $rArrowSkip = 6; # vert. space between arrow and text
+ $rArrowExtend = 24; # Abstand, um den der Pfeil ggue. den
+ # Beschriftungen verlaengert wird
+
+ $rXS = 6; # hor. and vert. spacing
+ $rYS = 6;
+ $rEmove = 3; # for electron moving
+
+ $rChainSep = 36; # vertical distance between reaction chains
+ $rMultilineSep = 36; # vertical distance between lines
+ $rTextSep = 24; # distance text - formula
+
+ $fboxsep = 3; # frame and bracket separation
+}
+
+
+#////////////////////////////////////////////////////////
+#
+# prints a trace message
+#
+sub trace
+{
+ my ($proc, $flag) = @_;
+ if ($level<$trace)
+ {
+ printf "%02d%s%s: Flag ist %d %s...\n",
+ $level, " "x(2*$level), $proc, $flag,
+ substr($buf->{"Buffer"}, $buf->{"Ptr"}, 40);
+ }
+}
+
+
+#////////////////////////////////////////////////////////
+#
+# prints an error message
+#
+sub error
+{
+ my ($errn, $proc) = @_;
+ printf "%s: error %d, %s\n", $proc, $errn, $errmsg[$errn];
+ printf " %s...\n", substr($buf->{"Buffer"}, $buf->{"Ptr"}, 40);
+}
+
+
+#////////////////////////////////////////////////////////
+#
+# utility functions
+#
+sub max
+{
+ my $m = $_[0];
+ foreach $elem (@_)
+ {
+ $m = $elem if $elem>$m;
+ }
+ return $m;
+}
+
+
+#////////////////////////////////////////////////////////
+#//
+#// branch
+#// {fliste;
+#// fliste;
+#// ...
+#// }
+#//
+sub branch
+{
+ my ($XYg, $XYweiter, $BBoxg, $bFlag) = @_;
+ my $XY = new loc();
+ my $BBox = new bbox;
+ my $errn = 0;
+ $level++;
+
+ $errn = $synterr, goto error if !$buf->NextToken("{");
+ # scanne ausgehende Strukturen
+ while (!$buf->NextToken("}"))
+ {
+ $XY->eq($XYg);
+ $BBox->init($XY);
+ $errn = $synterr, goto error if !&fliste($XY, $BBox, $bFlag, ";");
+ $BBoxg->MinMax($BBox);
+ }
+ $XYweiter->eq($XYg);
+ $level--;
+ return $true;
+
+error:
+ $level--;
+ &error($errn, "branch");
+ return $false;
+}
+
+
+#//////////////////////////////////////
+#
+# some routines for generic ring macro
+#
+sub getangle
+{
+ my ($p1, $p2) = @_;
+ return atan2($p2->{"y"}-$p1->{"y"}, $p2->{"x"}-$p1->{"x"})*180/$pi;
+}
+
+sub getlength
+{
+ my ($p1, $p2) = @_;
+ my ($dx, $dy) = ($p2->{"x"}-$p1->{"x"}, $p2->{"y"}-$p1->{"y"});
+ return sqrt($dx*$dx+$dy*$dy);
+}
+
+sub getpos
+{
+ my ($p1, $iAngle, $rLen) = @_;
+ my $p2 = new loc();
+ $p2->eq($p1->{"x"} + cos($iAngle*$pi/180)*$rLen, $p1->{"y"} + sin($iAngle*$pi/180)*$rLen);
+ return $p2;
+}
+
+# polygon
+# parameter: "ring", n, iangle, startpos, bliste, radius
+sub ring_default_
+{
+ my ($iAnz, $n, $iAngle, $iStart, $BT, $bAromat, $rRadius) = @_;
+ $$iAnz = $$n = 6;
+ $$iStart = 0;
+ $$iAngle = -90;
+ $$rRadius = $rLenN;
+ $$bAromat = $true;
+ @$BT = (0, 0, 0, 0, 0, 0);
+}
+
+sub ring_
+{
+ my ($XYstart, $rRadius, $rRadius_bak, $iAnz, $n, $iAngle, $iStart,
+ $M, $rLena, $rThetaa, $XYa, $BLa, $t, $b, $r) = @_;
+
+ $$iAnz = $n;
+ my $rAngle = (90-360/$n*$iStart + $iAngle)*$pi/180;
+ my $rLen;
+ if ($$rRadius<0)
+ {
+ $rLen = abs($$rRadius);
+ $$rRadius = $rLen/(2*sin($pi/$n));
+ }
+ else
+ {
+ $rLen = 2 * $$rRadius * sin($pi/$n);
+ }
+ $M->eq(- sin($rAngle)*$$rRadius, cos($rAngle)*$$rRadius);
+ $M->translate($XYstart);
+ my $i;
+ my $rTheta = (-90-180/$n) + $iAngle;
+ my $XY = new loc();
+ for ($i=0; $i<$n; $i++)
+ {
+ $rLena->[$i] = $rLen;
+ $rThetaa->[$i] = $rTheta;
+ $t->[$i] = $rTheta+180;
+ $b->[$i] = $rTheta + 360/$n;
+ $r->[$i] = $iAngle - $i*360/$n;
+ $rTheta -= 360/$n;
+ $XY->eq($M);
+ $rAngle = (90-360/$n*$i + $iAngle)*$pi/180;
+ $XY->translate(sin($rAngle)*$$rRadius, -cos($rAngle)*$$rRadius);
+ $XYa->[$i] = $XY->new();
+ $BLa->[$i] = $i;
+ }
+ $$rRadius_bak = $$rRadius;
+ $$rRadius *= 0.7;
+}
+
+# cyclohexane in chair conformation
+# parameter: "chair", , p2, startpos, bliste, radius
+# p2 = 1 | 0 | -1: three conformations
+sub chair_default_
+{
+ my ($iAnz, $conf, $iAngle, $iStart, $BT, $bAromat, $rRadius) = @_;
+ $$iAnz = 6;
+ $$iStart = $$iAngle = 0;
+ $$conf = 1;
+ $$rRadius = $rLenN;
+ $$bAromat = $false;
+ @$BT = (0, 0, 0, 9, 9, 9);
+}
+
+sub chair_
+{
+ my ($XYstart, $rRadius, $rRadius_bak, $iAnz, $conf, $iAngle, $iStart,
+ $M, $rLena, $rThetaa, $XYa, $BLa, $t, $b, $r) = @_;
+
+ $$rRadius_bak = $$rRadius = abs($$rRadius);
+ my ($dx, $dy) = (cos(30*$pi/180)*$$rRadius, sin(30*$pi/180)*$$rRadius);
+ my ($sx, $sy) = ($$rRadius, sin(30*$pi/180)*(2*$$rRadius));
+ my $l1 = sqrt($sx*$sx+$sy*$sy);
+ if ($conf == 1)
+ {
+ @$XYa = (new loc(0,0), new loc($dx,-$dy), new loc(2*$dx,0),
+ new loc($sx+2*$dx,-$sy), new loc($sx+$dx,$dy-$sy),
+ new loc($sx,-$sy));
+ @$rThetaa = (-30, +30, getangle($$XYa[2], $$XYa[3]),
+ 150, -150, getangle($$XYa[5], $$XYa[0]));
+ @$rLena = ($$rRadius, $$rRadius, $l1, $$rRadius, $$rRadius, $l1);
+ @$r = (150, -90, 90, -30, 90, -90);
+ @$t = (90, 120, 90, 30, 90, 160);
+ @$b = (-150, -90, -20, -90, -60, -90);
+ }
+ elsif ($conf == 0)
+ {
+ @$XYa = (new loc(0,0), new loc($dx,-$dy), new loc(3*$dx,$dy),
+ new loc(4*$dx,0), new loc(3*$dx,-$dy), new loc($dx,$dy));
+ @$rThetaa = (-30, 30, -30, -150, 150, -150);
+ @$rLena = ($$rRadius, 2*$$rRadius, $$rRadius, $$rRadius, 2*$$rRadius, $$rRadius);
+ @$r = (180, 120, -60, 0, 60, -120);
+ @$t = (150, 20, 90, 30, 90, -20);
+ @$b = (-90, -90, -20, -90, -20, -90);
+ }
+ elsif ($conf == -1)
+ {
+ @$XYa = (new loc(0,0), new loc($sx,$sy), new loc($sx+$dx,$sy-$dy),
+ new loc($sx+2*$dx,$sy), new loc(2*$dx,0), new loc($dx,$dy));
+ @$rThetaa = (getangle($$XYa[0], $$XYa[1]), -30, 30,
+ getangle($$XYa[3], $$XYa[4]), 150, -150);
+ @$rLena = ($l1, $$rRadius, $$rRadius, $l1, $$rRadius, $$rRadius);
+ @$r = (-150, 90, -90, 30, -90, 90);
+ @$t = (150, 90, 60, 90, 20, 90);
+ @$b = (-90, -160, -90, -30, -90, -120);
+ }
+ grep(($_->rotate($iAngle) && 0), @$XYa);
+ my $XYshift = new loc($$XYa[$iStart]);
+ grep(($_->translate(- $XYshift->{"x"},
+ - $XYshift->{"y"}) && 0), @$XYa);
+ grep(($_->translate($XYstart) && 0), @$XYa);
+ $M->eq(0,0);
+ $M->translate($XYstart);
+ @$BLa = (0, 1, 2, 3, 4, 5); # start atom
+ grep((($_ += $iAngle) && 0), @$r, @$t, @$b, @$rThetaa);
+}
+
+# newman projection
+# parameter: "newman", , iangle, startpos, bliste, radius
+sub newman_default_
+{
+ my ($iAnz, $iAngle, $p2, $iStart, $BT, $bAromat, $rRadius) = @_;
+ $$iAnz = 6;
+ $$iStart = $$p2 = 0;
+ $$iAngle = -60;
+ $$rRadius = $rLenN;
+ $$bAromat = $true;
+ @$BT = (9, 9, 9, 0, 0, 0);
+}
+
+sub newman_
+{
+ my ($XYstart, $rRadius, $rRadius_bak, $iAnz, $iAngle, $p2, $iStart,
+ $M, $rLena, $rThetaa, $XYa, $BLa, $t, $b, $r) = @_;
+
+ $$rRadius_bak = $$rRadius = abs($$rRadius);
+ my $rAngle;
+ if ($iStart<=2)
+ {
+ $rAngle = (90-120*$iStart+90)*$pi/180;
+ }
+ else
+ {
+ $rAngle = (90-120*($iStart-3)+$iAngle+90)*$pi/180;
+ }
+ $M->eq(- sin($rAngle)*$$rRadius, cos($rAngle)*$$rRadius);
+ $M->translate($XYstart);
+ my $i;
+ my $rTheta;
+ my $XY = new loc();
+ @$r = (90, -30, -150, 90+$iAngle, -30+$iAngle, -150+$iAngle);
+ @$t = (150, 30, -90, 150+$iAngle, 30+$iAngle, -90+$iAngle);
+ @$b = (30, -90, 150, 30+$iAngle, -90+$iAngle, 150+$iAngle);
+ for ($i=0; $i<=2; $i++)
+ {
+ $rLena->[$i] = $$rRadius;
+ $rThetaa->[$i] = 90-120*$i+180;
+ $rAngle = (90-120*$i+90)*$pi/180;
+ $XY->eq($M);
+ $XY->translate(sin($rAngle)*$$rRadius, -cos($rAngle)*$$rRadius);
+ $XYa->[$i] = $XY->new();
+ $BLa->[$i] = $i;
+ $rLena->[$i+3] = 0.5*$$rRadius;
+ $rThetaa->[$i+3] = 90-120*$i+180+$iAngle;
+ $rAngle = (90-120*$i+$iAngle+90)*$pi/180;
+ $XY->eq($M);
+ $XY->translate(sin($rAngle)*$$rRadius, -cos($rAngle)*$$rRadius);
+ $XYa->[$i+3] = $XY->new();
+ $BLa->[$i+3] = $i+3;
+ }
+ $$rRadius *= 0.5;
+}
+
+# cyclopentane similar to benzene, with flat top
+# parameter: "cpentane", n, iangle, startpos, bliste, radius
+sub cpentane_default_
+{
+ my ($iAnz, $p1, $iAngle, $iStart, $BT, $bAromat, $rRadius) = @_;
+ $$iAnz = 5;
+ $$iStart = $$p1 = 0;
+ $$iAngle = -90;
+ $$rRadius = $rLenN;
+ $$bAromat = $false; # can be changed to true by formula program
+ @$BT = (0, 0, 0, 0, 0);
+}
+
+sub cpentane_
+{
+ my ($XYstart, $rRadius, $rRadius_bak, $iAnz, $p1, $iAngle, $iStart,
+ $M, $rLena, $rThetaa, $XYa, $BLa, $t, $b, $r) = @_;
+
+ $$rRadius_bak = $$rRadius = abs($$rRadius);
+ $iStart++ if $iStart>2;
+ my $rAngle = (90-360/6*$iStart + $iAngle)*$pi/180;
+ $M->eq(- sin($rAngle)*$$rRadius, cos($rAngle)*$$rRadius);
+ $M->translate($XYstart);
+ my $rLen = 2 * $$rRadius * sin($pi/6);
+ my $rTheta = (-90-180/6) + $iAngle;
+ my $XY = new loc();
+ my ($i, $j);
+ for ($i = $j=0; $i<6; $i++)
+ {
+ if ($i==3)
+ {
+ $rTheta -= 360/6;
+ next;
+ }
+ $rLena->[$j] = ($i==2 ? 2*cos(30*$pi/180): 1) * $rLen;
+ $rTheta = $iAngle+90 if $i==2;
+ $rThetaa->[$j] = $rTheta;
+ $rTheta += 30 if ($i==2);
+ $rTheta -= 360/6;
+ $XY->eq($M);
+ $rAngle = (90-360/6*$i + $iAngle)*$pi/180;
+ $XY->translate(sin($rAngle)*$$rRadius, -cos($rAngle)*$$rRadius);
+ $XYa->[$j] = $XY->new();
+ $j++;
+ }
+ $M->translate(0, - sin(30*$pi/180)/3*$rLen);
+ $$rRadius *= 0.5; # ring size if someone wish it
+ @$BLa = (0, 1, 2, 3, 4);
+ @$r = (0, -60, -120, 120, 60);
+ @$t = (60, 0, -90, 180, 120);
+ @$b = (-60, -120, 180, 90, 0);
+ grep((($_ += $iAngle) && 0), @$b, @$r, @$t);
+}
+
+
+#////////////////////////////////////////////////////////
+#//
+#// ring([<cType>] [, [<startpos>] [, [<bliste>] [, [<radius>]
+#// [, [<p1>] [, [<p2>] ]]]]])
+#// {<pos>: fliste;
+#// vertex()...
+#// ...
+#// }
+#// vertex([<cType>] [, [<vertex1>] [, [<vertex2>] [, [<bliste>]
+#// [, [<p1>] ]]]])
+#// {<pos>: fliste;
+#// vertex()...
+#// ...
+#// }
+#//
+#// bliste := H | O | <n><bTyp> bliste
+#// <pos> := C, 0, 1, ..., Anz-1
+#//
+sub ring
+{
+ my $vertex = shift;
+
+ # if called by "vertex", get some information of base ring system
+ my $radius_ring1 = shift if $vertex;
+ my $rTheta_ring1 = shift if $vertex;
+ my $XYa_ring1 = shift if $vertex;
+ my $BLa_ring1 = shift if $vertex;
+ my $rLen_ring1 = shift if $vertex;
+
+ my ($XYg, $XYweiter, $BBoxg, $bFlag) = @_;
+ my $errn = 0;
+ $level++;
+
+&trace("ring", $bFlag);
+ # parse parameter list, defaults for benzene nucleus
+ my $cType = "ring";
+ my ($iAnz, $iAnztmp, $p1, $p2, $iStart, $bAromat, $rRadius, $rRadius_bak);
+ my (@XYa, @rLen, @rTheta, @BLa, @iBType, @ta, @ba, @ra);
+ my $tmp;
+ my $M = new loc();
+
+ $errn = $lberr, goto error if !$buf->NextToken("(");
+
+ # vertex? then some ring parameters can be calculated
+ if ($vertex)
+ {
+ $cType = $tmp if $buf->GetText($tmp);
+ $errn = $komma, goto error if !$buf->NextToken(",");
+ my $cCmd = "$cType".
+ '_default_(\$iAnz, \$p1, \$p2, \$iStart, \@iBType, '.
+ '\$bAromat, \$rRadius);';
+ eval($cCmd);
+ my ($iVertex1, $iVertex2) = (0,0);
+ $iVertex1 = $tmp if $buf->GetInt($tmp);
+ if ($buf->NextToken(","))
+ {
+ $iVertex2 = $tmp if $buf->GetInt($tmp);
+ if ($buf->NextToken(","))
+ {
+ if ($buf->NextToken("H"))
+ {
+ $bAromat = $false;
+ }
+ elsif ($buf->NextToken("O"))
+ {
+ $bAromat = $true;
+ }
+ my ($iN, $iTypeN);
+ while ($buf->GetInt($iN))
+ {
+ $errn = $bonderr, goto error
+ if !$buf->GetBondType($iTypeN);
+ $iBType[$iN] = $iTypeN;
+ }
+ if ($buf->NextToken(","))
+ {
+ $p1 = $tmp if $buf->GetInt($tmp);
+ }
+ }
+ }
+ # calculate parameters, use some information from base ring system
+ $rRadius = $radius_ring1;
+ $XYg->eq($$XYa_ring1[$$BLa_ring1[$iVertex1]]);
+ $iStart = ($iVertex2+1) % $iAnz;
+ $cCmd = "$cType".
+ '_($XYg, \$rRadius, \$rRadius_bak, \$iAnz, $p1, 0, $iStart,'.
+ '$M, \@rLen, \@rTheta, \@XYa, \@BLa, \@ta, \@ba, \@ra);';
+ eval($cCmd);
+ $rRadius = abs($rRadius_bak * ($$rLen_ring1[$iVertex1]/$rLen[$iVertex2]));
+ $p2 = $$rTheta_ring1[$iVertex1] - $rTheta[$iVertex2] + 180;
+ }
+ else
+ {
+ $cType = $tmp if $buf->GetText($tmp);
+ # construct call of specific structure default function
+ my $cCmd = "$cType".
+ '_default_(\$iAnz, \$p1, \$p2, \$iStart, \@iBType, '.
+ '\$bAromat, \$rRadius);';
+ eval($cCmd);
+ $errn = $typerr, goto error if $@;
+
+ if ($buf->NextToken(","))
+ {
+ $iStart = $tmp if $buf->GetInt($tmp);
+ if ($buf->NextToken(","))
+ {
+ if ($buf->NextToken("H"))
+ {
+ $bAromat = $false;
+ }
+ elsif ($buf->NextToken("O"))
+ {
+ $bAromat = $true;
+ }
+ my ($iN, $iTypeN);
+ while ($buf->GetInt($iN))
+ {
+ $errn = $bonderr, goto error
+ if !$buf->GetBondType($iTypeN);
+ $iBType[$iN] = $iTypeN;
+ }
+ if ($buf->NextToken(","))
+ {
+ my $rAbs = 1;
+ $rAbs = -1 if $buf->NextToken("#");
+ $rRadius = $tmp if $buf->GetBondLen($tmp);
+ $rRadius *= $rAbs;
+ if ($buf->NextToken(","))
+ {
+ $p1 = $tmp if $buf->GetInt($tmp);
+ if ($buf->NextToken(","))
+ {
+ # check for some special symbolic angles
+ if ($cType eq "ring" || $cType eq "cpentane")
+ {
+ if ($buf->GetInt($tmp))
+ {
+ $p2 = $tmp;
+ }
+ else
+ {
+ # construct call of specific structure function
+ # to get angles
+ $cCmd = "$cType".
+ '_($XYg, \$tmp, \$tmp, \$iAnz, $p1, 0, $iStart,'.
+ '$M, \@rLen, \@rTheta, \@XYa, \@BLa, \@ta, \@ba, \@ra);';
+ eval($cCmd);
+ if ($buf->NextToken("r"))
+ { $p2 = $iAngleBond + 180 - $ra[$iStart]; }
+ elsif ($buf->NextToken("t"))
+ { $p2 = $iAngleBond + 180 - $ta[$iStart]; }
+ elsif ($buf->NextToken("b"))
+ { $p2 = $iAngleBond + 180 - $ba[$iStart]; }
+ else
+ {
+ $errn = $badargerr, goto error;
+ }
+ }
+ }
+ else # otherwise, param must be integer
+ {
+ $p2 = $tmp if $buf->GetInt($tmp);
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ $errn = $rberr, goto error if !$buf->NextToken("){");
+
+ # now draw ring
+ # construct call of specific structure function
+ $cCmd = "$cType".
+ '_($XYg, \$rRadius, \$rRadius_bak, \$iAnz, $p1, $p2, $iStart,'.
+ '$M, \@rLen, \@rTheta, \@XYa, \@BLa, \@ta, \@ba, \@ra);';
+ eval($cCmd);
+ # insert missing bond types if p1 > iAnz (type "ring")
+ # and determine compound bounding box
+ my $i;
+ my $BBox = new bbox();
+ for ($i=0; $i<$iAnz; $i++)
+ {
+ $iBType[$i] = 0 if not defined $iBType[$i];
+ $BBox->MinMax($XYa[$i]);
+ }
+ $BBoxg->MinMax($BBox);
+
+ if ($bFlag)
+ {
+ my ($start, $bond) = (0,0);
+ foreach $start (@BLa)
+ {
+ print OUT $be->bond($XYa[$start]->{"x"}, $XYa[$start]->{"y"},
+ $rTheta[$bond]%360, $rLen[$bond], $iBType[$bond]);
+ $bond++;
+ }
+ print OUT $be->arc($M->{"x"}, $M->{"y"}, 0, 360, $rRadius)
+ if $bAromat; # draw aromatic ring symbol
+ }
+
+ # scan structures at ring atoms
+ my $XY = new loc();
+ while (!$buf->NextToken("}"))
+ {
+ if ($buf->NextToken("vertex"))
+ {
+ $XY->eq($XYg);
+ ring($true, $rRadius_bak, \@rTheta, \@XYa, \@BLa, \@rLen,
+ $XY, $XYweiter, $BBoxg, $bFlag);
+ $errn = $synterr, goto error if !$buf->NextToken(";");
+ }
+ else
+ {
+ if ($buf->NextToken("C"))
+ {
+ $XY->eq($M);
+ }
+ else
+ {
+ $errn = $interr, goto error if !$buf->GetInt($iN);
+ $errn = $badargerr, goto error if $iN>=$iAnz;
+ $XY->eq($XYa[$iN]);
+ # save globale ring-specific angles (top, bottom, radial)
+ $iAngleT = $ta[$iN];
+ $iAngleB = $ba[$iN];
+ $iAngleBond = $iAngleR = $ra[$iN];
+ $Theta = \@rTheta;
+ }
+ $errn = $colonerr, goto error if !$buf->NextToken(":");
+
+ $BBox->init($XY);
+ $errn = $synterr, goto error if !&fliste($XY, $BBox, $bFlag, ";");
+ $BBoxg->MinMax($BBox);
+ }
+ }
+
+ $XYweiter->eq($XYg);
+&trace("ring OK", $bFlag);
+ $level--;
+ return $true;
+
+error:
+ $level--;
+ &error($errn, "ring");
+ return $false;
+}
+
+
+#////////////////////////////////////////////////////////
+#//
+#// bond(<winkel> [, [<Typ>], [<Len>]])
+#// bond(#<n> [, [<Typ>]])
+#// bond([<winkel>] [+|-] r|b|t|v [/][t][+|- ...] [, [<Typ>], [<Len>]])
+#//
+sub bond
+{
+ my ($XYg, $XYweiter, $BBoxg, $bFlag) = @_;
+ my $errn = 0;
+ $level++;
+
+&trace("bond", $bFlag);
+ # parse parameter list, default is single bond, normal length
+ my ($iAngle, $rAngle);
+ $errn = $lberr, goto error if !$buf->NextToken("(");
+bond_start:
+ my ($iType, $rLen) = (0, $rLenN);
+ if ($buf->NextToken("#"))
+ {
+ my ($n, $tmp);
+ $errn = $interr, goto error if !$buf->GetInt($n);
+ if ($buf->NextToken(","))
+ {
+ $iType = $tmp if $buf->GetBondType($tmp);
+ }
+ $errn = $nexerr, goto error if !defined($posXY[$n]);
+ $iAngle = getangle($XYg, $posXY[$n]);
+ $rAngle = (90-$iAngle)*$pi/180;
+ $rLen = getlength($XYg, $posXY[$n]);
+ }
+ else
+ {
+ $iAngle = $buf->GetInt($tmp) ? $tmp : 0;
+ my ($term, $faktor) = (0,0);
+ if ($buf->NextToken("+"))
+ { $faktor = 1; }
+ elsif ($buf->NextToken("-"))
+ { $faktor = -1; }
+ # ring-specific global values? (top/bottom/radial angle)
+ if ($buf->NextToken("t"))
+ { $term = $iAngleT; }
+ elsif ($buf->NextToken("b"))
+ { $term = $iAngleB; }
+ elsif ($buf->NextToken("r"))
+ { $term = $iAngleR; }
+ elsif ($buf->NextToken("l"))
+ { $term = $iAngleBond; }
+ elsif ($buf->NextToken("v("))
+ {
+ my $tmp;
+ $errn = $interr, goto error if !$buf->GetInt($tmp);
+ $errn = $rberr, goto error if !$buf->NextToken(")");
+ $term = $Theta->[$tmp] % 360;
+ }
+ else
+ {
+ $term = 0;
+ }
+ $term += ((($term%360)/45)%2? 60 : -60) if $buf->NextToken("/");
+ $term -= ((($term%360)/45)%2? 60 : -60) if $buf->NextToken("\\");
+ $term -= ((($term%360)/45)%2? 60 : -60) if $buf->NextToken("t");
+ while ($buf->NextToken("+")) { $term += 60; }
+ while ($buf->NextToken("-")) { $term -= 60; }
+ $term = 180-$term if $buf->NextToken("|");
+ $iAngle += $term;
+ $iAngle += 180 if $faktor<0;
+ if ($buf->NextToken(","))
+ {
+ my $tmp;
+ $iType = $tmp if $buf->GetBondType($tmp);
+ if ($buf->NextToken(","))
+ {
+ $rLen = $tmp if $buf->GetBondLen($tmp);
+ }
+ }
+ $rAngle = (90-$iAngle) * $pi/180;
+ }
+
+ # OK, do the work!
+ $XYweiter->eq($XYg);
+ $XYweiter->translate(sin($rAngle)*$rLen, cos($rAngle)*$rLen);
+ $BBoxg->MinMax($XYg);
+ $BBoxg->MinMax($XYweiter);
+
+ if ($bFlag)
+ {
+ print OUT $be->bond($XYg->{"x"}, $XYg->{"y"},
+ $iAngle, $rLen, $iType);
+ }
+ $iAngleBond = $iAngle;
+
+ $XYg->eq($XYweiter), goto bond_start if $buf->NextToken(";");
+ $errn = $rberr, goto error if !$buf->NextToken(")");
+
+&trace("bond OK", $bFlag);
+ $level--;
+ return $true;
+
+error:
+ $level--;
+ &error($errn, "bond");
+ return $false;
+}
+
+
+#///////////////////////////////////
+# general function for text output
+sub atom_
+{
+ my ($cText, $iPos, $iPosCont, $bErase, $XYg, $XYweiter, $BBoxg,
+ $bFlag) = @_;
+
+ # read dimensions of text from dimension hash
+ my ($wd, $ht, $dp) = $texthash{$cText} =~ /^A:(.+)pt,(.+)pt,(.+)pt/;
+ my $TextBBox = new bbox(0,0, $wd, $ht);
+# 14.4.2001 IK - class type changed
+# my $Null = new bbox();
+ my $Null = new loc();
+ my $XY = new loc();
+
+ # bestimme Startpunkt, sodass BBox in Relation iPos zu XYg steht
+ $TextBBox->OrigConPoint($iPos, $XY, $Null);
+ # XY is no correct starting point, shift BBox
+ $XY->translate($XYg);
+ $TextBBox->translate($XY);
+ $TextBBox->ToConPoint($iPosCont, $XYweiter);
+ $XYg->eq($XY);
+ $TextBBox->{"yu"} -= $dp;
+ $BBoxg->MinMax($TextBBox);
+
+ if ($bFlag)
+ {
+ # erase background before writing text
+ print TMP $be->erase($XY->{"x"}, $XY->{"y"}-$dp, $wd, $ht+$dp) if $bErase;
+ print TMP $be->text($XY->{"x"}, $XY->{"y"}, $cText);
+ }
+}
+
+
+#////////////////////////////////////////////////////////
+#//
+#// atom(<Text> [, [<pos>][, [<contpos>] [, <erase>[]]]])
+#//
+sub atom
+{
+ my $errn = 0;
+ $level++;
+&trace("atom", $bFlag);
+
+ # parse parameter list
+ my $cText;
+ my ($iPos, $iPosCont, $bErase) = ($bbox::SB_C, $bbox::SB_C, 1);
+ my $tmp;
+ $errn = $lberr, goto error if !$buf->NextToken("(");
+ $errn = $texerr, goto error if !$buf->GetText($cText);
+ if ($buf->NextToken(","))
+ {
+ $iPos = $tmp if $buf->GetPos($tmp);
+ if ($buf->NextToken(","))
+ {
+ $iPosCont = $tmp if $buf->GetPos($tmp);
+ if ($buf->NextToken(","))
+ {
+ $bErase = $tmp if $buf->GetInt($tmp);
+ }
+ }
+ }
+ $errn = $rberr, goto error if !$buf->NextToken(")");
+ &atom_($cText, $iPos, $iPosCont, $bErase, @_);
+
+&trace("atom OK", $bFlag);
+ $level--;
+ return $true;
+
+error:
+ $level--;
+ &error($errn, "atom");
+ return $false;
+}
+
+
+#////////////////////////////////////////////////////////
+#//
+#// saveXY(#<n>) / restoreXY(#<n>)
+#//
+sub saveXY
+{
+ my ($XYstart) = @_;
+ my $errn = 0;
+ my $XY = new loc($XYstart);
+ $level++;
+
+ # parse parameter list
+ my $n;
+ $errn = $lberr, goto error if !$buf->NextToken("(#");
+ $errn = $interr, goto error if !$buf->GetInt($n);
+ if ($buf->NextToken(","))
+ {
+ my ($iAngle, $rLen);
+ $errn = $interr, goto error if !$buf->GetInt($iAngle);
+ $errn = $komma, goto error if !$buf->NextToken(",");
+ $errn = $lenerr, goto error if !$buf->GetBondLen($rLen);
+ $XY->translate(cos($iAngle*$pi/180)*$rLen, sin($iAngle*$pi/180)*$rLen);
+ }
+ $errn = $rberr, goto error if !$buf->NextToken(")");
+
+ $posXY[$n] = $XY->new();
+
+ $level--;
+ return $true;
+
+error:
+ $level--;
+ &error($errn, "saveXY");
+ return $false;
+}
+
+sub restoreXY
+{
+ my ($XYweiter) = @_;
+ my $errn = 0;
+ $level++;
+
+ # parse parameter list
+ my $n;
+ $errn = $lberr, goto error if !$buf->NextToken("(#");
+ $errn = $interr, goto error if !$buf->GetInt($n);
+ $errn = $rberr, goto error if !$buf->NextToken(")");
+
+ $XYweiter->eq($posXY[$n]);
+
+ $level--;
+ return $true;
+
+error:
+ $level--;
+ &error($errn, "restoreXY");
+ return $false;
+}
+
+
+#////////////////////////////////////////////////////////
+#//
+#// orbital([<iAngle>] [, [<rWeight>]])
+#//
+sub orbital
+{
+ my ($XYstart, $BBoxg, $bFlag) = @_;
+ my $errn = 0;
+ $level++;
+
+ # parse parameter list
+ my $tmp;
+ my ($iAngle, $iWeight) = (90, 1);
+ $errn = $lberr, goto error if !$buf->NextToken("(");
+ $iAngle = $tmp if $buf->GetInt($tmp);
+ if ($buf->NextToken(","))
+ {
+ $rWeight = $tmp if $buf->GetReal($tmp);
+ }
+ $errn = $rberr, goto error if !$buf->NextToken(")");
+ $rWeight *= 0.9*$rLenN;
+
+ my $XY = new loc($XYstart);
+ $XY->translate(cos($iAngle*$pi/180)*$rWeight, sin($iAngle*$pi/180)*$rWeight);
+ $BBoxg->MinMax($XY);
+ $XY->translate(cos(($iAngle+180)*$pi/180)*$rWeight, sin(($iAngle+180)*$pi/180)*$rWeight);
+ $BBoxg->MinMax($XY);
+
+ if ($bFlag)
+ {
+ print OUT $be->orbital($XYstart->{"x"}, $XYstart->{"y"},
+ $iAngle, $rWeight);
+ }
+
+ $level--;
+ return $true;
+
+error:
+ $level--;
+ &error($errn, "orbital");
+ return $false;
+}
+
+
+#////////////////////////////////////////////////////////
+#//
+#// fliste :== element fliste | <endtoken>
+#// element :== bond | atom | ring | branch | saveXY | restoreXY | orbital |
+#// save | restore | set
+#//
+sub fliste
+{
+ my ($XYg, $BBoxg, $bFlag, $EndToken) = @_;
+ my $XYStart = new loc($XYg);
+ my $XYweiter = new loc();
+
+fliste:
+ if ($buf->NextToken($EndToken))
+ {
+ return $true;
+ }
+ elsif ($buf->NextToken("bond"))
+ {
+ $XYStart->eq($XYweiter), goto fliste
+ if &bond($XYStart, $XYweiter, $BBoxg, $bFlag);
+ }
+ elsif ($buf->NextToken("atom"))
+ {
+ $XYStart->eq($XYweiter), goto fliste
+ if &atom($XYStart, $XYweiter, $BBoxg, $bFlag);
+ }
+ elsif ($buf->NextToken("ring"))
+ {
+ $XYStart->eq($XYweiter), goto fliste
+ if &ring($false, $XYStart, $XYweiter, $BBoxg, $bFlag);
+ }
+ elsif ($buf->NextToken("branch"))
+ {
+ $XYStart->eq($XYweiter), goto fliste
+ if &branch($XYStart, $XYweiter, $BBoxg, $bFlag);
+ }
+ elsif ($buf->NextToken("saveXY"))
+ {
+ goto fliste if &saveXY($XYStart);
+ }
+ elsif ($buf->NextToken("restoreXY"))
+ {
+ goto fliste if &restoreXY($XYStart);
+ }
+ elsif ($buf->NextToken("orbital"))
+ {
+ goto fliste if &orbital($XYStart, $BBoxg, $bFlag);
+ }
+ elsif ($buf->NextToken("save"))
+ {
+ goto fliste if &save();
+ }
+ elsif ($buf->NextToken("restore"))
+ {
+ goto fliste if &restore($bFlag);
+ }
+ elsif ($buf->NextToken("set"))
+ {
+ goto fliste if &set($bFlag);
+ }
+
+ return $false;
+}
+
+
+# helper function for spacing
+# &space_($iPosCont, $XYweiter)
+sub space_
+{
+ my ($iPos, $XYweiter) = @_;
+
+ SWITCH:
+ {
+ $XYweiter->translate(-$rXS,0), last SWITCH
+ if $iPos == $bbox::SB_L;
+ $XYweiter->translate(0,$rYS), last SWITCH
+ if $iPos == $bbox::SB_T;
+ $XYweiter->translate($rXS,0), last SWITCH
+ if $iPos == $bbox::SB_R;
+ $XYweiter->translate(0,-$rYS), last SWITCH
+ if $iPos == $bbox::SB_B;
+ $XYweiter->translate(-$rXS,$rYS), last SWITCH
+ if $iPos == $bbox::SB_TL;
+ $XYweiter->translate($rXS,$rYS), last SWITCH
+ if $iPos == $bbox::SB_TR;
+ $XYweiter->translate(-$rXS,-$rYS), last SWITCH
+ if $iPos == $bbox::SB_BL;
+ $XYweiter->translate($rXS,-$rYS), last SWITCH
+ if $iPos == $bbox::SB_BR;
+ }
+}
+
+
+#////////////////////////////////////////////////////////
+#//
+#// space([<pos>])
+#//
+sub space
+{
+ my ($XYg, $XYweiter, $BBoxg, $bFlag) = @_;
+ my $errn = 0;
+ $level++;
+
+ # parse parameter list
+ my $iPos = $bbox::SB_R;
+ my $tmp;
+
+ $errn = $lberr, goto error if !$buf->NextToken("(");
+ $iPos = $tmp if $buf->GetPos($tmp);
+ $errn = $rberr, goto error if !$buf->NextToken(")");
+
+ &space_($iPos, $XYweiter);
+
+ $level--;
+ return $true;
+
+error:
+ $level--;
+ &error($errn, "space");
+ return $false;
+}
+
+
+#////////////////////////////////////////////////////////
+#//
+#// gotoXY([<x>] [, [<y>]]) / shiftXY([<dx>] [, [<dy>]])
+#//
+sub gotoXY
+{
+ my ($XYstart, $XYweiter, $BBoxg, $bFlag) = @_;
+ my $errn = 0;
+ $level++;
+
+ # parse parameter list
+ my ($x, $y) = ($XYstart->{"x"}, $XYstart->{"y"});
+ my $tmp;
+
+ $errn = $lberr, goto error if !$buf->NextToken("(");
+ $x = $tmp if $buf->GetInt($tmp);
+ if ($buf->NextToken(","))
+ {
+ $y = $tmp if $buf->GetInt($tmp);
+ }
+ $errn = $rberr, goto error if !$buf->NextToken(")");
+
+ $XYweiter->eq($x, $y);
+ $BBoxg->MinMax($XYweiter);
+
+ $level--;
+ return $true;
+
+error:
+ $level--;
+ &error($errn, "gotoXY");
+ return $false;
+}
+
+sub shiftXY
+{
+ my ($XYstart, $XYweiter, $BBoxg, $bFlag) = @_;
+ my $errn = 0;
+ $level++;
+
+ # parse parameter list
+ my ($dx, $dy) = (0, 0);
+ my $tmp;
+
+ $errn = $lberr, goto error if !$buf->NextToken("(");
+ $dx = $tmp if $buf->GetInt($tmp);
+ if ($buf->NextToken(","))
+ {
+ $dy = $tmp if $buf->GetInt($tmp);
+ }
+ $errn = $rberr, goto error if !$buf->NextToken(")");
+
+ $XYweiter->eq($XYstart);
+ $XYweiter->translate($dx, $dy);
+ $BBoxg->MinMax($XYweiter);
+
+ $level--;
+ return $true;
+
+error:
+ $level--;
+ &error($errn, "shiftXY");
+ return $false;
+}
+
+
+#////////////////////////////////////////////////////////
+#//
+#// formula([<pos>] [, [<contpos>] [, <Name>, V|HA|HR, <dy>]]) :==
+#// fliste
+#//
+sub formula
+{
+ my ($XYstart, $XYweiter, $BBoxg, $bFlag,
+ $rTextSkip, $fbox, $context, $contextT) = @_;
+ my ($TM_NONE, $TM_V, $TM_HA, $TM_HR) = (0, 1, 2, 3);
+ my $errn = 0;
+ $level++;
+
+&trace("formula", $bFlag);
+ # parse parameter list
+ my ($iTextMode, $iDY, $tmp);
+ my ($iPos, $iPosCont) = ($bbox::SB_L, $bbox::SB_R);
+
+ # some default angles in case of pure aliphatic compounds
+ $iAngleT = 90;
+ $iAngleB = -90;
+ $iAngleBond = $iAngleR = 30;
+
+ $errn = $lberr, goto error if !$buf->NextToken("(");
+ $iPos = $tmp if $buf->GetPos($tmp);
+ if ($buf->NextToken(","))
+ {
+ $iPosCont = $tmp if $buf->GetPos($tmp);
+ $iTextMode = $TM_NONE;
+ if ($buf->NextToken(","))
+ {
+ $errn = $texerr, goto error if !$buf->GetText($cText);
+
+ # text size increase formula size due to user-given distance
+ # - but in multiline mode we have first to check for pure formula
+ # height, later give a calculated text distance. Therefore user
+ # must not give distance args!
+ if ($rTextSkip < 0)
+ {
+ $errn = $komma, goto error if !$buf->NextToken(",");
+ SW:
+ { $iTextMode = $TM_V, last SW if $buf->NextToken("V");
+ $iTextMode = $TM_HA, last SW if $buf->NextToken("HA");
+ $iTextMode = $TM_HR, last SW if $buf->NextToken("HR");
+ $errn = $synterr, goto error;
+ }
+ $errn = $komma, goto error if !$buf->NextToken(",");
+ $errn = $interr, goto error if !$buf->GetInt($iDY);
+ }
+ else
+ {
+ $iTextMode = $TM_HA;
+ $iDY = $rTextSkip;
+ }
+ }
+ }
+ $errn = $rberr, goto error if !$buf->NextToken("){");
+
+ my $XY = new loc();
+ my $BBox = new bbox();
+ my $Null = new loc();
+ my $TextXY = new loc();
+ my $fobjid = $objid+1;
+ $objid += 2;
+
+ if (!$bFlag)
+ # calculate unknown dimensions and then the resulting starting point
+ {
+ # calculate size in BBox, starting point is (0,0)
+ $errn = $synterr, goto error
+ if !&fliste($XY, $BBox, $false, "}");
+
+ $context->eq($BBox); # context without text
+ $contextT->eq($BBox); # text context is equal for textless formulas
+
+ if ($iTextMode != $TM_NONE)
+ {
+ $TextXY->{"x"} = ($BBox->{"xo"} + $BBox->{"xu"})/2;
+
+ $TextXY->{"y"} = $BBox->{"yu"} if $iTextMode == $TM_V;
+ $TextXY->{"y"} = ($BBox->{"yu"}+$BBox->{"yo"})/2
+ if $iTextMode == $TM_HA;
+ $TextXY->{"y"} = $BBox->{"yu"} if $iTextMode == $TM_HR;
+
+ $TextXY->{"y"} -= $iDY;
+
+ my $XYdummy = new loc();
+ my $Boxdummy = new bbox();
+ # increase formula dimension by text box dimension
+ $XYT = $TextXY->new();
+ &atom_($cText, $bbox::SB_B, $bbox::SB_B, $false, $TextXY,
+ $XYdummy, $Boxdummy, $bFlag);
+
+ $BBox->MinMax($Boxdummy->{"xu"}, $BBox->{"yu"});
+ $BBox->MinMax($Boxdummy->{"xo"}, $BBox->{"yu"});
+ if ($iPosCont == $bbox::SB_BL || $iPosCont == $bbox::SB_BR ||
+ $iPosCont == $bbox::SB_B)
+ {
+ $BBox->MinMax($BBox->{"xu"}, $TextXY->{"y"});
+ }
+ $contextT->eq($BBox); # context with text box
+ }
+
+ # bestimme Startpunkt, sodass BBox in Relation iPos zu XYg steht
+ $BBox->OrigConPoint($iPos, $XY, $Null);
+ # XY ist nun richtiger Startpunkt. Verschiebe BBox entsprechend
+ $BBox->translate($XY);
+ $BBox->translate($XYstart);
+ $XY->translate($XYstart);
+ $context->translate($XY);
+ $contextT->translate($XY);
+ if ($iTextMode != $TM_NONE)
+ {
+ $XYT->translate($XY);
+ $origin[$fobjid+1] = $XYT->new();
+ }
+
+ $BBox->ToConPoint($iPosCont, $XYweiter);# connection point is
+ # not influenced by text size
+ &space_($iPosCont, $XYweiter) if !$buf->NextToken("nospace");
+
+
+ # save size and position of object for later use in pass #2
+ $origin[$fobjid] = $XY->new();
+
+ $BBoxg->MinMax($BBox); # formula size
+ if ($iTextMode != $TM_NONE) # dto with text
+ {
+ $BBoxg->MinMax($XYT);
+ $contextT->MinMax($XYT); # added 1999-05-07 IK
+ push(@$fbox, $BBox->new());
+ }
+ }
+ else
+ # formula can be drawn
+ {
+ # get size of formula object
+ print OUT $be->comment("formula");
+ $XY = $origin[$fobjid];
+ $BBox->init($XY);
+
+ # draw at final position
+ &fliste($XY, $BBox, $bFlag, "}");
+ $buf->NextToken("nospace");
+
+ $context->eq($BBox); # context without text
+ $contextT->eq($BBox); # text context is equal for textless formulas
+
+ if ($iTextMode != $TM_NONE)
+ {
+ my $XYdummy = new loc();
+ my $Boxdummy = new bbox();
+ &atom_($cText, $bbox::SB_B, $bbox::SB_B, $true, $origin[$fobjid+1],
+ $XYdummy, $Boxdummy, $bFlag);
+ }
+ }
+
+
+&trace("formula OK", $bFlag);
+ $level--;
+ return $true;
+
+error:
+ $level--;
+ &error($errn, "formula");
+ return $false;
+}
+
+
+# helper function for arrow
+sub TranslatePos
+{
+ if ($_[0] eq "T")
+ {
+ $_[1] = $bbox::SB_BL if $_[1] == $bbox::SB_L;
+ $_[1] = $bbox::SB_B if $_[1] == $bbox::SB_C;
+ $_[1] = $bbox::SB_BR if $_[1] == $bbox::SB_R;
+ }
+ else
+ {
+ $_[1] = $bbox::SB_TL if $_[1] == $bbox::SB_L;
+ $_[1] = $bbox::SB_T if $_[1] == $bbox::SB_C;
+ $_[1] = $bbox::SB_TR if $_[1] == $bbox::SB_R;
+ }
+}
+
+
+#////////////////////////////////////////////////////////
+#//
+#// arrow([<Winkel>] [, [<Len_Extend>] [, [<Typ>]]])
+#// {text(T|B, <pos>){ sliste } ...
+#// }
+#//
+sub arrow
+{
+ my ($XYstart, $XYweiter, $BBoxg, $bFlag) = @_;
+ my $errn = 0;
+ $level++;
+
+&trace("arrow", $bFlag);
+ # parse parameter list
+ # default: 0 degree, ->
+ my ($iAngle, $iType, $iLen) = (0, 1, $rArrowExtend);
+ my $tmp;
+
+ $errn = $lberr, goto error if !$buf->NextToken("(");
+ $iAngle = ($tmp%360) if $buf->GetInt($tmp);
+ if ($buf->NextToken(","))
+ {
+ $iLen = $tmp if $buf->GetInt($tmp);
+ if ($buf->NextToken(","))
+ {
+ $iType = $tmp if $buf->GetArrowType($tmp);
+ }
+ }
+ $errn = $rberr, goto error if !$buf->NextToken("){");
+
+ my $iBreite = 0;
+ my $XY = new loc();
+ my $XY1 = new loc();
+ my $XY2 = new loc();
+ my $BBox = new bbox();
+# 15.4.2001 IK bug fixed
+# my $Null = new bbox();
+ my $Null = new loc();
+ my $BBox1 = new bbox();
+ my $BBox2 = new bbox();
+ my ($iPos1, $iPos2, $iPos) = (-1, -1, 0);
+
+ my $tmpObjID = $objid+1;
+ $objid += 4;
+ my ($objID1, $objID2, $Ptr1, $Ptr2);
+
+ if (!$bFlag)
+ # bestimme Ausdehnungen der beiden Beschriftungen
+ {
+ my $iHPos;
+ while (!$buf->NextToken("}"))
+ {
+ $errn = $synterr, goto error if !$buf->NextToken("text");
+ $errn = $lberr, goto error if !$buf->NextToken("(");
+ $errn = $poserr, goto error if !$buf->GetPos($iHPos);
+ $errn = $poserr, goto error
+ if ($iHPos != $bbox::SB_T && $iHPos != $bbox::SB_B);
+ $errn = $komma, goto error if !$buf->NextToken(",");
+ $errn = $poserr, goto error if !$buf->GetPos($iPos);
+ $errn = $poserr, goto error
+ if ($iPos != $bbox::SB_L && $iPos != $bbox::SB_C && $iPos != $bbox::SB_R);
+ $errn = $rberr, goto error if !$buf->NextToken("){");
+ $BBox->init(0,0);
+ $XY->eq(0,0);
+ my $Ptr = $buf->GetPtr();
+ my $objIDtmp = $objid;
+ $errn = $synterr, goto error
+ if !&sliste($XY, $BBox, $false, -1, 0, "}");
+ if ($iHPos==$bbox::SB_T)
+ {
+ $BBox1->eq($BBox);
+ $objID1 = $objIDtmp;
+ $iPos1 = $iPos;
+ $Ptr1 = $Ptr;
+ }
+ else
+ {
+ $BBox2->eq($BBox);
+ $iPos2 = $iPos;
+ $objID2 = $objIDtmp;
+ $Ptr2 = $Ptr;
+ }
+ }
+
+ # position marker inconsistent ?
+ $errn = $incargerr, goto error if
+ ($iPos1 != -1 && $iPos2 != -1 && $iPos1 != $iPos2);
+ # arrow length is max(Breite1, Breite2) + 2*arrow_extend
+ if ($iAngle<45 || $iAngle >=315 || ($iAngle >=135 && $iAngle <225))
+ {
+ $iBreite = &max($BBox1->width(), $BBox2->width());
+ }
+ else
+ {
+ $iBreite = &max($BBox1->height(), $BBox2->height());
+ }
+ $iBreite += 2*$iLen;
+
+ my $XYref = new loc();
+ my $iAngleBM = (90-$iAngle)*$pi/180;
+ my ($ax, $ay) = ($iBreite*sin($iAngleBM), $iBreite*cos($iAngleBM));
+ my ($px, $py) = ($ay/$iBreite, -$ax/$iBreite);
+
+ if ($iPos1 != -1)
+ {
+ &TranslatePos("T", $iPos1);
+ if ($iAngle==0)
+ {
+ $XYref->eq($iLen, $rArrowSkip)
+ if $iPos1 == $bbox::SB_BL;
+ $XYref->eq($iBreite/2, $rArrowSkip)
+ if $iPos1 == $bbox::SB_B;
+ $XYref->eq($iBreite-$iLen, $rArrowSkip)
+ if $iPos1 == $bbox::SB_BR;
+ }
+ elsif ($iAngle==180)
+ {
+ $XYref->eq(-$iLen, $rArrowSkip)
+ if $iPos1 == $bbox::SB_BR;
+ $XYref->eq(-$iBreite/2, $rArrowSkip)
+ if $iPos1 == $bbox::SB_B;
+ $XYref->eq(-$iBreite+$iLen, $rArrowSkip)
+ if $iPos1 == $bbox::SB_BL;
+ }
+ elsif ($iAngle==90)
+ {
+ $XYref->eq(-$rArrowSkip, $iBreite-$iLen), $iPos1 = $bbox::SB_TR
+ if $iPos1 == $bbox::SB_BL;
+ $XYref->eq(-$rArrowSkip, $iBreite/2), $iPos1 = $bbox::SB_R
+ if $iPos1 == $bbox::SB_B;
+ $XYref->eq(-$rArrowSkip, $iLen), $iPos1 = $bbox::SB_TR
+ if $iPos1 == $bbox::SB_BR;
+ }
+ elsif ($iAngle==270)
+ {
+ $XYref->eq(-$rArrowSkip, -$iLen), $iPos1 = $bbox::SB_TR
+ if $iPos1 == $bbox::SB_BL;
+ $XYref->eq(-$rArrowSkip, -$iBreite/2), $iPos1 = $bbox::SB_R
+ if $iPos1 == $bbox::SB_B;
+ $XYref->eq(-$rArrowSkip, -$iBreite+$iLen), $iPos1 = $bbox::SB_BR
+ if $iPos1 == $bbox::SB_BR;
+ }
+ else
+ {
+ $XYref->eq(0.5*$ax-$rArrowSkip*$px, 0.5*$ay-$rArrowSkip*$py);
+ SW: {
+ $iPos1 = $bbox::SB_BR, last SW if $iAngle<90;
+ $iPos1 = $bbox::SB_TR, last SW if $iAngle<180;
+ $iPos1 = $bbox::SB_TL, last SW if $iAngle<270;
+ $iPos1 = $bbox::SB_BL, last SW;
+ }
+ }
+ $BBox1->OrigConPoint($iPos1, $XY1, $Null);
+ $BBox1->translate($XY1);
+ $BBox1->translate($XYstart);
+ $BBox1->translate($XYref);
+ $XY1->translate($XYstart);
+ $XY1->translate($XYref);
+ $BBoxg->MinMax($BBox1);
+ $objid = $objID1;
+ $buf->SetPtr($Ptr1);
+ &sliste($XY1, $BBox, $false, -1, 0, "}");
+ }
+ if ($iPos2 != -1)
+ {
+ &TranslatePos("B", $iPos2);
+ if ($iAngle==0)
+ {
+ $XYref->eq($iLen, -$rArrowSkip)
+ if $iPos2 == $bbox::SB_TL;
+ $XYref->eq($iBreite/2, -$rArrowSkip)
+ if $iPos2 == $bbox::SB_T;
+ $XYref->eq($iBreite-$iLen, -$rArrowSkip)
+ if $iPos2 == $bbox::SB_TR;
+ }
+ elsif ($iAngle==180)
+ {
+ $XYref->eq(-$iLen, -$rArrowSkip)
+ if $iPos2 == $bbox::SB_TR;
+ $XYref->eq(-$iBreite/2, -$rArrowSkip)
+ if $iPos2 == $bbox::SB_T;
+ $XYref->eq(-$iBreite+$iLen, -$rArrowSkip)
+ if $iPos2 == $bbox::SB_TL;
+ }
+ elsif ($iAngle==90)
+ {
+ $XYref->eq($rArrowSkip, $iLen), $iPos2 = $bbox::SB_BL
+ if $iPos2 == $bbox::SB_TL;
+ $XYref->eq($rArrowSkip, $iBreite-$iLen), $iPos2 = $bbox::SB_TL
+ if $iPos2 == $bbox::SB_TR;
+ $XYref->eq($rArrowSkip, $iBreite/2), $iPos2 = $bbox::SB_L
+ if $iPos2 == $bbox::SB_T;
+ }
+ elsif ($iAngle==270)
+ {
+ $XYref->eq($rArrowSkip, -$iLen), $iPos2 = $bbox::SB_TL
+ if $iPos2 == $bbox::SB_TL;
+ $XYref->eq($rArrowSkip, -$iBreite+$iLen), $iPos2 = $bbox::SB_BL
+ if $iPos2 == $bbox::SB_TR;
+ $XYref->eq($rArrowSkip, -$iBreite/2), $iPos2 = $bbox::SB_L
+ if $iPos2 == $bbox::SB_T;
+ }
+ else
+ {
+ $XYref->eq(0.5*$ax+$rArrowSkip*$px, 0.5*$ay+$rArrowSkip*$py);
+ SW1: {
+ $iPos2 = $bbox::SB_TL, last SW1 if $iAngle<90;
+ $iPos2 = $bbox::SB_BL, last SW1 if $iAngle<180;
+ $iPos2 = $bbox::SB_BR, last SW1 if $iAngle<270;
+ $iPos2 = $bbox::SB_TR, last SW1;
+ }
+ }
+ $BBox2->OrigConPoint($iPos2, $XY2, $Null);
+ $BBox2->translate($XY2);
+ $BBox2->translate($XYstart);
+ $BBox2->translate($XYref);
+ $XY2->translate($XYstart);
+ $XY2->translate($XYref);
+ $BBoxg->MinMax($BBox2);
+ $objid = $objID2;
+ $buf->SetPtr($Ptr2);
+ &sliste($XY2, $BBox, $false, -1, 0, "}");
+ }
+ $buf->NextToken("}");
+
+ # save corrected origins of objects
+ $origin[$tmpObjID] = $XY1->new();
+ $origin[$tmpObjID+1] = $XY2->new();
+ $origin[$tmpObjID+2] = $iBreite;
+
+ # starting point remains at XYstart, ending point is shifted by
+ # the arrow-vector
+ $origin[$tmpObjID+3] = $XYstart->new();
+ $XYweiter->eq($XYstart);
+ $XYweiter->translate($ax, $ay);
+ $BBoxg->MinMax($XYweiter);
+
+ my $iPosCont = $bbox::SB_C;
+ SWITCH:
+ {
+ $iPosCont = $bbox::SB_R, last SWITCH if $iAngle<=22.5 || $iAngle>337.5;
+ $iPosCont = $bbox::SB_TR, last SWITCH if $iAngle<=67.5;
+ $iPosCont = $bbox::SB_T, last SWITCH if $iAngle<=112.5;
+ $iPosCont = $bbox::SB_TL, last SWITCH if $iAngle<=157.5;
+ $iPosCont = $bbox::SB_L, last SWITCH if $iAngle<=202.5;
+ $iPosCont = $bbox::SB_BL, last SWITCH if $iAngle<=247.5;
+ $iPosCont = $bbox::SB_B, last SWITCH if $iAngle<292.5;
+ $iPosCont = $bbox::SB_BR, last SWITCH if $iAngle<=337.5;
+ }
+ &space_($iPosCont, $XYweiter) if !$buf->NextToken("nospace");
+
+ }
+ else
+ # setze im zweiten Lauf alles anhand der bekannten Ma"se zusammen
+ {
+ print OUT $be->comment("arrow");
+ $XY1 = $origin[$tmpObjID];
+ $XY2 = $origin[$tmpObjID+1];
+ $iBreite = $origin[$tmpObjID+2];
+ $XYstart = $origin[$tmpObjID+3];
+ print OUT $be->arrow($XYstart->{"x"}, $XYstart->{"y"},
+ $iAngle, $iBreite, $iType);
+ while (!$buf->NextToken("}"))
+ {
+ $buf->NextToken("text");
+ $buf->NextToken("(");
+ $buf->GetPos($iHPos);
+ $buf->NextToken(",");
+ $buf->GetPos($iPos);
+ $buf->NextToken("){");
+ if ($iHPos==$bbox::SB_T)
+ {
+ print OUT $be->comment("arrow text T");
+ &sliste($XY1, $BBox1, $true, -1, 0, "}");
+ }
+ else
+ {
+ print OUT $be->comment("arrow text B");
+ &sliste($XY2, $BBox2, $true, -1, 0, "}");
+ }
+ }
+ $buf->NextToken("nospace");
+ }
+
+
+&trace("arrow OK", $bFlag);
+ $level--;
+ return $true;
+
+error:
+ $level--;
+ &error($errn, "arrow");
+ return $false;
+}
+
+
+#////////////////////////////////////////////////////////
+#//
+#// joinh(<n>, [<iPosInner>] [, [<iPos>] [, [<Len_Extend>]])
+#// {[nospace] sliste;
+#// ...
+#// }
+#//
+sub joinh
+{
+ my ($XYstart, $XYweiter, $BBoxg, $bFlag) = @_;
+ my $errn = 0;
+ $level++;
+
+&trace("joinh", $bFlag);
+ # parse parameter list
+ my ($iAnz, $iLen, $iPos, $iPosInner, $tmp);
+ $iLen = $rArrowExtend;
+ $iPosInner = $bbox::SB_L; # default: left aligned
+ $iPos = $bbox::SB_BL;
+
+ $errn = $lberr, goto error if !$buf->NextToken("(");
+ $errn = $interr, goto error if !$buf->GetInt($iAnz);
+ $errn = $komma, goto error if !$buf->NextToken(",");
+ $iPosInner = $tmp if $buf->GetPos($tmp);
+ $errn = $badargerr, goto error if ($iPosInner != $bbox::SB_L &&
+ $iPosInner != $bbox::SB_C && $iPosInner != $bbox::SB_R);
+ if ($buf->NextToken(","))
+ {
+ $iPos = $tmp if $buf->GetPos($tmp);
+ if ($buf->NextToken(","))
+ {
+ $iLen = $tmp if $buf->GetInt($tmp);
+ }
+ }
+ $errn = $rberr, goto error if !$buf->NextToken("){");
+
+ my $XY = new loc();
+ my $XYs = new loc();
+ my $Null = new loc();
+ my $BBox = new bbox();
+ my $tmpBBox = new bbox();
+ my $tmpObjID = $objid+1; # space for two entries in @size
+ $objid += 3*$iAnz+2;
+ my (@Ptr, @ObjID, @myBBox, @rRatio, @iY, @fBBox);
+
+ if (!$bFlag)
+ # determine dimensions of chains
+ {
+ my ($i, $iBreite, $iHoehe, $v) = (0, 0, 0, 0);
+ @rRatio = ();
+ while (!$buf->NextToken("}"))
+ {
+ $i++;
+ $XY->eq(0,0);
+ $tmpBBox->init(0,0);
+ push(@Ptr, $buf->GetPtr());
+ push(@ObjID, $objid);
+ @fBBox = ();
+ $errn = $synterr, goto error
+ if !&sliste($XY, $tmpBBox, $false, 0, \@fBBox, ";");
+ # save size of chain
+ push(@myBBox, $tmpBBox->new());
+ $iBreite = &max($iBreite, $tmpBBox->width());
+ $iHoehe += $tmpBBox->height();
+ $iHoehe += $rChainSep if $i>1;
+ my $iHMax = 0;
+ grep(($iHMax = &max($iHMax, $_->height())) && 0, @fBBox);
+ push(@iY, $iHMax);
+ push(@rRatio, $v = ($XY->{"y"}-$tmpBBox->{"yu"})/$tmpBBox->height());
+ # increase by text height if any
+ $iHoehe += $rTextSep +$iHMax/2 - $tmpBBox->height()*$v
+ if $iHMax>0 && ($rTextSep+$iHMax/2>$tmpBBox->height()*$v);
+ }
+ $iBreite += $iLen;
+
+ # given number of chains != actual number
+ $errn = $incargerr, goto error if $i != $iAnz;
+
+ $BBox->init(0,0);
+ $BBox->MinMax($iBreite, $iHoehe);
+ $BBox->OrigConPoint($iPos, $XY, $Null);
+ # XY ist nun richtiger Startpunkt. Verschiebe BBox entsprechend
+ $BBox->translate($XY);
+ $BBox->translate($XYstart);
+ $BBoxg->MinMax($BBox);
+ $origin[$tmpObjID+1] = $BBox->{"xo"};
+ $BBox->ToConPoint($bbox::SB_R, $XYweiter); # y-value will be modified some
+ # lines later
+
+ # construct chains, dimensions are now known
+ my $iH = $iHoehe;
+ SW1:
+ {
+ $iPosInner = $bbox::SB_TL, last SW1 if $iPosInner == $bbox::SB_L;
+ $iPosInner = $bbox::SB_T, last SW1 if $iPosInner == $bbox::SB_C;
+ $iPosInner = $bbox::SB_TR, last SW1 if $iPosInner == $bbox::SB_R;
+ }
+ for ($i=0; $i<$iAnz; $i++)
+ {
+ $buf->SetPtr(shift(@Ptr));
+ $objid = shift(@ObjID);
+ $BBox = shift(@myBBox);
+ my $iYY = shift(@iY);
+ my $iDY = $rTextSep + $iYY/2;
+ my $rBoxHeight = $BBox->height();
+ my $XYref = new loc($XYstart);
+ $XYref->translate($XY);
+ SW:
+ {
+ $XYref->translate(0,$iH), last SW if $iPosInner == $bbox::SB_TL;
+ $XYref->translate(($iBreite-$iLen)/2,$iH) if $iPosInner == $bbox::SB_T;
+ $XYref->translate($iBreite-$iLen,$iH) if $iPosInner == $bbox::SB_TR;
+ }
+ $BBox->OrigConPoint($iPosInner, $XYs, $Null);
+ $XYs->translate($XYref);
+ $BBox->init($XYs);
+ $origin[$tmpObjID+2+$i] = $XYs->new();
+ &sliste($XYs, $BBox, $false, $iDY, \@fBBox, ";");
+ $v = shift(@rRatio);
+ $BBox->{"yu"} += $rTextSep + $iYY/2 - $rBoxHeight*$v
+ if $iYY>0 && ($rTextSep+$iYY > $rBoxHeight*$v);
+ $box[$tmpObjID+2+$i] = $BBox->new();
+ $origin[$tmpObjID+2+$i+$iAnz] = $XYs->new();
+ $iH -= $rChainSep + $BBox->height();
+ $iH -= $rTextSep + $iYY/2 - $rBoxHeight*$v
+ if $iYY>0 && ($rTextSep+$iYY > $rBoxHeight*$v);
+ }
+
+ $XYweiter->{"y"} = ($origin[$tmpObjID+2+$iAnz]->{"y"}+
+ $origin[$tmpObjID+2+2*$iAnz-1]->{"y"})/2;
+ $origin[$tmpObjID] = $XYweiter->{"y"};
+ for ($i=0; $i<$iAnz; $i++)
+ {
+ $origin[$tmpObjID+2+$i+2*$iAnz] =
+ $origin[$tmpObjID+2+$i+$iAnz]->{"y"}-$XYweiter->{"y"};
+ }
+ $buf->NextToken("}");
+ }
+ else
+ # draw chains on known origins
+ {
+ print OUT $be->comment("joinh");
+ my $iLineheight = $origin[$tmpObjID];
+ my $XO = $origin[$tmpObjID+1];
+ my $XYw = new loc();
+ my ($iLen, $i) = (0, 0);
+ while (!$buf->NextToken("}"))
+ {
+ $i++;
+ $XYs = $origin[$tmpObjID+1+$i];
+ $XYw = $origin[$tmpObjID+1+$i+$iAnz];
+ $iLen = $origin[$tmpObjID+1+$i+2*$iAnz];
+ &sliste($XYs, $BBox, $true, 0, 0, ";");
+ $BBox = $box[$tmpObjID+1+$i];
+ print OUT $be->comment(sprintf "chain %d", $i);
+ print OUT $be->arrow($XYw->{"x"}, $XYw->{"y"},
+ 0, $XO-$XYw->{"x"}, 0, sprintf "joinh BOND %d", $i);
+ print OUT $be->arrow($XO, $XYw->{"y"}, $iLen>0 ? -90 : 90,
+ abs($iLen), 0, sprintf "joinh BOND %d", $i);
+ }
+ }
+
+&trace("joinh OK", $bFlag);
+ $level--;
+ return $true;
+
+error:
+ $level--;
+ &error($errn, "joinh");
+ return $false;
+}
+
+
+#////////////////////////////////////////////////////////
+#//
+#// joinv(<n>, [<iPosInner>] [, [<iPos>] [, [<Len_Extend>]])
+#// {sliste;
+#// ...
+#// }
+#//
+sub joinv
+{
+ my ($XYstart, $XYweiter, $BBoxg, $bFlag) = @_;
+ my $errn = 0;
+ $level++;
+
+&trace("joinv", $bFlag);
+ # parse parameter list
+ my ($iAnz, $iLen, $iPos, $iPosInner, $tmp);
+ $iLen = $rArrowExtend;
+ $iPosInner = $bbox::SB_T; # default: top aligned
+ $iPos = $bbox::SB_BL;
+
+ $errn = $lberr, goto error if !$buf->NextToken("(");
+ $errn = $interr, goto error if !$buf->GetInt($iAnz);
+ $errn = $komma, goto error if !$buf->NextToken(",");
+ $iPosInner = $tmp if $buf->GetPos($tmp);
+ $errn = $badargerr, goto error if ($iPosInner != $bbox::SB_T &&
+ $iPosInner != $bbox::SB_C && $iPosInner != $bbox::SB_B);
+ if ($buf->NextToken(","))
+ {
+ $iPos = $tmp if $buf->GetPos($tmp);
+ if ($buf->NextToken(","))
+ {
+ $iLen = $tmp if $buf->GetInt($tmp);
+ }
+ }
+ $errn = $rberr, goto error if !$buf->NextToken("){");
+
+ my $XY = new loc();
+ my $XYs = new loc();
+ my $Null = new loc();
+ my $BBox = new bbox();
+ my $tmpBBox = new bbox();
+ my $tmpObjID = $objid+1; # space for two entries in @size
+ $objid += 2*$iAnz+2;
+ my (@Ptr, @ObjID, @myBBox);
+
+ if (!$bFlag)
+ # determine dimensions of chains
+ {
+ my ($i, $iBreite, $iHoehe) = (0, 0, 0);
+ while (!$buf->NextToken("}"))
+ {
+ $i++;
+ $XY->eq(0,0);
+ $tmpBBox->init(0,0);
+ push(@Ptr, $buf->GetPtr());
+ push(@ObjID, $objid);
+ $errn = $synterr, goto error
+ if !&sliste($XY, $tmpBBox, $false, -1, 0, ";");
+ # save size of chain
+ push(@myBBox, $tmpBBox->new());
+ $iHoehe = &max($iHoehe, $tmpBBox->height());
+ $iBreite += $tmpBBox->width();
+ $iBreite += $rChainSep if $i>1;
+ }
+ $iHoehe += $iLen;
+
+ # given number of chains != actual number
+ $errn = $incargerr, goto error if $i != $iAnz;
+
+ $BBox->init(0,0);
+ $BBox->MinMax($iBreite, $iHoehe);
+ $BBox->OrigConPoint($iPos, $XY, $Null);
+ # XY ist nun richtiger Startpunkt. Verschiebe BBox entsprechend
+ $BBox->translate($XY);
+ $BBox->translate($XYstart);
+ $BBoxg->MinMax($BBox);
+
+ $BBox->ToConPoint($bbox::SB_B, $XYweiter); # x-value will be modified some
+ # lines later
+ $origin[$tmpObjID+1] = $XYweiter->new();
+ # construct chains, dimensions are now known
+ my $iB = 0;
+ SW1:
+ {
+ $iPosInner = $bbox::SB_TL, last SW1 if $iPosInner == $bbox::SB_T;
+ $iPosInner = $bbox::SB_L, last SW1 if $iPosInner == $bbox::SB_C;
+ $iPosInner = $bbox::SB_BL, last SW1 if $iPosInner == $bbox::SB_B;
+ }
+ for ($i=0; $i<$iAnz; $i++)
+ {
+ $buf->SetPtr(shift(@Ptr));
+ $objid = shift(@ObjID);
+ $BBox = shift(@myBBox);
+ my $XYref = new loc($XYstart);
+ $XYref->translate($XY);
+ SW:
+ {
+ $XYref->translate($iB,$iHoehe), last SW if $iPosInner == $bbox::SB_TL;
+ $XYref->translate($iB, ($iHoehe-$iLen)/2+$iLen) if $iPosInner == $bbox::SB_L;
+ $XYref->translate($iB, $iLen) if $iPosInner == $bbox::SB_BL;
+ }
+ $BBox->OrigConPoint($iPosInner, $XYs, $Null);
+ $XYs->translate($XYref);
+ $BBox->init($XYs);
+ $origin[$tmpObjID+2+$i] = $XYs->new();
+ &sliste($XYs, $BBox, $false, -1, 0, ";");
+ $box[$tmpObjID+2+$i] = $BBox->new();
+ $origin[$tmpObjID+2+$i+$iAnz] = $XYs->new();
+ $iB += $rChainSep + $BBox->width();
+ }
+
+ $XYweiter->{"x"} = ($origin[$tmpObjID+2+$iAnz]->{"x"}+
+ $origin[$tmpObjID+2+2*$iAnz-1]->{"x"})/2;
+ $origin[$tmpObjID] = $XYweiter->{"x"};
+ $buf->NextToken("}");
+ }
+ else
+ # draw chains on known origins
+ {
+ print OUT $be->comment("joinv");
+ my $iLinewidth = $origin[$tmpObjID];
+ my $YU = $origin[$tmpObjID+1]->{"y"};
+ my $XYw = new loc();
+ my $i = 0;
+ while (!$buf->NextToken("}"))
+ {
+ $i++;
+ $XYs = $origin[$tmpObjID+1+$i];
+ $XYw = $origin[$tmpObjID+1+$i+$iAnz];
+ &sliste($XYs, $BBox, $true, -1, 0, ";");
+ $BBox = $box[$tmpObjID+1+$i];
+ my $y = $XYw->{"y"};
+ print OUT $be->comment(sprintf "chain %d", $i);
+ print OUT $be->arrow($XYw->{"x"}, $XYw->{"y"},
+ -90, $XYw->{"y"}-$YU, 0,
+ sprintf "joinv BOND %d", $i);
+ print OUT $be->arrow($XYw->{"x"}, $YU,
+ $XYw->{"x"} > $iLinewidth ? 180 : 0,
+ abs($XYw->{"x"} - $iLinewidth), 0, sprintf "joinv BOND %d", $i);
+ }
+ }
+
+&trace("joinv OK", $bFlag);
+ $level--;
+ return $true;
+
+error:
+ $level--;
+ &error($errn, "joinv");
+ return $false;
+}
+
+
+#////////////////////////////////////////////////////////
+#//
+#// multiline(<n> [, [<iInnerPos>] [, [<iPos>] [, [<iPosCont>]]]])
+#// {sliste;
+#// ...
+#// }
+#//
+sub multiline
+{
+ my ($XYstart, $XYweiter, $BBoxg, $bFlag, $context, $contextT) = @_;
+ my $errn = 0;
+ $level++;
+
+&trace("multiline", $bFlag);
+ # parse parameter list
+ my $iAnz;
+ my ($iPosInner, $iPos, $iPosCont) = ($bbox::SB_L, $bbox::SB_L, $bbox::SB_R);
+ my $tmp;
+ $errn = $lberr, goto error if !$buf->NextToken("(");
+ $errn = $interr, goto error if !$buf->GetInt($iAnz);
+ if ($buf->NextToken(","))
+ {
+ $iPosInner = $tmp if $buf->GetPos($tmp);
+ $errn = $badargerr, goto error if ($iPosInner != $bbox::SB_L &&
+ $iPosInner != $bbox::SB_C && $iPosInner != $bbox::SB_R);
+ if ($buf->NextToken(","))
+ {
+ $iPos = $tmp if $buf->GetPos($tmp);
+ if ($buf->NextToken(","))
+ {
+ $iPosCont = $tmp if $buf->GetPos($tmp);
+ }
+ }
+ }
+ $errn = $rberr, goto error if !$buf->NextToken("){");
+
+ my $XY = new loc();
+ my $XYref = new loc();
+ my $Null = new loc();
+ my $BBox = new bbox();
+ my $tmpObjID = $objid+1; # space for two entries in @size
+ $objid += $iAnz;
+ my (@iY, @myBBox, @fBBox, @rRatio, @Ptr, @ObjID);
+
+ if (!$bFlag)
+ # determine dimensions of lines
+ {
+ my ($i, $iBreite, $iHoehe, $v) = (0, 0, 0, 0);
+ @rRatio = ();
+ while (!$buf->NextToken("}"))
+ {
+ $i++;
+ $XY->eq(0,0);
+ $BBox->init(0,0);
+ push(@Ptr, $buf->GetPtr());
+ push(@ObjID, $objid);
+ @fBBox = ();
+ # test formula without text if any -> pure height of formulas
+ $errn = $synterr, goto error
+ if !&sliste($XY, $BBox, $false, 0, \@fBBox, ";");
+ # save size of chain
+ push(@myBBox, $BBox->new());
+ $iBreite = &max($iBreite, $BBox->width());
+ $iHoehe += $BBox->height();
+ my $iHMax = 0;
+ grep(($iHMax = &max($iHMax, $_->height())) && 0, @fBBox);
+ push(@iY, $iHMax);
+ # increase by text height if any
+ push(@rRatio, $v = ($XY->{"y"}-$BBox->{"yu"})/$BBox->height());
+ $iHoehe += $rTextSep+$iHMax/2 - $BBox->height()*$v
+ if $iHMax>0 && ( $rTextSep+$iHMax/2 > $BBox->height()*$v);
+ $iHoehe += $rMultilineSep if $i>1;
+ }
+ # given number of chains != actual number
+ $errn = $incargerr, goto error if $i != $iAnz;
+
+ $BBox->init(0,0);
+ $BBox->MinMax($iBreite, $iHoehe);
+ $BBox->OrigConPoint($iPos, $XY, $Null);
+ # XY ist nun richtiger Startpunkt. Verschiebe BBox entsprechend
+ $BBox->translate($XY);
+ $BBox->translate($XYstart);
+ $BBoxg->MinMax($BBox);
+ $context->eq($BBox);
+ $contextT->eq($BBox);
+
+ $BBox->ToConPoint($iPosCont, $XYweiter);
+ &space_($iPosCont, $XYweiter) if !$buf->NextToken("nospace");
+
+ my $XYorig = new loc($BBox->{"xu"}, $BBox->{"yu"});
+ # construct lines, dimensions are now known
+ my $XYs = new loc();
+ my $iH = $iHoehe;
+ for ($i=0; $i<$iAnz; $i++)
+ {
+ $buf->SetPtr(shift(@Ptr));
+ $objid = shift(@ObjID);
+ $BBox = shift(@myBBox);
+ my $iYY = shift(@iY);
+ my $iDY = $rTextSep + $iYY/2;
+ my $rBoxHeight = $BBox->height();
+ $iH -= $rBoxHeight/2;
+ my $XYref = new loc($XYorig);
+ $XYref->translate(0,$iH) if $iPosInner == $bbox::SB_L;
+ $XYref->translate(($iBreite-$iLen)/2,$iH) if $iPosInner == $bbox::SB_C;
+ $XYref->translate($iBreite-$iLen,$iH) if $iPosInner == $bbox::SB_R;
+ $BBox->OrigConPoint($iPosInner, $XYs, $Null);
+ $XYs->translate($XYref);
+ $BBox->init($XYs);
+ $origin[$tmpObjID+$i] = $XYs->new();
+ &sliste($XYs, $BBox, $false, $iDY, \@fBBox, ";");
+ $v = shift(@rRatio);
+ $iH -= $rChainSep + $rBoxHeight/2;
+ $iH -= $rTextSep + $iYY/2 - $rBoxHeight*$v
+ if ($iYY>0 && $rTextSep+$iYY/2 > $rBoxHeight*$v);
+ }
+ $buf->NextToken("}");
+ }
+ else
+ # setze im zweiten Lauf alles anhand der bekannten Ma"se zusammen
+ {
+ print OUT $be->comment("multiline");
+ my $i = 0;
+ while (!$buf->NextToken("}"))
+ {
+ $i++;
+ $be->comment(sprintf("chain %d", $i));
+ $XYs = $origin[$tmpObjID+$i-1]; ## "-1" added 1999-05-07 IK
+ &sliste($XYs, $BBox, $true, 0, 0, ";");
+ }
+ $buf->NextToken("nospace");
+ }
+
+&trace("multiline OK", $bFlag);
+ $level--;
+ return $true;
+
+error:
+ $level--;
+ &error($errn, "multiline");
+ return $false;
+}
+
+
+#////////////////////////////////////////////////////////
+#//
+#// bracket() | bracket([]) | bracket([) | bracket(])
+#//
+sub bracket
+{
+ my ($BBox, $bFlag) = @_;
+ my $errn;
+ $level++;
+
+ my ($bLeft, $bRight) = ($true, $true);
+ $errn = $lberr, goto error if !$buf->NextToken("(");
+ if ($buf->NextToken("[]"))
+ { $bLeft = $bRight = $true; }
+ elsif ($buf->NextToken("["))
+ { $bLeft = $true; $bRight = $false; }
+ elsif ($buf->NextToken("]"))
+ { $bLeft = $false; $bRight = $true; }
+ $errn = $rberr, goto error if !$buf->NextToken(")");
+
+ $objid++;
+ if (!$bFlag)
+ {
+ $origin[$objid] = $BBox->new();
+ }
+ else
+ {
+ $BBox = $origin[$objid];
+ if ($bLeft)
+ {
+ print OUT $be->line($BBox->{"xu"}-$fboxsep, $BBox->{"yu"}-$fboxsep,
+ 0, 6+$fboxsep);
+ print OUT $be->line($BBox->{"xu"}-$fboxsep, $BBox->{"yu"}-$fboxsep,
+ 90 ,$BBox->height()+2*$fboxsep);
+ print OUT $be->line($BBox->{"xu"}-$fboxsep, $BBox->{"yo"}+$fboxsep,
+ 0, 6+$fboxsep);
+ }
+ if ($bRight)
+ {
+ print OUT $be->line($BBox->{"xo"}+$fboxsep, $BBox->{"yu"}-$fboxsep,
+ 180, 6+$fboxsep);
+ print OUT $be->line($BBox->{"xo"}+$fboxsep, $BBox->{"yu"}-$fboxsep,
+ 90 ,$BBox->height()+2*$fboxsep);
+ print OUT $be->line($BBox->{"xo"}+$fboxsep, $BBox->{"yo"}+$fboxsep,
+ 180, 6+$fboxsep);
+ }
+ }
+
+ return $true;
+
+error:
+ $level--;
+ &error($errn, "bracket");
+ return $false;
+}
+
+
+#////////////////////////////////////////////////////////
+#//
+#// fbox
+#//
+sub fbox
+{
+ my ($BBox, $bFlag) = @_;
+ $level++;
+
+ $objid++;
+ if (!$bFlag)
+ {
+ $origin[$objid] = $BBox->new();
+ }
+ else
+ {
+ $BBox = $origin[$objid];
+ print OUT $be->line($BBox->{"xu"}-$fboxsep, $BBox->{"yu"}-$fboxsep,
+ 0, $BBox->width()+2*$fboxsep);
+ print OUT $be->line($BBox->{"xu"}-$fboxsep, $BBox->{"yu"}-$fboxsep,
+ 90 ,$BBox->height()+2*$fboxsep);
+ print OUT $be->line($BBox->{"xo"}+$fboxsep, $BBox->{"yu"}-$fboxsep,
+ 90 ,$BBox->height()+2*$fboxsep);
+ print OUT $be->line($BBox->{"xu"}-$fboxsep, $BBox->{"yo"}+$fboxsep,
+ 0, $BBox->width()+2*$fboxsep);
+ }
+
+ return $true;
+}
+
+
+#////////////////////////////////////////////////////////
+#//
+#// setcontext(#<Nr>, <pos>)
+#// savecontext(#<Nr>)
+#//
+sub setcontext
+{
+ my ($XYstart, $XYweiter, $BBoxg, $bFlag) = @_;
+ my $errn;
+ $level++;
+
+ my $i;
+ my $iPos;
+ $errn = $lberr, goto error if !$buf->NextToken("(#");
+ $errn = $interr, goto error if !$buf->GetInt($i);
+ $errn = $komma, goto error if !$buf->NextToken(",");
+ $errn = $poserr, goto error if !$buf->GetPos($iPos);
+ $errn = $rberr, goto error if !$buf->NextToken(")");
+
+ $errn = $nexerr, goto error if !defined($contextlist[$i]);
+ if ($iPos==$bbox::SB_B || $iPos==$bbox::SB_BL || $iPos==$bbox::SB_BR)
+ {
+ $contextTlist[$i]->ToConPoint($iPos, $XYweiter);
+ }
+ else
+ {
+ $contextlist[$i]->ToConPoint($iPos, $XYweiter);
+ }
+ &space_($iPos, $XYweiter) if !$buf->NextToken("nospace");
+ return $true;
+
+error:
+ $level--;
+ &error($errn, "setcontext");
+ return $false;
+}
+
+sub savecontext
+{
+ my ($context, $contextT) = @_;
+ my $errn;
+ $level++;
+
+ my $i;
+ $errn = $lberr, goto error if !$buf->NextToken("(#");
+ $errn = $interr, goto error if !$buf->GetInt($i);
+ $errn = $rberr, goto error if !$buf->NextToken(")");
+
+ $contextlist[$i] = $context->new();
+ $contextTlist[$i] = $contextT->new();
+ return $true;
+
+error:
+ $level--;
+ &error($errn, "savecontext");
+ return $false;
+}
+
+
+#////////////////////////////////////////////////////////
+#//
+#// save(#<n>)/restore(#<n>)
+#// set(<cPar>, <iVal>)
+#//
+sub save
+{
+ my $errn;
+ $level++;
+ my $i;
+ $errn = $lberr, goto error if !$buf->NextToken("(#");
+ $errn = $interr, goto error if !$buf->GetInt($i);
+ $errn = $rberr, goto error if !$buf->NextToken(")");
+
+ my $r_par = [$rLenS, $rLenN, $rLenL, $rLW, $rBW, $rBD, $rAW, $rXS, $rYS,
+ $rArrowSkip, $rArrowExtend, $rChainSep, $rMultilineSep,
+ $fboxsep];
+ $par_stack[$i] = $r_par;
+ return $true;
+
+error:
+ $level--;
+ &error($errn, "save");
+ return $false;
+}
+
+sub restore
+{
+ my ($bFlag) = @_;
+ my $errn;
+ $level++;
+ my $i;
+ $errn = $lberr, goto error if !$buf->NextToken("(#");
+ $errn = $interr, goto error if !$buf->GetInt($i);
+ $errn = $rberr, goto error if !$buf->NextToken(")");
+
+ $errn = $nexerr, goto error if !defined($par_stack[$i]);
+ my $r_par = $par_stack[$i];
+ ($rLenS, $rLenN, $rLenL, $rLW, $rBW, $rBD, $rAW, $rXS, $rYS,
+ $rArrowSkip, $rArrowExtend, $rChainSep, $rMultilineSep,
+ $fboxsep) = @$r_par;
+
+ if ($bFlag)
+ {
+ print OUT $be->parameter("lw", $rLW);
+ print OUT $be->parameter("bw", $rBW);
+ print OUT $be->parameter("aw", $rAW);
+ print OUT $be->parameter("bd", $rBD);
+ }
+ return $true;
+
+error:
+ $level--;
+ &error($errn, "restore");
+ return $false;
+}
+
+sub set
+{
+ my ($bFlag) = @_;
+ my ($cPar, $rVal);
+ my $errn;
+ $level++;
+
+ $errn = $lberr, goto error if !$buf->NextToken("(");
+ $errn = $texterr, goto error if !$buf->GetText($cPar);
+ $errn = $komma, goto error if !$buf->NextToken(",");
+ $errn = $realerr, goto error if !$buf->GetReal($rVal);
+ $errn = $rberr, goto error if !$buf->NextToken(")");
+
+ eval('$'."$cPar = $rVal;");
+
+ if ($bFlag)
+ {
+ SW:
+ {
+ (print OUT $be->parameter("lw", $rVal)), last SW if $cPar eq 'rLW';
+ (print OUT $be->parameter("bw", $rVal)), last SW if $cPar eq 'rBW';
+ (print OUT $be->parameter("bd", $rVal)), last SW if $cPar eq 'rBD';
+ (print OUT $be->parameter("aw", $rVal)), last SW if $cPar eq 'rAW';
+ }
+ }
+
+ return $true;
+
+error:
+ $level--;
+ &error($errn, "set");
+ return $false;
+}
+
+sub scale
+{
+ my ($bFlag) = @_;
+ my $errn;
+ $level++;
+ my $r;
+ $errn = $lberr, goto error if !$buf->NextToken("(");
+ $errn = $realerr, goto error if !$buf->GetReal($r);
+ $errn = $rberr, goto error if !$buf->NextToken(")");
+
+ foreach $par ($rLenS, $rLenN, $rLenL, $rLW, $rBW, $rBD, $rAW, $rXS, $rYS,
+ $rArrowSkip, $rArrowExtend, $rChainSep, $rMultilineSep,
+ $fboxsep)
+ {
+ $par *= $r;
+ }
+
+ if ($bFlag)
+ {
+ print OUT $be->parameter("lw", $rLW);
+ print OUT $be->parameter("bw", $rBW);
+ print OUT $be->parameter("aw", $rAW);
+ print OUT $be->parameter("bd", $rBD);
+ }
+ return $true;
+
+error:
+ $level--;
+ &error($errn, "scale");
+ return $false;
+}
+
+
+#////////////////////////////////////////////////////////
+#//
+#// emove(#<n1>, <iAngle1>, <ctrl1>, #<n2>, <iAngle2>, <ctrl2>)
+#//
+sub emove
+{
+ my ($bFlag) = @_;
+ my $errn;
+ $level++;
+ my ($i, $iAngle, $iCtrl, $j, $jAngle, $jCtrl);
+ $errn = $lberr, goto error if !$buf->NextToken("(#");
+ $errn = $interr, goto error if !$buf->GetInt($i);
+ $errn = $komma, goto error if !$buf->NextToken(",");
+ $errn = $interr, goto error if !$buf->GetInt($iAngle);
+ $errn = $komma, goto error if !$buf->NextToken(",");
+ $errn = $realerr, goto error if !$buf->GetReal($iCtrl);
+ $errn = $komma, goto error if !$buf->NextToken(",#");
+ $errn = $interr, goto error if !$buf->GetInt($j);
+ $errn = $komma, goto error if !$buf->NextToken(",");
+ $errn = $interr, goto error if !$buf->GetInt($jAngle);
+ $errn = $komma, goto error if !$buf->NextToken(",");
+ $errn = $realerr, goto error if !$buf->GetReal($jCtrl);
+ $errn = $rberr, goto error if !$buf->NextToken(")");
+
+ if ($bFlag)
+ {
+ my ($p1, $p2, $pa, $pe);
+ $pa = new loc($posXY[$i]);
+ $pa->translate(cos($iAngle*$pi/180)*$rEmove, sin($iAngle*$pi/180)*$rEmove);
+ $p1 = new loc($posXY[$i]);
+ $p1->translate(cos($iAngle*$pi/180)*$iCtrl, sin($iAngle*$pi/180)*$iCtrl);
+ $pe = new loc($posXY[$j]);
+ $pe->translate(cos($jAngle*$pi/180)*$rEmove, sin($jAngle*$pi/180)*$rEmove);
+ $p2 = new loc($posXY[$j]);
+ $p2->translate(cos($jAngle*$pi/180)*$jCtrl, sin($jAngle*$pi/180)*$jCtrl);
+ print OUT $be->spline($pa->{"x"}, $pa->{"y"},
+ $p1->{"x"}, $p1->{"y"}, $p2->{"x"}, $p2->{"y"},
+ $pe->{"x"}, $pe->{"y"}, $jAngle+180);
+ }
+ return $true;
+
+error:
+ $level--;
+ &error($errn, "emove");
+ return $false;
+}
+
+#////////////////////////////////////////////////////////
+#//
+#// sliste :== formula | arrow | setcontext | savecontext |
+#// showcontext | space | multiline | <endtoken>
+#//
+sub sliste
+{
+ my ($XYg, $BBoxg, $bFlag, $rTextSkip, $fbox, $EndToken) = @_;
+ my $XYStart = new loc($XYg);
+ my $XYweiter = new loc();
+ my $LastContext = new bbox();
+ my $LastContextT = new bbox();
+sliste:
+ if ($buf->NextToken($EndToken))
+ {
+ $XYg->eq($XYweiter);
+ return $true;
+ }
+ elsif ($buf->NextToken("formula"))
+ {
+ $XYStart->eq($XYweiter), goto sliste
+ if &formula($XYStart, $XYweiter, $BBoxg, $bFlag,
+ $rTextSkip, $fbox,
+ $LastContext, $LastContextT);
+ }
+ elsif ($buf->NextToken("arrow"))
+ {
+ $XYStart->eq($XYweiter), goto sliste
+ if &arrow($XYStart, $XYweiter, $BBoxg, $bFlag);
+ }
+ elsif ($buf->NextToken("joinh"))
+ {
+ $XYStart->eq($XYweiter), goto sliste
+ if &joinh($XYStart, $XYweiter, $BBoxg, $bFlag);
+ }
+ elsif ($buf->NextToken("joinv"))
+ {
+ $XYStart->eq($XYweiter), goto sliste
+ if &joinv($XYStart, $XYweiter, $BBoxg, $bFlag);
+ }
+ elsif ($buf->NextToken("multiline"))
+ {
+ $XYStart->eq($XYweiter), goto sliste
+ if &multiline($XYStart, $XYweiter, $BBoxg, $bFlag,
+ $LastContext, $LastContextT);
+ }
+ elsif ($buf->NextToken("space"))
+ {
+ $XYStart->eq($XYweiter), goto sliste
+ if &space($XYStart, $XYweiter, $BBoxg, $bFlag);
+ }
+ elsif ($buf->NextToken("gotoXY"))
+ {
+ $XYStart->eq($XYweiter), goto sliste
+ if &gotoXY($XYStart, $XYweiter, $BBoxg, $bFlag);
+ }
+ elsif ($buf->NextToken("shiftXY"))
+ {
+ $XYStart->eq($XYweiter), goto sliste
+ if &shiftXY($XYStart, $XYweiter, $BBoxg, $bFlag);
+ }
+ elsif ($buf->NextToken("bracket"))
+ {
+ goto sliste if &bracket($LastContext, $bFlag);
+ }
+ elsif ($buf->NextToken("fbox"))
+ {
+ goto sliste if &fbox($LastContextT, $bFlag);
+ }
+ elsif ($buf->NextToken("setcontext"))
+ {
+ $XYStart->eq($XYweiter), goto sliste if &setcontext($XYStart, $XYweiter, $BBoxg, $bFlag);
+ }
+ elsif ($buf->NextToken("savecontext"))
+ {
+ goto sliste if &savecontext($LastContext, $LastContextT);
+ }
+ elsif ($buf->NextToken("save"))
+ {
+ goto sliste if &save();
+ }
+ elsif ($buf->NextToken("restore"))
+ {
+ goto sliste if &restore($bFlag);
+ }
+ elsif ($buf->NextToken("set"))
+ {
+ goto sliste if &set($bFlag);
+ }
+ elsif ($buf->NextToken("scale"))
+ {
+ goto sliste if &scale($bFlag);
+ }
+ elsif ($buf->NextToken("emove"))
+ {
+ goto sliste if &emove($bFlag);
+ }
+
+ &error($synterr, "sliste");
+ return $false;
+}
+
+
+#////////////////////////////////////////////////////////
+#//
+#// schema :== schema(id)
+#// { sliste ...}
+#//
+sub schema
+{
+ my ($BBox, $rW, $rH) = @_;
+ my $errn = 0;
+ my $XY = new loc();
+ my $Null = new loc();
+ my $lBuf = $buf->GetPtr();
+ $level = 0;
+ $objid = 0;
+
+ &init_param;
+ $errn = $synterr, goto error if !&sliste($XY, $BBox, $false, -1, 0, "endschema");
+
+ # save dimensions for use in picture environment size
+ $$rW = $BBox->width();
+ $$rH = $BBox->height();
+
+ # lies nun alles nochmal, wobei der Startpunkt
+ # mit der gewuenschten Positionierung angepasst ist
+
+ &init_param;
+ # write parameter initialization
+ print OUT $be->comment("initialization section");
+ print OUT $be->parameter("lw", $rLW);
+ print OUT $be->parameter("bw", $rBW);
+ print OUT $be->parameter("bd", $rBD);
+ print OUT $be->parameter("aw", $rAW);
+
+
+ $shift = new loc(-$BBox->{"xu"}, -$BBox->{"yu"});
+ $shift->dump("shift") if $trace;
+ grep((ref($_) && $_->translate($shift) && 0), @origin);
+ $BBox->init(0,0);
+ $XY->eq(0,0);
+ $buf->SetPtr($lBuf);
+ $objid = 0;
+ &sliste($XY, $BBox, $true, -1, 0, "endschema");
+
+ return $true;
+
+error:
+ $level--;
+ &error($errn, "schema");
+ return $false;
+}
+
+
+#////////////////////////////////////////////////////////
+#//
+#// main routine
+#//
+
+$version = "1.0b 2001-04-10";
+
+print "This is OCHEM chemistry compiler version $version\n";
+print "requires OCHEM.STY 3.0e\n";
+
+# ##### parse command line #########
+my ($help, $be_type, $preproc, $infile);
+GetOptions("h", \$help, "trace=i", \$trace, "type=s", \$be_type,
+ "pp", \$preproc);
+#$be_type = "PS";
+#$preproc = 1;
+
+if (defined $help)
+{
+ print "usage: chemie.pl [opt...] <chm-file>\n";
+ print " -type <n> output format, PS, PSLATEX, LATEX\n";
+ print " default is 2\n";
+ print " -trace <level> trace level\n";
+ print " -pp use praeprocessor\n";
+ print "\n\n";
+ exit(0);
+}
+
+$infile = shift;
+
+
+# ##### output device, default is postscript drawing and LaTeX picture text #####
+$be_type = "PSLATEX" unless defined $be_type;
+$cCmd = '$be_type = $be::BE_'.$be_type;
+eval($cCmd);
+$be = new be($be_type);
+
+# other initialization, tmp file names
+my ($tmptex, $tmpfile) = ("tmp.tex", "tmp.dat");
+$errn = 0;
+$level = 0;
+
+# ##### replace with call to your LaTeX ######
+# e.g. "tex386 -format=glatex"
+$latexcmd = "latex";
+
+
+
+# ##### start parsing source code #########
+# fill buffer with compressed text and get dimensions of all text fragments
+# enclosed in btex...etex
+%texthash = ();
+$buf = new streambuf();
+
+# ##### preprocess input file ? ######
+if (defined $preproc)
+{
+ ##### replace with call to your preprocessor ######
+ `m4 $infile >$tmpfile`;
+ $buf->LoadBuffer($tmpfile, \%texthash);
+}
+else
+{
+ $buf->LoadBuffer($infile, \%texthash);
+}
+
+# check if a special font for text is required
+if ($buf->NextToken("font("))
+{
+ $errn = $texterr, goto error if !$buf->GetText($cFont);
+ $errn = $rberr, goto error if !$buf->NextToken(")");
+}
+
+#
+# fill in list of desired preloaded LaTeX packages, if required
+#
+@packages = ();
+while ($buf->NextToken("package("))
+{
+ $errn = $texterr, goto error if !$buf->GetText($cPackage);
+ unshift (@packages, $cPackage);
+ $errn = $rberr, goto error if !$buf->NextToken(")");
+}
+$buf->GetTextSize($tmptex, \%texthash, $be_type, $latexcmd, $cFont, \@packages);
+
+# check if perl modules are to load
+while ($buf->NextToken("require"))
+{
+ my ($cFile, $cCmd);
+ $errn = $lberr, goto error if !$buf->NextToken("(");
+ $errn = $texterr, goto error if !$buf->GetText($cFile);
+ $errn = $rberr, goto error if !$buf->NextToken(")");
+
+ require "$cFile.pm";
+}
+
+# parse each "schema" unit
+while ($buf->NextToken("schema"))
+{
+ # parse parameter list
+ $errn = $lberr, goto error if !$buf->NextToken("(");
+ $errn = $texterr, goto error if !$buf->GetText($outfile);
+ $errn = $rberr, goto error if !$buf->NextToken(")");
+
+ # open aux files
+ open(OUT, ">".$outfile);
+ open(TMP, ">".$tmpfile);
+ print "[$outfile] ";
+ $lBackPatch = tell(OUT);
+ # assume (0,0) for unknown box dimension
+ print OUT $be->open('chemfont', 0, 0);
+
+ # parse schema
+ my $BBox = new bbox();
+ my ($rW, $rH);
+ goto error if !&schema($BBox, \$rW, \$rH);
+ print OUT $be->inter();
+ print OUT $be->erase(-1, -1, 0.01, 0.01);
+ print OUT $be->erase($rW+1, $rH+1, 0.01, 0.01);
+ close(TMP);
+
+ # load aux file with LaTeX text for output in picture environment
+ open(TMP, $tmpfile);
+ print OUT <TMP>;
+ close(TMP);
+
+ print OUT $be->close();
+ seek(OUT, $lBackPatch, 0);
+ printf OUT $be->open('chemfont', $rW, $rH);
+ close(OUT);
+}
+
+print "\n";
+exit(0);
+
+# error
+error:
+&error($errn, "main");
+print OUT $be->inter();
+print OUT $be->close();
+die "error aborted run ...\n";