Annotation of loncom/homework/convertjme.pl, revision 1.10

1.1       albertel    1: #!/usr/bin/perl
1.4       albertel    2: # The LearningOnline Network with CAPA
                      3: # Dynamically converts JME strings into either a png or ps file.
                      4: #
1.10    ! albertel    5: # $Id: convertjme.pl,v 1.9 2003/12/08 18:36:58 albertel Exp $
1.4       albertel    6: #
                      7: # Copyright Michigan State University Board of Trustees
                      8: #
                      9: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
                     10: #
                     11: # LON-CAPA is free software; you can redistribute it and/or modify
                     12: # it under the terms of the GNU General Public License as published by
                     13: # the Free Software Foundation; either version 2 of the License, or
                     14: # (at your option) any later version.
                     15: #
                     16: # LON-CAPA is distributed in the hope that it will be useful,
                     17: # but WITHOUT ANY WARRANTY; without even the implied warranty of
                     18: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
                     19: # GNU General Public License for more details.
                     20: #
                     21: # You should have received a copy of the GNU General Public License
                     22: # along with LON-CAPA; if not, write to the Free Software
                     23: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
                     24: #
                     25: # /home/httpd/html/adm/gpl.txt
                     26: #
                     27: # http://www.lon-capa.org/
1.1       albertel   28: # Coded by Guy Ashkenazi, guy@fh.huji.ac.il
                     29: # Based on the work of Peter Ertl, peter.ertl@pharma.novartis.com
1.4       albertel   30: 
1.8       albertel   31: use strict;
                     32: 
                     33: ### FOR LON-CAPA set $loncapa to 1 and uncomment both uses
                     34: ### For standalone operation, set $loncapa to 0, and comment out both uses
                     35: my $loncapa=1;
                     36: use lib '/home/httpd/lib/perl';
                     37: use LONCAPA::loncgi();
1.4       albertel   38: 
1.1       albertel   39: 
                     40: use GD;
1.3       albertel   41: use PostScript::Simple;
1.2       albertel   42: 
1.7       albertel   43: if ($loncapa) {
                     44:     if (! &LONCAPA::loncgi::check_cookie_and_load_env()) {
                     45: 	print <<END;
1.2       albertel   46: Content-type: text/html
                     47: 
                     48: <html>
                     49: <head><title>Bad Cookie</title></head>
                     50: <body>
                     51: Your cookie information is incorrect. 
                     52: </body>
                     53: </html>
                     54: END
1.7       albertel   55:         exit;
                     56:     }
1.2       albertel   57: }
                     58: 
                     59: sub unescape {
                     60:     my $str=shift;
                     61:     $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
                     62:     return $str;
                     63: }
1.1       albertel   64: 
                     65: # read the width and the JME string from the cgi query
1.7       albertel   66: my ($id,$width,$ps,$png,@JMEstring);
                     67: if ($loncapa) {
                     68:     $id=$ENV{'QUERY_STRING'};
                     69:     $width = $ENV{'cgi.'.$id.'.WIDTH'};
                     70:     if (!$width) { $width = 400; }
                     71:     $png = $ENV{'cgi.'.$id.'.PNG'};
                     72:     $ps = $ENV{'cgi.'.$id.'.PS'};
                     73:     @JMEstring=&unescape($ENV{'cgi.'.$id.'.JME'});
                     74: } else {
1.9       albertel   75:     @JMEstring = @ARGV;
1.7       albertel   76:     $width = shift @JMEstring;
                     77:     $png = 1;
                     78:     $ps = 1;
                     79: }
1.1       albertel   80: 
1.5       albertel   81: #get objects
1.7       albertel   82: my ($reactants,$modulators,$products)=split('>',$JMEstring[0]);
1.1       albertel   83: 
1.5       albertel   84: my @reactant_structs=split(/\|/,$reactants);
1.7       albertel   85: my @modulator_structs=split(/\|/,$modulators);
1.5       albertel   86: my @product_structs=split(/\|/,$products);
1.1       albertel   87: 
                     88: 
1.7       albertel   89: my @all_structs=(@reactant_structs,@modulator_structs,@product_structs);
1.1       albertel   90: 
1.5       albertel   91: #get size of image and initialize image and globals
                     92: my ($xmin,$xmax,$ymin,$ymax,$maxName,$height,$scale) =
                     93:     &determine_size(@all_structs);
