summaryrefslogtreecommitdiff
path: root/support/ochem/streambuf.pm
diff options
context:
space:
mode:
authorNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
committerNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
commite0c6872cf40896c7be36b11dcc744620f10adf1d (patch)
tree60335e10d2f4354b0674ec22d7b53f0f8abee672 /support/ochem/streambuf.pm
Initial commit
Diffstat (limited to 'support/ochem/streambuf.pm')
-rw-r--r--support/ochem/streambuf.pm419
1 files changed, 419 insertions, 0 deletions
diff --git a/support/ochem/streambuf.pm b/support/ochem/streambuf.pm
new file mode 100644
index 0000000000..50d9720454
--- /dev/null
+++ b/support/ochem/streambuf.pm
@@ -0,0 +1,419 @@
+package streambuf;
+#
+# history
+#
+# 09-JAN-2000 IK new bond shapes >> and >. and b
+# 19-JAN-2000 IK new bond shape ~, bond length now determined by number of type markers,
+# LaTeX packages can be given to be preloaded
+#
+
+#
+# creates new buffer
+#
+sub new
+{
+ $r_buffer = { "Ptr" => 0,
+ "Anz" => 0,
+ "Buffer" => ""
+ };
+ bless $r_buffer, 'streambuf';
+ return $r_buffer;
+}
+
+
+#
+# $buf->LoadBuffer($file)
+#
+sub LoadBuffer
+{
+ my ($r_buff, $file, $texthash) = @_;
+ my ($text, $l, $c, $bOutText);
+
+ open(FILE, $file);
+ while ($line = <FILE>)
+ {
+ chop($line);
+ $l = "";
+ $bOutText = $::true;
+ for ($i=$j=0; $i<length($line); $i++)
+ {
+ $c = substr($line, $i, 1);
+ if ($c eq '"')
+ {
+ if (substr($line, $i+1, 1) eq '"')
+ {
+ $c = '"';
+ $i++;
+ }
+ else
+ {
+ $bOutText = !$bOutText;
+ $c = ($bOutText ? "</text>" : "<text>");
+ }
+ }
+ last if ($c =~ /%/ && $bOutText);
+ next if ($c =~ /\s/ && $bOutText);
+ substr($l, $j) = $c;
+ $j += length($c);
+ }
+ $line = $l;
+##+ $line =~ s/\s//g; # delete white spaces
+##+ $line =~ /^([^%]*)%*.*$/; # cut off comment
+##+ $line = $1;
+ # write out all TeX text strings
+ @textext = ($line =~ m{<text>(.*?)</text>}g);
+ if (@textext)
+ {
+ foreach $text (@textext)
+ {
+ $texthash->{$text} = "";
+ }
+ }
+ substr($r_buff->{"Buffer"}, $r_buff->{"Anz"}, 0) = $line;
+ $r_buff->{"Anz"} += length($line);
+ }
+ close(FILE);
+}
+
+
+#
+# $buf->GetTextSize(...)
+#
+sub GetTextSize
+{
+ my ($r_buff, $tmptex, $texthash, $be_type, $latexcmd, $cFont, $packages) = @_;
+ my $text;
+ my ($opt, $package, $packagename);
+
+ # get dimensions of text fragments
+ if ($be_type == $be::BE_PSLATEX || $be_type == $be::BE_LATEX)
+ {
+ open(OUT, ">".$tmptex);
+ print OUT "\\documentclass[a4paper,12pt]{article}\n";
+ print OUT "\\usepackage{german}\n";
+ # write each desired LaTeX package in preamble
+ while ($package = pop(@$packages))
+ {
+ ($opt, $packagename) = $package =~ /(\[\S*\])*(\S*)/;
+ print OUT "\\usepackage$opt\{$packagename\}\n";
+ }
+ print OUT "\\newsavebox{\\testbox}\n";
+ print OUT "\\newcommand{\\atom}[1]\n";
+ print OUT "{\\sbox{\\testbox}{#1}\n";
+ print OUT " \\typeout{A:\\the\\wd\\testbox,\\the\\ht\\testbox,\\the\\dp\\testbox}\n";
+ print OUT " }\n";
+ print OUT "\\newcommand{\\testfont}{$cFont}\n" if $cFont;
+ print OUT "\n";
+ print OUT "\\begin{document}\n";
+ print OUT "\\testfont\n" if $cFont;
+ foreach $text (keys %$texthash)
+ {
+ print OUT "\\atom{$text}\n";
+ }
+ print OUT "\\end{document}\n";
+ close(OUT);
+
+ # build array of TeX text dimensions: LaTeX it!
+ my @dimen = grep(/^A:/, `$latexcmd $tmptex`);
+ my $i = 0;
+ foreach $text (keys %$texthash)
+ {
+ $texthash->{$text} = $dimen[$i++];
+ }
+ }
+ elsif ($be_type == $be::BE_PS)
+ {
+ foreach $text (keys %$texthash)
+ {
+ print "warning: cannot determine text size for $text\n";
+ }
+ }
+}
+
+
+#
+#
+#
+sub GetPtr
+{
+ my $r_buff = shift;
+ return $r_buff->{"Ptr"};
+}
+
+sub SetPtr
+{
+ my ($r_buff, $ptr) = @_;
+ $r_buff->{"Ptr"} = $ptr;
+}
+
+
+#
+# check if next token in buffer is $token, and adjusts buffer pointer
+# Returns zero if there's not this token.
+# BOOL $buf->NextToken($token)
+#
+sub NextToken
+{
+ my ($r_buff, $text) = @_;
+ my $Ptr = $r_buff->{"Ptr"};
+ my $Anz = $r_buff->{"Anz"};
+ my $len = length($text);
+
+ return 0 if $len+$Ptr > $Anz;
+ if (substr($r_buff->{"Buffer"}, $Ptr, $len) eq $text)
+ {
+ $r_buff->{"Ptr"} += $len;
+ return 1;
+ }
+ return 0;
+}
+
+
+#
+# Tries to get an signed integer value.
+# BOOL $buf->GetInt($iVar)
+#
+sub GetInt
+{
+ my $r_buff = shift;
+
+ if ( $iAnz = substr($r_buff->{"Buffer"}, $r_buff->{"Ptr"}) =~
+ /^([+-]?\d+)/)
+ {
+ $_[0] = $1;
+ $r_buff->{"Ptr"} += length($1);
+ }
+ return ($iAnz);
+}
+
+
+#
+# Tries to get an signed fix float value.
+# BOOL $buf->GetReal($rVar)
+#
+sub GetReal
+{
+ my $r_buff = shift;
+
+ if ( $iAnz = substr($r_buff->{"Buffer"}, $r_buff->{"Ptr"}) =~
+ /^([+-]?(\d+(\.\d*)*)|(\d*\.\d*))/)
+ {
+ $_[0] = $1;
+ $r_buff->{"Ptr"} += length($1);
+ }
+ return ($iAnz);
+}
+
+
+#
+# Tries to get a text enclosed in <text>...</text>
+# BOOL $buf->GetText($cVar)
+#
+sub GetText
+{
+ my $r_buff = shift;
+
+ if ( $iAnz = substr($r_buff->{"Buffer"}, $r_buff->{"Ptr"}) =~
+ m{^<text>(.*?)</text>})
+ {
+ $_[0] = $1;
+ $r_buff->{"Ptr"} += length($1) + 13;
+ }
+ return ($iAnz);
+}
+
+
+#
+# decodes a type marker like X or Y
+# BOOL $buf->GetType($iType)
+#
+($T_X, $T_Y) = (0, 1);
+sub GetType
+{
+ my $r_buff = shift;
+ my $code = substr($r_buff->{"Buffer"}, $r_buff->{"Ptr"}, 1);
+ my $l;
+ $_[0] = -1;
+ SWITCH: {
+ $l = 1;
+ $_[0] = $T_X, last SWITCH if $code eq "X";
+ $_[0] = $T_Y, last SWITCH if $code eq "Y";
+ $l = 0;
+ }
+ $r_buff->{"Ptr"} += $l;
+ return ($_[0] != -1);
+}
+
+#
+# decodes a position marker like T, TR, T, BL, C, ...
+# BOOL $buf->GetPos($iPos)
+#
+sub GetPos
+{
+ my $r_buff = shift;
+ my $code2 = substr($r_buff->{"Buffer"}, $r_buff->{"Ptr"}, 2);
+ my $code1 = substr($r_buff->{"Buffer"}, $r_buff->{"Ptr"}, 1);
+ my $l;
+ $_[0] = -1;
+ SWITCH: {
+ $l = 2;
+ $_[0] = $bbox::SB_BL, last SWITCH if $code2 eq "BL";
+ $_[0] = $bbox::SB_BR, last SWITCH if $code2 eq "BR";
+ $_[0] = $bbox::SB_TL, last SWITCH if $code2 eq "TL";
+ $_[0] = $bbox::SB_TR, last SWITCH if $code2 eq "TR";
+ $l = 1;
+ $_[0] = $bbox::SB_L, last SWITCH if $code1 eq "L";
+ $_[0] = $bbox::SB_R, last SWITCH if $code1 eq "R";
+ $_[0] = $bbox::SB_T, last SWITCH if $code1 eq "T";
+ $_[0] = $bbox::SB_B, last SWITCH if $code1 eq "B";
+ $_[0] = $bbox::SB_C, last SWITCH if $code1 eq "C";
+ $l = 0;
+ }
+ $r_buff->{"Ptr"} += $l;
+ return ($_[0] != -1);
+}
+
+
+#
+# decodes a bond length marker like S, N, L and returns length
+# BOOL $buf->GetBondLen($rLen)
+#
+sub GetBondLen
+{
+ my $r_buff = shift;
+ my $l;
+ my $bFound = 0;
+ $_[0] = 0;
+ while(1)
+ {
+ my $code = substr($r_buff->{"Buffer"}, $r_buff->{"Ptr"}, 1);
+ $_[0] += $main::rLenN, next if $code eq "N";
+ $_[0] += $main::rLenL, next if $code eq "L";
+ $_[0] += $main::rLenS, next if $code eq "S";
+ $_[0] += $main::rLenN/2, next if $code eq "n";
+ $_[0] += $main::rLenL/2, next if $code eq "l";
+ $_[0] += $main::rLenS/2, next if $code eq "s";
+ next if $code eq "0";
+ last;
+ } continue { $r_buff->{"Ptr"} += 1; $bFound = 1; }
+ return ($bFound);
+}
+sub GetBondLenOrig
+{
+ my $r_buff = shift;
+ my $code2 = substr($r_buff->{"Buffer"}, $r_buff->{"Ptr"}, 2);
+ my $code1 = substr($r_buff->{"Buffer"}, $r_buff->{"Ptr"}, 1);
+ my $l;
+ $_[0] = -1;
+ SWITCH: {
+ $l = 2;
+ $_[0] = 2*$main::rLenN, last SWITCH if $code2 eq "NN";
+ $_[0] = 2*$main::rLenS, last SWITCH if $code2 eq "SS";
+ $_[0] = 2*$main::rLenL, last SWITCH if $code2 eq "LL";
+ $l = 1;
+ $_[0] = $main::rLenN, last SWITCH if $code1 eq "N";
+ $_[0] = $main::rLenL, last SWITCH if $code1 eq "L";
+ $_[0] = $main::rLenS, last SWITCH if $code1 eq "S";
+ $_[0] = $main::rLenN/2, last SWITCH if $code1 eq "n";
+ $_[0] = $main::rLenL/2, last SWITCH if $code1 eq "l";
+ $_[0] = $main::rLenS/2, last SWITCH if $code1 eq "s";
+ $_[0] = 0, last SWITCH if $code1 eq "0";
+ $l = 0;
+ }
+ $r_buff->{"Ptr"} += $l;
+ return ($_[0] != -1);
+}
+
+
+#
+# decodes a bond type marker like -, =, L and returns type code
+# BOOL $buf->GetBondType($iType)
+#
+sub GetBondType
+{
+ my $r_buff = shift;
+ my %codes = ( "->" => 10, "-" => 0, "<-" => 11, "s" => 12,
+ "<<" => 2, "<." => 3, "o" => 4,
+ "=C" => 5, "=U" => 6, "=" => 7, "3" => 8,
+ "p" =>1, "t" => 9, ">>" => 13, ">." => 14,
+ "b" => 15, "~" => 16
+ );
+ $_[0] = -1;
+
+ foreach $elem (keys %codes)
+ {
+ if (substr($r_buff->{"Buffer"}, $r_buff->{"Ptr"}, length($elem)) eq
+ $elem)
+ {
+ $_[0] = $codes{$elem};
+ $r_buff->{"Ptr"} += length($elem);
+ last;
+ }
+ }
+ return ($_[0] != -1);
+}
+
+
+#
+# decodes a arrow type marker like -, =, ... and returns type code
+# BOOL $buf->GetArrowType($iType)
+#
+sub GetArrowType
+{
+ my $r_buff = shift;
+ my $code3 = substr($r_buff->{"Buffer"}, $r_buff->{"Ptr"}, 3);
+ my $code2 = substr($r_buff->{"Buffer"}, $r_buff->{"Ptr"}, 2);
+ my $code1 = substr($r_buff->{"Buffer"}, $r_buff->{"Ptr"}, 1);
+ my $l;
+ $_[0] = -1;
+ SWITCH: {
+ $l = 3;
+ $_[0] = 3, last SWITCH if $code3 eq "<=>";
+ $_[0] = 4, last SWITCH if $code3 eq "<->";
+ $_[0] = 5, last SWITCH if $code3 eq "-|>";
+ $_[0] = 6, last SWITCH if $code3 eq "<|-";
+ $l = 2;
+ $_[0] = 1, last SWITCH if $code2 eq "->";
+ $_[0] = 2, last SWITCH if $code2 eq "<-";
+ $l = 1;
+ $_[0] = 0, last SWITCH if $code1 eq "-";
+ $l = 0;
+ }
+ $r_buff->{"Ptr"} += $l;
+ return ($_[0] != -1);
+}
+
+#
+# decodes a marker type marker like -, =, ... and returns type code
+# BOOL $buf->GetMarkerType($iType)
+#
+sub GetMarkerType
+{
+ my $r_buff = shift;
+ my $code2 = substr($r_buff->{"Buffer"}, $r_buff->{"Ptr"}, 2);
+ my $code1 = substr($r_buff->{"Buffer"}, $r_buff->{"Ptr"}, 1);
+ my $l;
+ $_[0] = -1;
+ SWITCH: {
+ $l = 2;
+ $_[0] = 3, last SWITCH if $code2 eq "4f";
+ $_[0] = 1, last SWITCH if $code2 eq "of";
+ $_[0] = 5, last SWITCH if $code2 eq "rf";
+ $_[0] = 7, last SWITCH if $code2 eq "3f";
+ $l = 1;
+ $_[0] = 0, last SWITCH if $code1 eq "o";
+ $_[0] = 2, last SWITCH if $code1 eq "4";
+ $_[0] = 4, last SWITCH if $code1 eq "r";
+ $_[0] = 6, last SWITCH if $code1 eq "3";
+ $_[0] = 8, last SWITCH if $code1 eq "+";
+ $_[0] = 9, last SWITCH if $code1 eq "x";
+ $_[0] = 10, last SWITCH if $code1 eq "*";
+ $_[0] = 11, last SWITCH if $code1 eq "n";
+ $l = 0;
+ }
+ $r_buff->{"Ptr"} += $l;
+ return ($_[0] != -1);
+}
+
+
+1;