From e0c6872cf40896c7be36b11dcc744620f10adf1d Mon Sep 17 00:00:00 2001 From: Norbert Preining Date: Mon, 2 Sep 2019 13:46:59 +0900 Subject: Initial commit --- support/ochem/streambuf.pm | 419 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 419 insertions(+) create mode 100644 support/ochem/streambuf.pm (limited to 'support/ochem/streambuf.pm') 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 = ) + { + chop($line); + $l = ""; + $bOutText = $::true; + for ($i=$j=0; $i" : ""); + } + } + 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{(.*?)}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 ... +# BOOL $buf->GetText($cVar) +# +sub GetText +{ + my $r_buff = shift; + + if ( $iAnz = substr($r_buff->{"Buffer"}, $r_buff->{"Ptr"}) =~ + m{^(.*?)}) + { + $_[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; -- cgit v1.2.3