1.1       albertel   94: 
1.7       albertel   95: my $draw_arrow;
                     96: if (@modulator_structs || @product_structs) { $draw_arrow=1; }
                     97: my ($arrow_x1,$arrow_x2,$arrow_y) = (-1e20,1e20,0);
                     98: if ($draw_arrow) {
                     99:     foreach my $struct (@reactant_structs) {
                    100: 	my @bounds =  &determine_size($struct);
                    101: 	if ($arrow_x1 < $bounds[1]) {
                    102: 	    $arrow_x1 = $bounds[1];
                    103: 	    $arrow_y = ($bounds[2] + $bounds[3]) / 2;
                    104: 	}
                    105:     }
                    106:     foreach my $struct (@product_structs) {
                    107: 	my @bounds =  &determine_size($struct);
                    108: 	$arrow_x2 = $bounds[0] if ($arrow_x2 > $bounds[0]);
                    109:     }
                    110: 
                    111:     $arrow_x1 += (1.5+$maxName/2-$xmin);
                    112:     $arrow_x1 *= $scale;
                    113:     $arrow_x2 += (1.5+$maxName/2-$xmin);
                    114:     $arrow_x2 *= $scale; 
                    115:     $arrow_y += (1.0-$ymin);
                    116:     $arrow_y *= $scale;
                    117: }
1.1       albertel  118: 
                    119: # Create a new PostScript object
1.3       albertel  120: my ($im,$white,$black,$gray);
1.7       albertel  121: my $gdAntiAliased;
1.3       albertel  122: if ($png) {
                    123:     $im = new GD::Image($width,$height); 
                    124:     $white = $im->colorAllocate(255,255,255);
                    125:     $black = $im->colorAllocate(0,0,0);
                    126:     $gray = $im->colorAllocate(200,200,200);
1.7       albertel  127:     $gdAntiAliased = $im->colorAllocate(1,1,1);
                    128:     # $im->setAntiAliased($black);
1.3       albertel  129: } elsif ($ps) {
                    130:     $im = new PostScript::Simple(xsize => $xmax-$xmin+3+$maxName,
                    131: 				 ysize => $ymax-$ymin+2,
                    132: 				 clip => 1,
                    133: 				 eps => 1,
                    134: 				 color => 0,
                    135: 				 units => "cm");
                    136: }
1.1       albertel  137: 
1.10    ! albertel  138: my %electrons = ("C",4,"N",5,"P",5,"O",6,"S",6);
1.5       albertel  139: my %font_width = (" ",250,"+",564,"-",500,"0",500,"1",500,"2",500,"3",500,"4",500,"5",500,"6",500,"7",500,"8",500,"9",500,"A",722,"B",667,"C",667,"D",722,"E",611,"F",556,"G",722,"H",722,"I",333,"J",389,"K",722,"L",611,"M",889,"N",722,"O",722,"P",556,"Q",722,"R",667,"S",556,"T",611,"U",722,"V",722,"W",944,"X",722,"Y",722,"Z",611,"a",444,"b",500,"c",444,"d",500,"e",444,"f",333,"g",500,"h",500,"i",278,"j",278,"k",500,"l",278,"m",778,"n",500,"o",500,"p",500,"q",500,"r",333,"s",389,"t",278,"u",500,"v",500,"w",722,"x",500,"y",500,"z",444);
                    140: my $font = '/usr/share/fonts/default/Type1/n021003l.pfb';
                    141: my $pointsize = 20;
                    142: my ($ptsize,@bounds);
                    143: if ($png) {
                    144:     @bounds = GD::Image->stringTTF($black,$font,100,0,0,0,"H");
                    145:     $ptsize = 100*0.662*$pointsize*(2.54/72)*$scale/(@bounds[3]-@bounds[5]);
                    146: }
                    147: 
                    148: #set bond sizes
1.3       albertel  149: my $doubleWidth;
                    150: my $tripleWidth;
