#!/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([] [, [] [, [] [, [] #// [, [] [, [] ]]]]]) #// {: fliste; #// vertex()... #// ... #// } #// vertex([] [, [] [, [] [, [] #// [, [] ]]]]) #// {: fliste; #// vertex()... #// ... #// } #// #// bliste := H | O | bliste #// := 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( [, [], []]) #// bond(# [, []]) #// bond([] [+|-] r|b|t|v [/][t][+|- ...] [, [], []]) #// 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( [, [][, [] [, []]]]) #// 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(#) / restoreXY(#) #// 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([] [, []]) #// 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 | #// 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([]) #// 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([] [, []]) / shiftXY([] [, []]) #// 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([] [, [] [, , V|HA|HR, ]]) :== #// 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([] [, [] [, []]]) #// {text(T|B, ){ 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(, [] [, [] [, []]) #// {[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(, [] [, [] [, []]) #// {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( [, [] [, [] [, []]]]) #// {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(#, ) #// savecontext(#) #// 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(#)/restore(#) #// set(, ) #// 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(#, , , #, , ) #// 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 | #// 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...] \n"; print " -type output format, PS, PSLATEX, LATEX\n"; print " default is 2\n"; print " -trace 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 ; 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";