summaryrefslogtreecommitdiff
path: root/support/ochem/be.pm
diff options
context:
space:
mode:
Diffstat (limited to 'support/ochem/be.pm')
-rw-r--r--support/ochem/be.pm482
1 files changed, 482 insertions, 0 deletions
diff --git a/support/ochem/be.pm b/support/ochem/be.pm
new file mode 100644
index 0000000000..0a4cbd93ea
--- /dev/null
+++ b/support/ochem/be.pm
@@ -0,0 +1,482 @@
+package be;
+#
+# history
+#
+# 20-OCT-1999 IK setting \unitlength in an enclosing group
+# 19-JAN-2000 IK inhibit undesired space (thanks to B. Seckinge)
+#
+
+($BE_PS, $BE_PSLATEX, $BE_LATEX) = (1, 2, 3);
+my $type = $BE_PSLATEX;
+
+# BE_PS: drawing and text as PostScript
+# BE_PSLATEX: drawing as PostScript, text as LaTeX picture environment
+# BE_LATEX: drawing and text as LaTeX picture
+
+#
+# create new backend object.
+# $be = be->new($type)
+#
+
+sub new
+{
+ my $r_be;
+ my $pck = shift; # first parameter is class name
+ if (ref($pck))
+ # called as instance method $beobject->new()
+ {
+ $r_be = { "type" => $pck->{"type"}
+ };
+ }
+ else
+ # called as class method be->new()
+ {
+ if (@_)
+ {
+ $r_be = { "type" => $_[0]
+ };
+ }
+ else
+ {
+ $r_be = { "type" => $BE_PSLATEX
+ };
+ }
+ }
+ bless $r_be, 'be';
+return $r_be;
+}
+
+# helper function for LaTeX output
+# converts angle Phi to dx/dy in [0,4]
+sub phi2delta
+{
+ my ($phi, $len, $dx, $dy, $proj) = @_;
+ my $c30 = cos(30*3.1415927/180);
+ $phi = $phi%360;
+ SW:
+ {
+ $$dx = 2, $$dy = 1, $$proj = $c30*$len, last SW if $phi==30;
+ $$dx = -2, $$dy = 1, $$proj = $c30*$len, last SW if $phi==150;
+ $$dx = -2, $$dy = -1, $$proj = $c30*$len, last SW if $phi==210;
+ $$dx = 2, $$dy = -1, $$proj = $c30*$len, last SW if $phi==330;
+ $$dx = 1, $$dy = 2, $$proj = $len/2, last SW if $phi==60;
+ $$dx = -1, $$dy = 2, $$proj = $len/2, last SW if $phi==120;
+ $$dx = -1, $$dy = -2, $$proj = $len/2, last SW if $phi==240;
+ $$dx = 1, $$dy = -2, $$proj = $len/2, last SW if $phi==300;
+ $$dx = 1, $$dy = 0, $$proj = $len, last SW if $phi==0;
+ $$dx = -1, $$dy = 0, $$proj = $len, last SW if $phi==180;
+ $$dx = 0, $$dy = 1, $$proj = $len, last SW if $phi==90;
+ $$dx = 0, $$dy = -1, $$proj = $len, last SW if $phi==270;
+ $$dx = 1, $$dy = 1, $$proj = sqrt($len), last SW if $phi==45;
+ $$dx = -1, $$dy = 1, $$proj = sqrt($len), last SW if $phi==135;
+ $$dx = -1, $$dy = -1, $$proj = sqrt($len), last SW if $phi==225;
+ $$dx = 1, $$dy = -1, $$proj = sqrt($len), last SW if $phi==315;
+ print "warning: not converting angle $phi!\n";
+ }
+}
+
+
+#
+# draw normal line giving starting point, length and direction
+# $be->line($x, $y, $phi, $len, [,$rem])
+#
+sub line
+{
+ my $r_be = shift;
+ my ($x, $y, $phi, $len, $rem) = @_;
+
+ if ($r_be->{"type"} == $BE_PS || $r_be->{"type"} == $BE_PSLATEX)
+ {
+ sprintf "gs %.2f %.2f tr %.2f rotate ".
+ "0 0 m %.2f 0 rlineto stroke gr %s\n",
+ $x, $y, $phi, $len,
+ $rem ? " %%$rem" : "";
+ }
+ elsif ($r_be->{"type"} == $BE_LATEX)
+ {
+ my ($xe, $ye) = ($x+cos($phi*$::pi/180)*$len, $y+sin($phi*$::pi/180)*$len);
+ sprintf "\\drawline(%.2f,%.2f)(%.2f,%.2f) %s\n",
+ $x, $y, $xe, $ye, $rem ? " %%$rem" : "";
+ }
+}
+
+
+#
+# draw general line connecting two points, giving dash pattern
+# $be->draw($x0, $y0, $x1, $y1 [,$cLineType])
+#
+sub draw
+{
+ my $r_be = shift;
+ my ($x0, $y0, $x1, $y1, $cLineType) = @_;
+
+ if ($r_be->{"type"} == $BE_PS || $r_be->{"type"} == $BE_PSLATEX)
+ {
+ sprintf "gs %s 0 setdash %.2f %.2f m %.2f %.2f l stroke gr\n",
+ $cLineType, $x0, $y0, $x1, $y1;
+ }
+ elsif ($r_be->{"type"} == $BE_LATEX)
+ {
+ sprintf "\\drawline(%.2f,%.2f)(%.2f,%.2f)\n",
+ $x0, $y0, $x1, $y1;
+ }
+}
+
+
+#
+# draw marker at given point
+# $be->mark($x0, $y0, $iType, $iSize)
+#
+sub mark
+{
+ my $r_be = shift;
+ my ($x, $y, $iType, $iSize) = @_;
+
+ if ($r_be->{"type"} == $BE_PS || $r_be->{"type"} == $BE_PSLATEX)
+ {
+ sprintf "%.2f %.2f %.2f m%d\n", $iSize, $x, $y, $iType;
+ }
+ elsif ($r_be->{"type"} == $BE_LATEX)
+ {
+ sprintf "\\put(%.2f,%.2f){\\circle*{%d}}\n", $x, $y, $iSize;
+ }
+}
+
+
+#
+# chemical bond in different shapes
+# $be->bond($x, $y, $phi, $len, $type [,$rem])
+#
+sub bond
+{
+ my $r_be = shift;
+ my ($x, $y, $phi, $len, $type, $rem) = @_;
+
+ if ($r_be->{"type"} == $BE_PS || $r_be->{"type"} == $BE_PSLATEX)
+ {
+ sprintf "%.2f %.2f %.2f %.2f b%d%s\n",
+ $phi, $x, $y, $len, $type, $rem ? " %%$rem" : "";
+ }
+ elsif ($r_be->{"type"} == $BE_LATEX)
+ {
+ my ($xe, $ye) = ($x+cos($phi*$::pi/180)*$len, $y+sin($phi*$::pi/180)*$len);
+ my ($dx1, $dy1) = (cos((45+$phi)*$::pi/180)*4, sin((45+$phi)*$::pi/180)*4);
+ my ($dxe1, $dye1) = (cos((135+$phi)*$::pi/180)*4, sin((135+$phi)*$::pi/180)*4);
+ my ($dx2, $dy2) = (cos((-45+$phi)*$::pi/180)*4, sin((-45+$phi)*$::pi/180)*4);
+ my ($dxe2, $dye2) = (cos((-135+$phi)*$::pi/180)*4, sin((-135+$phi)*$::pi/180)*4);
+ SW: {
+ (sprintf "\\drawline(%.2f,%.2f)(%.2f,%.2f)\n",
+ $x, $y, $xe, $ye), last SW if $type==0;
+ (sprintf "\\drawline(%.2f,%.2f)(%.2f,%.2f) ".
+ "\\drawline(%.2f,%.2f)(%.2f,%.2f)\n",
+ $x, $y+$dy1, $xe, $ye+$dye1,
+ $x, $y+$dy2, $xe, $ye+$dye2), last SW if $type==5;
+ (sprintf "\\drawline(%.2f,%.2f)(%.2f,%.2f) ".
+ "\\drawline(%.2f,%.2f)(%.2f,%.2f)\n",
+ $x, $y, $xe, $ye,
+ $x+$dx1, $y+$dy1, $xe+$dxe1, $ye+$dye1), last SW if $type==6;
+ (sprintf "\\drawline(%.2f,%.2f)(%.2f,%.2f) ".
+ "\\drawline(%.2f,%.2f)(%.2f,%.2f)\n",
+ $x, $y, $xe, $ye,
+ $x+$dx2, $y+$dy2, $xe+$dxe2, $ye+$dye2), last SW if $type==7;
+ (sprintf "\\drawline(%.2f,%.2f)(%.2f,%.2f) ".
+ "\\drawline(%.2f,%.2f)(%.2f,%.2f) ".
+ "\\drawline(%.2f,%.2f)(%.2f,%.2f)\n",
+ $x, $y, $xe, $ye,
+ $x+$dx1, $y+$dy1, $xe+$dxe1, $ye+$dye1,
+ $x+$dx2, $y+$dy2, $xe+$dxe2, $ye+$dye2), last SW if $type==8;
+ (sprintf "{\\allinethickness{2pt}\\drawline(%.2f,%.2f)(%.2f,%.2f)}\n",
+ $x, $y, $xe, $ye), last SW if $type==9;
+ (sprintf "{\\allinethickness{2pt}\\dottedline(%.2f,%.2f)(%.2f,%.2f)}\n",
+ $x, $y, $xe, $ye), last SW if $type==4;
+ (sprintf "\\dottedline(%.2f,%.2f)(%.2f,%.2f)\n",
+ $x, $y, $xe, $ye), last SW if $type==13;
+ (sprintf "\n"), last SW if $type==12;
+ my ($dx, $dy, $proj);
+ &phi2delta($phi, $len, \$dx, \$dy, \$proj);
+ (sprintf "\\put(%.2f,%.2f){\\vector(%d,%d){%.2f}}\n",
+ $x, $y, $dx, $dy, $proj), last SW if $type==10;
+ (sprintf "\\put(%.2f,%.2f){\\vector(%d,%d){%.2f}}\n",
+ $x+$proj, $y, -$dx, $dy, $proj), last SW if $type==11;
+ print "warning: not drawing bond type $type\n";
+ }
+ }
+}
+
+#
+# chemical arrow
+# $be->arrow($x, $y, $phi, $len, $type [,$rem])
+#
+sub arrow
+{
+ my $r_be = shift;
+ my ($x, $y, $phi, $len, $type, $rem) = @_;
+
+ if ($r_be->{"type"} == $BE_PS || $r_be->{"type"} == $BE_PSLATEX)
+ {
+ sprintf "%.2f %.2f %.2f %.2f ar%d%s\n",
+ $len, $phi, $x, $y, $type,
+ $rem ? " %%$rem" : "";
+ }
+ elsif ($r_be->{"type"} == $BE_LATEX)
+ {
+ my ($dx, $dy, $proj);
+ &phi2delta($phi, $len, \$dx, \$dy, \$proj);
+ SW: {
+ (sprintf "\\put(%.2f,%.2f){\\line(%d,%d){%.2f}}\n",
+ $x, $y, $dx, $dy, $proj), last SW if $type==0;
+ (sprintf "\\put(%.2f,%.2f){\\vector(%d,%d){%.2f}}\n",
+ $x, $y, $dx, $dy, $proj), last SW if $type==1;
+ (sprintf "\\put(%.2f,%.2f){\\vector(%d,%d){%.2f}}\n",
+ $x+$proj, $y, -$dx, $dy, $proj),
+ last SW if $type==2;
+ (sprintf "\\put(%.2f,%.2f){\\vector(%d,%d){%.2f}} ".
+ "\\put(%.2f,%.2f){\\vector(%d,%d){%.2f}}\n",
+ $x, $y+3, $dx, $dy, $proj,
+ $x+$proj, $y-3, -$dx, $dy, $proj),
+ last SW if $type==3;
+ (sprintf "\\put(%.2f,%.2f){\\vector(%d,%d){%.2f}} ".
+ "\\put(%.2f,%.2f){\\vector(%d,%d){%.2f}}\n",
+ $x, $y, $dx, $dy, $proj,
+ $x+$proj, $y, -$dx, $dy,),
+ last SW if $type==4;
+ (sprintf "\\put(%.2f,%.2f){\\vector(%d,%d){%.2f}} ".
+ "\\put(%.2f,%.2f){//}\n",
+ $x, $y, $dx, $dy, $proj, $x+$proj/2,$y),
+ last SW if $type==5;
+ (sprintf "\\put(%.2f,%.2f){\\vector(%d,%d){%.2f}} ".
+ "\\put(%.2f,%.2f){//}\n",
+ $x+$proj, $y, -$dx, $dy, $proj, $x+$proj/2,$y),
+ last SW if $type==6;
+ }
+ }
+}
+
+
+#
+# blanks out rectangle, normally used to erase background of text
+# $be->erase($x, $y, $width, $height [,$rem])
+#
+sub erase
+{
+ my $r_be = shift;
+ my ($x, $y, $width, $height, $rem) = @_;
+
+ if ($r_be->{"type"} == $BE_PS)
+ {
+ sprintf "gs 1 setgray np %f %f moveto %f 0 rlineto 0 %f rlineto -%f 0 rlineto ".
+ "closepath fill gr\n",
+ $x, $y, $width, $height, $rem ? " %%$rem" : "";
+ }
+ elsif ($r_be->{"type"} == $BE_PSLATEX || $r_be->{"type"} == $BE_LATEX)
+ {
+ sprintf "\\put(%f,%f){\\textcolor{white}{\\rule{%fpt}{%fpt}}}\n",
+ $x, $y, $width, $height, $rem ? " %%$rem" : "";
+ }
+}
+
+
+#
+# $be->text($x, $y, $text [,$rem])
+#
+sub text
+{
+ my $r_be = shift;
+ my ($x, $y, $text, $rem) = @_;
+
+ if ($r_be->{"type"} == $BE_PS)
+ {
+ sprintf "%.2f %.2f moveto (%s) show%s\n",
+ $x, $y, $text, $rem ? " %%$rem" : "";
+ }
+ elsif ($r_be->{"type"} == $BE_PSLATEX || $r_be->{"type"} == $BE_LATEX)
+ {
+ sprintf "\\put(%f,%f){%s}%s\n",
+ $x, $y, $text, $rem ? " %%$rem" : "";
+ }
+}
+
+
+#
+# draw a circle
+# $be->arc($mx, $my, $phi0, $phiend, $radius [,$rem])
+#
+sub arc
+{
+ my $r_be = shift;
+ my ($x, $y, $phi0, $phiend, $radius, $rem) = @_;
+
+ if ($r_be->{"type"} == $BE_PS || $r_be->{"type"} == $BE_PSLATEX)
+ {
+ sprintf "np %.2f %.2f %4f %4f %.2f arc closepath s%s\n",
+ $x, $y, $radius, $phi0, $phiend,
+ $rem ? " %$rem" : "";
+ }
+ elsif ($r_be->{"type"} == $BE_LATEX)
+ {
+ sprintf "\\put(%.2f,%.2f){\\circle{%.2f}}%s\n",
+ $x, $y, $radius, $rem ? " %$rem" : "";
+ }
+}
+
+
+#
+# draws a spline starting at p1, control points p2/p3 with an arrow tip
+# at the end point p4
+# $be->spline($p1.x, $p1.y, ..., $p4.y)
+#
+sub spline
+{
+ my $r_be = shift;
+ my ($x1, $y1, $x2, $y2, $x3, $y3, $x4, $y4, $angle) = @_;
+
+ if ($r_be->{"type"} == $BE_PS || $r_be->{"type"} == $BE_PSLATEX)
+ {
+ sprintf "np %.2f %.2f moveto %.2f %.2f %.2f %.2f %.2f %.2f curveto s".
+ " %d %.2f %.2f atip\n",
+ $x1, $y1, $x2, $y2, $x3, $y3, $x4, $y4, $angle, $x4, $y4;
+ }
+ elsif ($r_be->{"type"} == $BE_LATEX)
+ {
+ print "warning: not drawing emove spline!\n";
+ sprintf "\n";
+ }
+}
+
+
+#
+# $be->orbital($x, $y, $iAngle, $rWeight)
+#
+sub orbital
+{
+ my $r_be = shift;
+ my ($x, $y, $iAngle, $rWeight) = @_;
+
+ my $XY1 = loc->new($x, $y);
+ my $XY2 = loc->new($x, $y);
+ if ($r_be->{"type"} == $BE_PS || $r_be->{"type"} == $BE_PSLATEX)
+ {
+
+ sprintf "gsave %.2f %.2f translate %d rotate %.2f dup scale ".
+ ".9 setgray np 0 0 moveto 1 .5 1 -.5 0 0 rcurveto fill ".
+ ".7 setgray np 0 0 moveto -1 .5 -1 -.5 0 0 rcurveto fill grestore\n",
+ $x, $y, $iAngle, $rWeight;
+ }
+ elsif ($r_be->{"type"} == $BE_LATEX)
+ {
+ print "warning: not drawing orbital!\n";
+ sprintf "\n";
+ }
+}
+
+
+#
+# sets graphical parameters
+# $be->parameter($name, $wert)
+#
+sub parameter
+{
+ my $r_be = shift;
+ my ($name, $value, $rem) = @_;
+
+ if ($r_be->{"type"} == $BE_PS || $r_be->{"type"} == $BE_PSLATEX)
+ {
+ SW: {
+ (sprintf "%f setlinewidth /lw %f def \n", $value, $value),
+ last SW if $name eq "lw";
+ (sprintf "%f setgray\n", $value), last SW if $name eq "gray";
+ sprintf "/%s %f def\n", $name, $value;
+ }
+ }
+ elsif ($r_be->{"type"} == $BE_LATEX)
+ {
+ SW1: {
+ (sprintf "\\allinethickness{%.2fpt}\n", $value), last SW1 if $name eq "lw";
+ }
+ }
+}
+
+
+# $be->comment($rem)
+sub comment
+{
+ my $r_be = shift;
+ my ($rem) = @_;
+
+ if ($r_be->{"type"} == $BE_PS || $r_be->{"type"} == $BE_PSLATEX ||
+ $r_be->{"type"} == $BE_LATEX)
+ {
+ sprintf "%%%s\n", $rem;
+ }
+}
+
+
+#
+# called when picture is to be opened
+# $be->open($font, $x, $y, [,$rem])
+#
+sub open
+{
+ my $r_be = shift;
+ my ($font, $x, $y, $rem) = @_;
+
+ if ($r_be->{"type"} == $BE_PS)
+ {
+ sprintf "%sBoundingBox: 0 0 %7.2f %7.2f%s\n", "%%%%",
+ $x, $y, $rem ? "\n%% $rem" : "";
+
+ }
+ elsif ($r_be->{"type"} == $BE_PSLATEX)
+ {
+ sprintf "{\\unitlength1pt\\begin{picture}(%7.2f,%7.2f)\n".
+ "{\\%sname\n".
+ "\\special{\\string\"\n", $x, $y, $font;
+ }
+ elsif ($r_be->{"type"} == $BE_LATEX)
+ {
+ sprintf "{\\unitlength1pt\\begin{picture}(%7.2f,%7.2f)\n".
+ "{\\%s\n", $x, $y, $font;
+ }
+}
+
+
+#
+# called at closure of picture
+# $be->close([$rem])
+#
+sub close
+{
+ my $r_be = shift;
+ my ($rem) = @_;
+
+ if ($r_be->{"type"} == $BE_PS)
+ {
+ sprintf "%% end of chem pic%s\n", $rem ? " ($rem)" : "";
+ }
+ if ($r_be->{"type"} == $BE_PSLATEX || $r_be->{"type"} == $BE_LATEX)
+ {
+ sprintf "}\\end{picture}}\%%s\n", $rem ? " %%$rem" : "";
+ }
+}
+
+
+#
+# called after drawing data was written, but before text is wrote
+# $be->inter([$rem])
+#
+sub inter
+{
+ my $r_be = shift;
+ my ($rem) = @_;
+
+ if ($r_be->{"type"} == $BE_PS || $r_be->{"type"} == $BE_LATEX)
+ {
+ sprintf "\n";
+ }
+ elsif ($r_be->{"type"} == $BE_PSLATEX)
+ {
+ sprintf "} %% end of special%s\n", $rem ? " ($rem)" : "";
+ }
+}
+
+1;
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-08 09:13:27 +0000