1.7       albertel  151: $doubleWidth = 0.10*$scale;
                    152: $tripleWidth = 0.15*$scale;
                    153: 
                    154: # Draw arrow
                    155: 
                    156: if ($draw_arrow) {
                    157:     my $dx = $arrow_x2 - $arrow_x1;
                    158:     if ($png) {
                    159: 	$im->line($arrow_x1+0.25*$dx,$height-$arrow_y,
                    160: 		  $arrow_x2-0.25*$dx,$height-$arrow_y,
                    161: 		  $gdAntiAliased);
                    162: 	$im->line($arrow_x2-0.25*$dx,$height-$arrow_y,
                    163: 		  $arrow_x2-0.25*$dx-fm2cm(500),$height-$arrow_y-fm2cm(300),
                    164: 		  $gdAntiAliased);
                    165: 	$im->line($arrow_x2-0.25*$dx,$height-$arrow_y,
                    166: 		  $arrow_x2-0.25*$dx-fm2cm(500),$height-$arrow_y+fm2cm(300),
                    167: 		  $gdAntiAliased);
                    168: 	
                    169:     } elsif ($ps) {
                    170: 	$im->line($arrow_x1+0.25*$dx,$arrow_y,
                    171: 		  $arrow_x2-0.25*$dx,$arrow_y);
                    172: 	$im->line($arrow_x2-0.25*$dx,$arrow_y,
                    173: 		  $arrow_x2-0.25*$dx-fm2cm(500),$arrow_y-fm2cm(250));
                    174: 	$im->line($arrow_x2-0.25*$dx,$arrow_y,
                    175: 		  $arrow_x2-0.25*$dx-fm2cm(500),$arrow_y+fm2cm(250));
                    176:     }
1.3       albertel  177: }
1.1       albertel  178: 
1.5       albertel  179: 
                    180: foreach my $struct (@all_structs) {
                    181: 
                    182:     my (@name,@x,@y,@atomA,@atomB,@bondType,$natoms,$nbonds);
                    183:     &parse_struct($struct,\@name,\@x,\@y,\@atomA,\@atomB,\@bondType);
                    184:     $natoms=scalar(@x);
                    185:     $nbonds=scalar(@bondType);
                    186: 
1.7       albertel  187: # Scale and move lower left corner to (1.5,1.0)
                    188: 
1.5       albertel  189:     for (my $i = 0; $i < $natoms; $i++) {
1.7       albertel  190: 	$x[$i] += (1.5+$maxName/2-$xmin);
                    191: 	$x[$i] *= $scale; 
                    192: 	$y[$i] += (1.0-$ymin);
                    193: 	$y[$i] *= $scale;
1.5       albertel  194:     }
1.7       albertel  195:     
1.5       albertel  196: # Count bonds
                    197: 
                    198:     my @bonds = map {0} 0..$natoms-1;
                    199:     my @adjacent = map {0} 0..$natoms-1;
                    200:     my @bondsx = map {0} 0..$natoms-1;
                    201:     my @bondsy = map {0} 0..$natoms-1;
1.9       albertel  202:     my @aldehyde = map {0} 0..$natoms-1;
1.5       albertel  203:     for (my $i = 0; $i < $nbonds; $i++) {
1.7       albertel  204: 	$bonds[$atomA[$i]] += ($bondType[$i]>0) ? $bondType[$i] : 1;
                    205: 	$bonds[$atomB[$i]] += ($bondType[$i]>0) ? $bondType[$i] : 1;
1.5       albertel  206: 
1.7       albertel  207: 	$adjacent[$atomA[$i]]++;
                    208: 	$adjacent[$atomB[$i]]++;
1.5       albertel  209:     
1.7       albertel  210: 	$bondsx[$atomA[$i]] += $x[$atomB[$i]] - $x[$atomA[$i]];
                    211: 	$bondsy[$atomA[$i]] += $y[$atomB[$i]] - $y[$atomA[$i]];
                    212: 	$bondsx[$atomB[$i]] += $x[$atomA[$i]] - $x[$atomB[$i]];
                    213: 	$bondsy[$atomB[$i]] += $y[$atomA[$i]] - $y[$atomB[$i]];
1.9       albertel  214: 
                    215: 	if ( @bondType[$i] == 2) {
                    216: 	    @aldehyde[@atomA[$i]] ++ if (@name[@atomB[$i]] eq "O");
                    217: 	    @aldehyde[@atomB[$i]] ++ if (@name[@atomA[$i]] eq "O");
                    218: 	}
                    219: 
1.5       albertel  220:     }
                    221: 
1.9       albertel  222:    
1.5       albertel  223: # Draw bonds
                    224:     for (my $i = 0; $i < $nbonds; $i++) {
1.7       albertel  225: 	my $xa = $x[$atomA[$i]];
                    226: 	my $ya = $y[$atomA[$i]];
                    227: 	my $xb = $x[$atomB[$i]];
                    228: 	my $yb = $y[$atomB[$i]];
1.5       albertel  229: 
                    230: 	my ($sina,$cosa,$dx,$dy);
1.7       albertel  231: 	if ($bondType[$i] != 1) {
1.5       albertel  232: 	    $dx = $xb-$xa;
                    233: 	    $dy = $yb-$ya;
                    234: 	    my $dd = sqrt($dx*$dx + $dy*$dy);
                    235: 	    $sina=$dy/$dd;
                    236: 	    $cosa=$dx/$dd;
                    237: 	}
1.7       albertel  238: 	if    ($bondType[$i] == -2) {
1.5       albertel  239: 	    for (my $t = 0; $t <= 1; $t += 0.1) {
                    240: 		my $xab = $xa + $t*$dx; 
                    241: 		my $yab = $ya + $t*$dy; 
                    242: 		my $xperp = $tripleWidth*$sina*$t;
                    243: 		my $yperp = $tripleWidth*$cosa*$t;
                    244: 		if ($png) {
                    245: 		    $im->line($xab+$xperp,$height-($yab-$yperp),
                    246: 			      $xab-$xperp,$height-($yab+$yperp),
1.7       albertel  247: 			      $gdAntiAliased);
1.5       albertel  248: 		} elsif ($ps) {
                    249: 		    $im->line($xab+$xperp,$yab-$yperp,$xab-$xperp,$yab+$yperp);
                    250: 		}
                    251: 	    }
                    252: 	}
1.7       albertel  253: 	elsif ($bondType[$i] == -1) {
1.5       albertel  254: 	    my $xperp = $tripleWidth*$sina;
                    255: 	    my $yperp = $tripleWidth*$cosa;
1.3       albertel  256: 	    if ($png) {
1.5       albertel  257: 		my $poly = new GD::Polygon;
                    258: 		$poly->addPt($xa,$height-$ya);
                    259: 		$poly->addPt($xb+$xperp,$height-($yb-$yperp));
                    260: 		$poly->addPt($xb-$xperp,$height-($yb+$yperp));
                    261: 		$im->filledPolygon($poly,$black);
1.3       albertel  262: 	    } elsif ($ps) {
1.5       albertel  263: 		$im->polygon({filled=>1},
                    264: 			     $xa,$ya,
                    265: 			     $xb+$xperp,$yb-$yperp,
                    266: 			     $xb-$xperp,$yb+$yperp);
1.3       albertel  267: 	    }
1.1       albertel  268: 	}
1.7       albertel  269: 	elsif ($bondType[$i] == 1) {
1.5       albertel  270: 	    if ($png) {
1.7       albertel  271: 		$im->line($xa,$height-$ya,$xb,$height-$yb,$gdAntiAliased);
1.5       albertel  272: 	    } elsif ($ps) {
                    273: 		$im->line($xa,$ya,$xb,$yb);
                    274: 	    }
1.3       albertel  275: 	}
1.7       albertel  276: 	elsif ($bondType[$i] == 2 &&
                    277: 	       (($adjacent[$atomA[$i]] == 1 && $adjacent[$atomB[$i]] > 2)||
1.9       albertel  278: 		($adjacent[$atomB[$i]] == 1 && $adjacent[$atomA[$i]] > 2)||
                    279: 		@name[@atomA[$i]] eq "O" || @name[@atomB[$i]] eq "O")) {
1.5       albertel  280: 	    # centered bond
                    281: 	    my $xperp = $doubleWidth*$sina;
                    282: 	    my $yperp = $doubleWidth*$cosa;
                    283: 	    if ($png) {
                    284: 		$im->line($xa+$xperp,$height-($ya-$yperp),
                    285: 			  $xb+$xperp,$height-($yb-$yperp),
1.7       albertel  286: 			  $gdAntiAliased);
1.5       albertel  287: 		$im->line($xa-$xperp,$height-($ya+$yperp),
                    288: 			  $xb-$xperp,$height-($yb+$yperp),
1.7       albertel  289: 			  $gdAntiAliased);
1.5       albertel  290: 	    } elsif ($ps) {
                    291: 		$im->line($xa+$xperp,$ya-$yperp,$xb+$xperp,$yb-$yperp);
                    292: 		$im->line($xa-$xperp,$ya+$yperp,$xb-$xperp,$yb+$yperp);
                    293: 	    }
1.3       albertel  294: 	}
1.7       albertel  295: 	elsif ($bondType[$i] == 2) {
1.5       albertel  296: 	    my $xperp = 2*$doubleWidth*$sina;
                    297: 	    my $yperp = 2*$doubleWidth*$cosa;
                    298: 	    if ($png) {
1.7       albertel  299: 		$im->line($xa,$height-$ya,$xb,$height-$yb,$gdAntiAliased);
1.5       albertel  300: 		$im->line($xa+0.1*$dx-$xperp,$height-($ya+0.1*$dy+$yperp),
                    301: 			  $xb-0.1*$dx-$xperp,$height-($yb-0.1*$dy+$yperp),
1.7       albertel  302: 			  $gdAntiAliased);
1.5       albertel  303: 	    } elsif ($ps) {
                    304: 		$im->line($xa,$ya,$xb,$yb);
                    305: 		$im->line($xa+0.1*$dx-$xperp,$ya+0.1*$dy+$yperp,
                    306: 			  $xb-0.1*$dx-$xperp,$yb-0.1*$dy+$yperp);
                    307: 	    }
1.3       albertel  308: 	}
1.7       albertel  309: 	elsif ($bondType[$i] == 3) {
1.5       albertel  310: 	    my $xperp = $tripleWidth*$sina;
                    311: 	    my $yperp = $tripleWidth*$cosa;
                    312: 	    if ($png) {
1.7       albertel  313: 		$im->line($xa,$height-$ya,$xb,$height-$yb,$gdAntiAliased);
1.5       albertel  314: 		$im->line($xa+$xperp,$height-($ya-$yperp),
                    315: 			  $xb+$xperp,$height-($yb-$yperp),
1.7       albertel  316: 			  $gdAntiAliased);
1.5       albertel  317: 		$im->line($xa-$xperp,$height-($ya+$yperp),
                    318: 			  $xb-$xperp,$height-($yb+$yperp),
1.7       albertel  319: 			  $gdAntiAliased);
1.5       albertel  320: 	    } elsif ($ps) {
                    321: 		$im->line($xa,$ya,$xb,$yb);
                    322: 		$im->line($xa+$xperp,$ya-$yperp,$xb+$xperp,$yb-$yperp);
                    323: 		$im->line($xa-$xperp,$ya+$yperp,$xb-$xperp,$yb+$yperp);
                    324: 	    }
                    325: 	}   
1.1       albertel  326:     }
1.3       albertel  327: 
1.5       albertel  328: # Write labels
                    329: 
                    330:     for (my $i = 0; $i < $natoms; $i++) {
                    331: 	my ($formula,$sign,$charge) =
1.7       albertel  332: 	    ($name[$i] =~ /(\w+)([\+|\-])?(\d)?/);
1.5       albertel  333: 	if ($formula ne "C" || $sign ne ""||
1.9       albertel  334: 	    $adjacent[$i] < 2 || ($adjacent[$i] == 2 && $bonds[$i] == 4) || (@aldehyde[$i] == 1 && @bonds[$i] == 3)) {
1.5       albertel  335: 	    # don't show C, unless charged, terminal, or linear
1.10    ! albertel  336: 	    if (exists $electrons{$formula}) {
        !           337: 		# add H atoms to satisfy minimum valence
        !           338: 		my $e = $electrons{$formula};
        !           339: 		$e -= (($charge eq "")? 1 : $charge) if ($sign eq "+");
        !           340: 		$e += (($charge eq "")? 1 : $charge) if ($sign eq "-");
        !           341: 		my $valence = 4 - abs($e-4);
        !           342: 		my $nH = $valence - @bonds[$i];
        !           343: 		$formula .= "H" if ($nH > 0);
        !           344: 		$formula .= $nH if ($nH > 1);
1.5       albertel  345: 	    }
                    346: 	    my @formula = $formula=~ /[A-Z][a-z]?\d*/g;
                    347: 	    
                    348: 	    my $PI = 3.1415;
                    349: 	    my $bondAngle;
1.7       albertel  350: 	    if (abs($bondsy[$i]) < 0.01 && abs($bondsx[$i]) < 0.01) {
1.5       albertel  351: 		$bondAngle = -$PI;
1.1       albertel  352: 	    }
1.5       albertel  353: 	    else {
1.7       albertel  354: 		$bondAngle = atan2($bondsy[$i],$bondsx[$i]);
1.1       albertel  355: 	    }
1.5       albertel  356: 
                    357: 	    my $direction;
1.7       albertel  358: 	    if ($adjacent[$i] < 2) {
                    359: 		$direction = ($bondsx[$i] < 0.01) ? "r" : "l";
1.1       albertel  360: 	    }
                    361: 	    else {
1.5       albertel  362: 		if  ($bondAngle >= -$PI/4 && $bondAngle <= $PI/4) {
                    363: 		    $direction = "l";
                    364: 		}
                    365: 		elsif ($bondAngle > $PI/4 && $bondAngle < 3*$PI/4) {
                    366: 		    $direction = "d";
                    367: 		}
                    368: 		elsif ($bondAngle < -$PI/4 && $bondAngle > -3*$PI/4) {
                    369: 		    $direction = "u";
                    370: 		}
                    371: 		else {
                    372: 		    $direction = "r";
                    373: 		}
1.1       albertel  374: 	    }
                    375: 		
1.5       albertel  376: 	    if ($direction eq "r") {  # direction = right
1.7       albertel  377: 		$formula[0] =~ /([A-Z][a-z]?)(\d*)/;
                    378: 		my $carrige = $x[$i]-stringWidth($1)/2;
1.5       albertel  379: 		foreach (@formula) {
                    380: 		    $_ =~ /([A-Z][a-z]?)(\d*)/;
1.7       albertel  381: 		    $carrige = printElement ($1,$2,$carrige,$y[$i]);
1.5       albertel  382: 		}
1.7       albertel  383: 		printCharge ($sign,$charge,$carrige,$y[$i]) if ($sign ne ""); 
1.5       albertel  384: 	    }
                    385: 	    elsif ($direction eq "l") {  # direction = left, reverse hydrogens
1.7       albertel  386: 		$formula[0] =~ /([A-Z][a-z]?)(\d*)/;
                    387: 		my $carrige = $x[$i]+
1.5       albertel  388: 		    stringWidth($1)/2+stringWidth($2)-stringWidth($formula);
                    389: 		foreach (reverse @formula) {
                    390: 		    $_ =~ /([A-Z][a-z]?)(\d*)/;
1.7       albertel  391: 		    $carrige = printElement ($1,$2,$carrige,$y[$i]);
1.5       albertel  392: 		}
1.7       albertel  393: 		printCharge ($sign,$charge,$carrige,$y[$i]) if ($sign ne ""); 
1.5       albertel  394: 	    }
                    395: 	    elsif ($direction eq "u") { # direction = up
                    396: 		(shift @formula) =~ /([A-Z][a-z]?)(\d*)/;
1.7       albertel  397: 		my $carrige = $x[$i]-stringWidth($1)/2;
                    398: 		$carrige = printElement ($1,$2,$carrige,$y[$i]);
                    399: 		my $y = (@formula > 0) ? $y[$i] + fm2cm(800) : $y[$i];
1.5       albertel  400: 		$carrige =
1.7       albertel  401: 		    (@formula > 0) ? $x[$i]-stringWidth($1)/2 : $carrige;
1.5       albertel  402: 		foreach (@formula) {
                    403: 		    $_ =~ /([A-Z][a-z]?)(\d*)/;
                    404: 		    $carrige = printElement ($1,$2,$carrige,$y);
                    405: 		}
                    406: 		printCharge ($sign,$charge,$carrige,$y) if ($sign ne ""); 
1.1       albertel  407: 	    }
1.5       albertel  408: 	    else { # direction = down
                    409: 		(shift @formula) =~ /([A-Z][a-z]?)(\d*)/;
1.7       albertel  410: 		my $carrige = $x[$i]-stringWidth($1)/2;
                    411: 		$carrige = printElement ($1,$2,$carrige,$y[$i]);
                    412: 		my $y = (@formula > 0) ? $y[$i] + fm2cm(-800) : $y[$i];
1.5       albertel  413: 		$carrige =
1.7       albertel  414: 		    (@formula > 0) ? $x[$i]-stringWidth($1)/2 : $carrige;
1.5       albertel  415: 		foreach (@formula) {
                    416: 		    $_ =~ /([A-Z][a-z]?)(\d*)/;
                    417: 		    $carrige = printElement ($1,$2,$carrige,$y);
                    418: 		}
                    419: 		printCharge ($sign,$charge,$carrige,$y) if ($sign ne ""); 
1.1       albertel  420: 	    }
                    421: 	}
                    422:     }
                    423: }
