path: root/support/ochem/streambuf.pm

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;