diff options
Diffstat (limited to 'support/ochem/chemie.pl')
-rwxr-xr-x | support/ochem/chemie.pl | 2727 |
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"; |