1.7       albertel  424: 
                    425: if ($loncapa) {
                    426:     if ($png) {
1.1       albertel  427: # make sure we are writing to a binary stream
1.7       albertel  428: 	binmode STDOUT;
1.1       albertel  429: 
                    430: # Convert the image to PNG and print it on standard output
1.7       albertel  431: 	print "Content-type: image/png\n\n";
                    432: 	print $im->png;
                    433:     } elsif ($ps) {
                    434: 	my $psfile = "/home/httpd/perl/tmp/".$id.'.eps';
                    435: 	$im->output($psfile);
                    436: 	print "Content-type: text/html\n\n";
                    437: 	print (<<HTML)
                    438: 	    <html>
                    439: 	    <body>
                    440: 	    Wrote eps file $psfile
                    441: 	    </body>
                    442: 	    </html>
1.3       albertel  443: HTML
1.7       albertel  444:     }
                    445: } else {
                    446:     if ($png) {
                    447: # make sure we are writing to a binary stream
                    448: 	binmode STDOUT;
                    449: # Convert the image to PNG and print it on standard output
                    450: 	print $im->png;
                    451:     } elsif ($ps) {
                    452: 	$im->output("file.ps");
                    453:     }
1.3       albertel  454: }
                    455: 
1.1       albertel  456: sub stringWidth {
                    457:     my ($string) = @_;
                    458:     my $width = 0;
                    459:     while ($string =~ /[A-Za-z]/g) {
1.3       albertel  460: 	if ($png) {
                    461: 	    my @bounds = GD::Image->stringTTF($black,$font,$ptsize,0,0,0,$&);
1.7       albertel  462: 	    $width += $bounds[2]-$bounds[0]+2;
1.3       albertel  463: 	} elsif ($ps) {
1.7       albertel  464: 	    $width += fm2cm($font_width{$&});
1.3       albertel  465: 	}
1.1       albertel  466:     }
                    467:     while ($string =~ /[\d+-]/g) {
1.3       albertel  468: 	if ($png) {
                    469: 	    my @bounds=GD::Image->stringTTF($black,$font,0.6*$ptsize,0,0,0,$&);
1.7       albertel  470: 	    $width += $bounds[2]-$bounds[0]+2;
1.3       albertel  471: 	} elsif ($ps) {
1.7       albertel  472: 	    $width += fm2cm(0.6*$font_width{$&});
1.3       albertel  473: 	}
1.1       albertel  474:     }
                    475:     
                    476:     return $width;
                    477: }
                    478: 
                    479: sub fm2cm {  #font metrics to cm
                    480:     my ($fm) = @_;
1.7       albertel  481:     return $scale*(2.54/72)*$pointsize*$fm/1000;
1.3       albertel  482: }
                    483: 
                    484: sub printElement {
                    485:     if ($png) {
                    486: 	return &printElement_png(@_);
                    487:     } elsif ($ps) {
                    488: 	return &printElement_ps(@_);
                    489:     }
1.1       albertel  490: }
                    491: 
1.3       albertel  492: sub printElement_png {  #element symbol + optional subscript
1.1       albertel  493:     my ($element,$subscript,$x,$y) = @_;
1.2       albertel  494:     my $yy = 662;
1.1       albertel  495: 
                    496:     my @bounds = GD::Image->stringTTF($black,$font,$ptsize,0,
                    497: 				   $x,$height-($y+fm2cm(-$yy/2)),$element);
                    498:     $im->filledRectangle(
1.7       albertel  499: 			 $bounds[6]-1,$bounds[7]-fm2cm(135),
                    500: 			 $bounds[2]+1,$bounds[3]+fm2cm(135),$white);
1.1       albertel  501: 
                    502:     $im->stringTTF($black,$font,$ptsize,0,
                    503: 		   $x,$height-($y+fm2cm(-$yy/2)),$element);
1.7       albertel  504:     $x = $bounds[2] + 1;
1.1       albertel  505: 
                    506:     if ($subscript ne "") {
                    507: 	@bounds = GD::Image->stringTTF($black,$font,0.6*$ptsize,0,
                    508: 	   $x,$height-($y+fm2cm(-0.8*$yy)),$subscript);
                    509: 	$im->filledRectangle(
1.7       albertel  510: 			     $bounds[6]-1,$bounds[7]-fm2cm(45),
                    511: 			     $bounds[2]+1,$bounds[3]+fm2cm(45),$white);
1.1       albertel  512: 	$im->stringTTF($black,$font,0.6*$ptsize,0,
                    513: 				 $x,$height-($y+fm2cm(-0.8*$yy)),$subscript);
                    514:     }
1.7       albertel  515:     $x = $bounds[2] + 1;
1.1       albertel  516: }
                    517: 
1.3       albertel  518: sub printElement_ps {  #element symbol + optional subscript
                    519:     my ($element,$subscript,$x,$y) = @_;
                    520:     $height = 662;
1.7       albertel  521: 
1.3       albertel  522:     $im->setcolour("white");
                    523:     $im->box({filled=>1},
                    524: 	    $x+fm2cm(-30),$y+fm2cm(-$height/2-150),
1.7       albertel  525: 	    $x+stringWidth($element)+fm2cm(50),$y+fm2cm(+$height/2+150));
1.3       albertel  526:     $im->setcolour("black");
                    527:     $im->setfont("Times-Roman",$pointsize);
                    528:     $im->text($x,$y+fm2cm(-$height/2),$element);
1.7       albertel  529:     $x += stringWidth($element);
1.3       albertel  530: 
                    531:     if ($subscript ne "") {
                    532: 	$im->setcolour("white");
                    533: 	$im->box({filled=>1},
                    534: 		$x,$y+fm2cm(-0.8*$height-45),
1.7       albertel  535: 		$x+stringWidth($subscript)+fm2cm(50),$y+fm2cm(-0.2*$height+45));
1.3       albertel  536: 	$im->setcolour("black");
                    537: 	$im->setfont("Times-Roman",0.6*$pointsize);
                    538: 	$im->text($x,$y+fm2cm(-0.8*$height),$subscript);
                    539:     }
1.7       albertel  540:     $x += stringWidth($subscript);
1.3       albertel  541: }
                    542: 
1.1       albertel  543: sub printCharge {
1.3       albertel  544:     if ($png) {
                    545: 	return &printCharge_png(@_);
                    546:     } elsif ($ps) {
                    547: 	return &printCharge_ps(@_);
                    548:     }
                    549: }
                    550: 
                    551: sub printCharge_png {
1.1       albertel  552:     my ($sign,$charge,$x,$y) = @_;
1.2       albertel  553:     my $yy = 662;
1.1       albertel  554: 
1.9       albertel  555:     $sign = "&#8211;" if ($sign eq "-");  # replace by n-dash
1.1       albertel  556:     $charge = "" if ($charge == 1);
                    557:     $charge .= $sign;
                    558:     
                    559:     my @bounds = GD::Image->stringTTF($black,$font,0.6*$ptsize,0,
                    560:        $x,$height-($y+fm2cm(0.2*$yy)),$charge);
                    561:     $im->filledRectangle(
1.7       albertel  562: 			 $bounds[6]-1,$bounds[7]-fm2cm(45),
                    563: 			 $bounds[2]+1,$bounds[3]+fm2cm(45),$white);
1.1       albertel  564: 
                    565:     $im->stringTTF($black,$font,0.6*$ptsize,0,$x,$height-($y+fm2cm(0.2*$yy)),$charge);
1.7       albertel  566:     $x = $bounds[2] + 1;
1.1       albertel  567: }
                    568: 
1.3       albertel  569: sub printCharge_ps {
                    570:     my ($sign,$charge,$x,$y) = @_;
                    571:     $height = 662;
                    572: 
                    573:     $charge = "" if ($charge == 1);
                    574:     $charge .= $sign;
                    575:     
                    576:     $im->setcolour("white");
                    577:     $im->box({filled=>1},
                    578: 	    $x,$y+fm2cm(0.2*$height-45),
1.7       albertel  579: 	    $x+stringWidth($charge)+fm2cm(50),$y+fm2cm(0.8*$height+45));
1.3       albertel  580: 
                    581:     if ($sign eq "-") { # replace by n-dash
                    582: 	chop $charge;
                    583: 	$charge .= "\xb1";
                    584:     }
                    585:     $im->setcolour("black");
                    586:     $im->setfont("Times-Roman",0.6*$pointsize);
                    587:     $im->text($x,$y+fm2cm(0.2*$height),$charge);
1.7       albertel  588:     $x += stringWidth($charge);
1.3       albertel  589: }
1.1       albertel  590: 
1.5       albertel  591: sub determine_size {
1.7       albertel  592: # Find border 
1.5       albertel  593:     my (@all_structs)=@_;
                    594:     my $xmin = my $ymin = 1e20;
                    595:     my $xmax = my $ymax = -1e20;
                    596:     my $maxName = 0;
                    597:     foreach my $struct (@all_structs) {
                    598: 	my (@name,@x,@y,@atomA,@atomB,@bondType,$natoms,$nbonds);
                    599: 	&parse_struct($struct,\@name,\@x,\@y,\@atomA,\@atomB,\@bondType);
                    600: 	$natoms=scalar(@x);
                    601: 	$nbonds=scalar(@bondType);
1.7       albertel  602: 	for (my $i = 0; $i < $natoms; $i++) {
                    603: 	    $xmax = $x[$i] if ($x[$i] > $xmax);
                    604: 	    $xmin = $x[$i] if ($x[$i] < $xmin);
                    605: 	    $ymax = $y[$i] if ($y[$i] > $ymax);
                    606: 	    $ymin = $y[$i] if ($y[$i] < $ymin);
                    607: 	    $name[$i] =~ /(\@{1,2})?(\w+)([\+|\-])?(\d)?/;
1.5       albertel  608: 	    $maxName = length $2 if (length $2 > $maxName);
                    609: 	}
                    610:     }
1.7       albertel  611:     $maxName = ($maxName-3 < 0) ? 0 : $maxName-3;
                    612: 
                    613:     my $scale;
                    614:     if ($png) {
                    615: 	$scale = $width / ($xmax-$xmin+3+$maxName);
                    616:     } elsif ($ps) {
                    617: 	$scale = 1;
                    618:     }
1.5       albertel  619:     my $height = $scale * ($ymax-$ymin+2);
                    620: 
                    621:     return ($xmin,$xmax,$ymin,$ymax,$maxName,$height,$scale);
                    622: 
                    623: }
                    624: 
                    625: sub parse_struct {
                    626:     my ($struct,$name,$x,$y,$atomA,$atomB,$bondType)=@_;
1.6       albertel  627:     $struct=~s/^\s*//;
                    628:     $struct=~s/\s*$//;
                    629:     my @JMEstring = split(/ +/,$struct);
1.5       albertel  630: # parse JME string
                    631:     my $natoms= shift @JMEstring;
                    632:     my $nbonds= shift @JMEstring;
                    633:     for (my $i = 0; $i < $natoms; $i++) {
                    634: 	$$name[$i] = shift @JMEstring;
                    635: 	$$x[$i] = shift @JMEstring;
                    636: 	$$y[$i] = shift @JMEstring;
                    637:     }
                    638: 
                    639:     for (my $i = 0; $i < $nbonds; $i++) {
                    640: 	$$atomA[$i] = (shift @JMEstring)-1;
                    641: 	$$atomB[$i] = (shift @JMEstring)-1;
                    642: 	$$bondType[$i] = shift @JMEstring;
                    643:     }
                    644: }
1.1       albertel  645: 

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>