Annotation of loncom/homework/convertjme.pl, revision 1.2
1.1 albertel 1: #!/usr/bin/perl
2:
3: # Coded by Guy Ashkenazi, guy@fh.huji.ac.il
4: # Based on the work of Peter Ertl, peter.ertl@pharma.novartis.com
5:
1.2 ! albertel 6: use strict;
! 7: use lib '/home/httpd/lib/perl';
1.1 albertel 8: use GD;
1.2 ! albertel 9: use LONCAPA::loncgi();
! 10:
! 11: if (! &LONCAPA::loncgi::check_cookie_and_load_env()) {
! 12: print <<END;
! 13: Content-type: text/html
! 14:
! 15: <html>
! 16: <head><title>Bad Cookie</title></head>
! 17: <body>
! 18: Your cookie information is incorrect.
! 19: </body>
! 20: </html>
! 21: END
! 22: exit;
! 23: }
! 24:
! 25: sub unescape {
! 26: my $str=shift;
! 27: $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
! 28: return $str;
! 29: }
1.1 albertel 30:
31: # read the width and the JME string from the cgi query
1.2 ! albertel 32: my $id=$ENV{'QUERY_STRING'};
! 33: my @JMEstring = split(/ /,&unescape($ENV{'cgi.'.$id.'.JME'}));
! 34: my $width = $ENV{'cgi.'.$id.'.WIDTH'};
! 35: if (!$width) { $width = 200; }
1.1 albertel 36:
37: # parse JME string
38:
1.2 ! albertel 39: my $natoms= shift @JMEstring;
! 40: my $nbonds= shift @JMEstring;
! 41: my (@name,@x,@y);
! 42: for (my $i = 0; $i < $natoms; $i++) {
1.1 albertel 43: @name[$i] = shift @JMEstring;
44: @x[$i] = shift @JMEstring;
45: @y[$i] = shift @JMEstring;
46: }
47:
1.2 ! albertel 48: my (@atomA,@atomB,@bondType);
! 49: for (my $i = 0; $i < $nbonds; $i++) {
1.1 albertel 50: @atomA[$i] = (shift @JMEstring)-1;
51: @atomB[$i] = (shift @JMEstring)-1;
52: @bondType[$i] = shift @JMEstring;
53: }
54:
55: # Find border and move lower left corner to (1.5,1.0)
56:
1.2 ! albertel 57: my $xmin = my $xmax = @x[0];
! 58: my $ymin = my $ymax = $y[0];
! 59: my $maxName = 0;
1.1 albertel 60:
1.2 ! albertel 61: for (my $i = 1; $i < $natoms; $i++) {
1.1 albertel 62: $xmax = @x[$i] if (@x[$i] > $xmax);
63: $xmin = @x[$i] if (@x[$i] < $xmin);
64: $ymax = @y[$i] if (@y[$i] > $ymax);
65: $ymin = @y[$i] if (@y[$i] < $ymin);
66: @name[$i] =~ /(\@{1,2})?(\w+)([\+|\-])?(\d)?/;
67: $maxName = length $2 if (length $2 > $maxName);
68: }
69: $maxName = ($maxName-3 < 0) ? 0 : $maxName-3;
1.2 ! albertel 70: my $scale = $width / ($xmax-$xmin+3+$maxName);
! 71: my $height = $scale * ($ymax-$ymin+2);
1.1 albertel 72:
1.2 ! albertel 73: for (my $i = 0; $i < $natoms; $i++) {
1.1 albertel 74: @x[$i] += (1.5+$maxName/2-$xmin);
75: @x[$i] *= $scale;
76: @y[$i] += (1.0-$ymin);
77: @y[$i] *= $scale;
78: }
79:
80: # Count bonds
81:
1.2 ! albertel 82: my @bonds = map {0} 0..$natoms-1;
! 83: my @adjacent = map {0} 0..$natoms-1;
! 84: my @bondsx = map {0} 0..$natoms-1;
! 85: my @bondsy = map {0} 0..$natoms-1;
! 86: for (my $i = 0; $i < $nbonds; $i++) {
1.1 albertel 87: @bonds[@atomA[$i]] += (@bondType[$i]>0) ? @bondType[$i] : 1;
88: @bonds[@atomB[$i]] += (@bondType[$i]>0) ? @bondType[$i] : 1;
89:
90: @adjacent[@atomA[$i]]++;
91: @adjacent[@atomB[$i]]++;
92:
93: @bondsx[@atomA[$i]] += @x[@atomB[$i]] - @x[@atomA[$i]];
94: @bondsy[@atomA[$i]] += @y[@atomB[$i]] - @y[@atomA[$i]];
95: @bondsx[@atomB[$i]] += @x[@atomA[$i]] - @x[@atomB[$i]];
96: @bondsy[@atomB[$i]] += @y[@atomA[$i]] - @y[@atomB[$i]];
97: }
98:
99: # Create a new PostScript object
1.2 ! albertel 100: my $im = new GD::Image($width,$height);
! 101: my $white = $im->colorAllocate(255,255,255);
! 102: my $black = $im->colorAllocate(0,0,0);
! 103: my $gray = $im->colorAllocate(200,200,200);
1.1 albertel 104: #$gdAntiAliased = $im->colorAllocate(1,1,1);
105: $im->setAntiAliased($black);
106:
107: # Draw bonds
1.2 ! albertel 108: my $doubleWidth = 0.10*$scale;
! 109: my $tripleWidth = 0.15*$scale;
1.1 albertel 110:
1.2 ! albertel 111: for (my $i = 0; $i < $nbonds; $i++) {
! 112: my $xa = @x[@atomA[$i]];
! 113: my $ya = @y[@atomA[$i]];
! 114: my $xb = @x[@atomB[$i]];
! 115: my $yb = @y[@atomB[$i]];
1.1 albertel 116:
1.2 ! albertel 117: my ($sina,$cosa,$dx,$dy);
1.1 albertel 118: if (@bondType[$i] != 1) {
119: $dx = $xb-$xa;
120: $dy = $yb-$ya;
1.2 ! albertel 121: my $dd = sqrt($dx*$dx + $dy*$dy);
1.1 albertel 122: $sina=$dy/$dd;
123: $cosa=$dx/$dd;
124: }
125: if (@bondType[$i] == -2) {
1.2 ! albertel 126: for (my $t = 0; $t <= 1; $t += 0.1) {
! 127: my $xab = $xa + $t*$dx;
! 128: my $yab = $ya + $t*$dy;
! 129: my $xperp = $tripleWidth*$sina*$t;
! 130: my $yperp = $tripleWidth*$cosa*$t;
1.1 albertel 131: $im->line($xab+$xperp,$height-($yab-$yperp),
132: $xab-$xperp,$height-($yab+$yperp),
133: gdAntiAliased);
134: }
135: }
136: elsif (@bondType[$i] == -1) {
1.2 ! albertel 137: my $xperp = $tripleWidth*$sina;
! 138: my $yperp = $tripleWidth*$cosa;
! 139: my $poly = new GD::Polygon;
1.1 albertel 140: $poly->addPt($xa,$height-$ya);
141: $poly->addPt($xb+$xperp,$height-($yb-$yperp));
142: $poly->addPt($xb-$xperp,$height-($yb+$yperp));
143: $im->filledPolygon($poly,$black);
144: }
145: elsif (@bondType[$i] == 1) {
146: $im->line($xa,$height-$ya,$xb,$height-$yb,gdAntiAliased);
147: }
148: elsif (@bondType[$i] == 2 &&
149: ((@adjacent[@atomA[$i]] == 1 && @adjacent[@atomB[$i]] > 2)||
150: (@adjacent[@atomB[$i]] == 1 && @adjacent[@atomA[$i]] > 2))) {
151: # centered bond
1.2 ! albertel 152: my $xperp = $doubleWidth*$sina;
! 153: my $yperp = $doubleWidth*$cosa;
1.1 albertel 154: $im->line($xa+$xperp,$height-($ya-$yperp),
155: $xb+$xperp,$height-($yb-$yperp),
156: gdAntiAliased);
157: $im->line($xa-$xperp,$height-($ya+$yperp),
158: $xb-$xperp,$height-($yb+$yperp),
159: gdAntiAliased);
160: }
161: elsif (@bondType[$i] == 2) {
1.2 ! albertel 162: my $xperp = 2*$doubleWidth*$sina;
! 163: my $yperp = 2*$doubleWidth*$cosa;
1.1 albertel 164: $im->line($xa,$height-$ya,$xb,$height-$yb,gdAntiAliased);
165: $im->line($xa+0.1*$dx-$xperp,$height-($ya+0.1*$dy+$yperp),
166: $xb-0.1*$dx-$xperp,$height-($yb-0.1*$dy+$yperp),
167: gdAntiAliased);
168: }
169: elsif (@bondType[$i] == 3) {
1.2 ! albertel 170: my $xperp = $tripleWidth*$sina;
! 171: my $yperp = $tripleWidth*$cosa;
1.1 albertel 172: $im->line($xa,$height-$ya,$xb,$height-$yb,gdAntiAliased);
173: $im->line($xa+$xperp,$height-($ya-$yperp),
174: $xb+$xperp,$height-($yb-$yperp),
175: gdAntiAliased);
176: $im->line($xa-$xperp,$height-($ya+$yperp),
177: $xb-$xperp,$height-($yb+$yperp),
178: gdAntiAliased);
179: }
180: }
181:
182: # Write labels
183:
1.2 ! albertel 184: my %valence = ("C",4,"N",3,"P",3,"O",2,"S",2);
1.1 albertel 185:
1.2 ! albertel 186: my $font = '/usr/share/fonts/default/Type1/n021003l.pfb';
! 187: my $pointsize = 20;
! 188: my @bounds = GD::Image->stringTTF($black,$font,100,0,0,0,"H");
! 189: my $ptsize = 100*0.662*$pointsize*(2.54/72)*$scale/(@bounds[3]-@bounds[5]);
1.1 albertel 190:
1.2 ! albertel 191: for (my $i = 0; $i < $natoms; $i++) {
1.1 albertel 192: my ($formula,$sign,$charge) =
193: (@name[$i] =~ /(\w+)([\+|\-])?(\d)?/);
194: $sign = "–" if ($sign eq "-"); # replace by n-dash
195:
196: if ($formula ne "C" || $sign ne ""||
197: @adjacent[$i] < 2 || (@adjacent[$i] == 2 && @bonds[$i] == 4)) {
198: # don't show C, unless charged, terminal, or linear
1.2 ! albertel 199: my $nH = 0;
1.1 albertel 200: if (exists $valence{$formula}) {
201: $nH = $valence{$formula} - @bonds[$i];
202: $nH += (($charge eq "")? 1 : $charge) if ($sign eq "+");
203: $nH -= (($charge eq "")? 1 : $charge) if ($sign eq "-");
204: }
205: $formula .= "H" if ($nH > 0);
206: $formula .= $nH if ($nH > 1);
1.2 ! albertel 207: my @formula = $formula=~ /[A-Z][a-z]?\d*/g;
1.1 albertel 208:
1.2 ! albertel 209: my $PI = 3.1415;
! 210: my $bondAngle;
1.1 albertel 211: if (abs(@bondsy[$i]) < 0.01 && abs(@bondsx[$i]) < 0.01) {
212: $bondAngle = -$PI;
213: }
214: else {
215: $bondAngle = atan2(@bondsy[$i],@bondsx[$i]);
216: }
217:
1.2 ! albertel 218: my $direction;
1.1 albertel 219: if (@adjacent[$i] < 2) {
220: $direction = (@bondsx[$i] < 0.01) ? "r" : "l";
221: }
222: else {
223: if ($bondAngle >= -$PI/4 && $bondAngle <= $PI/4) {
224: $direction = "l";
225: }
226: elsif ($bondAngle > $PI/4 && $bondAngle < 3*$PI/4) {
227: $direction = "d";
228: }
229: elsif ($bondAngle < -$PI/4 && $bondAngle > -3*$PI/4) {
230: $direction = "u";
231: }
232: else {
233: $direction = "r";
234: }
235: }
236:
237: if ($direction eq "r") { # direction = right
238: @formula[0] =~ /([A-Z][a-z]?)(\d*)/;
1.2 ! albertel 239: my $carrige = @x[$i]-stringWidth($1)/2;
1.1 albertel 240: foreach (@formula) {
241: $_ =~ /([A-Z][a-z]?)(\d*)/;
242: $carrige = printElement ($1,$2,$carrige,@y[$i]);
243: }
244: printCharge ($sign,$charge,$carrige,@y[$i]) if ($sign ne "");
245: }
246: elsif ($direction eq "l") { # direction = left, reverse hydrogens
247: @formula[0] =~ /([A-Z][a-z]?)(\d*)/;
1.2 ! albertel 248: my $carrige = @x[$i]+
1.1 albertel 249: stringWidth($1)/2+stringWidth($2)-stringWidth($formula);
250: foreach (reverse @formula) {
251: $_ =~ /([A-Z][a-z]?)(\d*)/;
252: $carrige = printElement ($1,$2,$carrige,@y[$i]);
253: }
254: printCharge ($sign,$charge,$carrige,@y[$i]) if ($sign ne "");
255: }
256: elsif ($direction eq "u") { # direction = up
257: (shift @formula) =~ /([A-Z][a-z]?)(\d*)/;
1.2 ! albertel 258: my $carrige = @x[$i]-stringWidth($1)/2;
1.1 albertel 259: $carrige = printElement ($1,$2,$carrige,@y[$i]);
1.2 ! albertel 260: my $y = (@formula > 0) ? @y[$i] + fm2cm(800) : @y[$i];
1.1 albertel 261: $carrige =
262: (@formula > 0) ? @x[$i]-stringWidth($1)/2 : $carrige;
263: foreach (@formula) {
264: $_ =~ /([A-Z][a-z]?)(\d*)/;
265: $carrige = printElement ($1,$2,$carrige,$y);
266: }
267: printCharge ($sign,$charge,$carrige,$y) if ($sign ne "");
268: }
269: else { # direction = down
270: (shift @formula) =~ /([A-Z][a-z]?)(\d*)/;
1.2 ! albertel 271: my $carrige = @x[$i]-stringWidth($1)/2;
1.1 albertel 272: $carrige = printElement ($1,$2,$carrige,@y[$i]);
1.2 ! albertel 273: my $y = (@formula > 0) ? @y[$i] + fm2cm(-800) : @y[$i];
1.1 albertel 274: $carrige =
275: (@formula > 0) ? @x[$i]-stringWidth($1)/2 : $carrige;
276: foreach (@formula) {
277: $_ =~ /([A-Z][a-z]?)(\d*)/;
278: $carrige = printElement ($1,$2,$carrige,$y);
279: }
280: printCharge ($sign,$charge,$carrige,$y) if ($sign ne "");
281: }
282: }
283: }
284:
285: # make sure we are writing to a binary stream
286: binmode STDOUT;
287:
288: # Convert the image to PNG and print it on standard output
289: print "Content-type: image/png\n\n";
290: print $im->png;
291: sub stringWidth {
292: my ($string) = @_;
293: my $width = 0;
294: while ($string =~ /[A-Za-z]/g) {
295: my @bounds = GD::Image->stringTTF($black,$font,$ptsize,0,0,0,$&);
296: $width += @bounds[2]-@bounds[0]+2;
297: }
298: while ($string =~ /[\d+-]/g) {
299: my @bounds = GD::Image->stringTTF($black,$font,0.6*$ptsize,0,0,0,$&);
300: $width += @bounds[2]-@bounds[0]+2;
301: }
302:
303: return $width;
304: }
305:
306: sub fm2cm { #font metrics to cm
307: my ($fm) = @_;
308: return $scale*(2.54/72)*$pointsize*$fm/1000;
309: }
310:
311: sub printElement { #element symbol + optional subscript
312: my ($element,$subscript,$x,$y) = @_;
1.2 ! albertel 313: my $yy = 662;
1.1 albertel 314:
315: my @bounds = GD::Image->stringTTF($black,$font,$ptsize,0,
316: $x,$height-($y+fm2cm(-$yy/2)),$element);
317: $im->filledRectangle(
318: @bounds[6]-1,@bounds[7]-fm2cm(135),
319: @bounds[2]+1,@bounds[3]+fm2cm(135),$white);
320:
321: $im->stringTTF($black,$font,$ptsize,0,
322: $x,$height-($y+fm2cm(-$yy/2)),$element);
323: $x = @bounds[2] + 1;
324:
325: if ($subscript ne "") {
326: @bounds = GD::Image->stringTTF($black,$font,0.6*$ptsize,0,
327: $x,$height-($y+fm2cm(-0.8*$yy)),$subscript);
328: $im->filledRectangle(
329: @bounds[6]-1,@bounds[7]-fm2cm(45),
330: @bounds[2]+1,@bounds[3]+fm2cm(45),$white);
331: $im->stringTTF($black,$font,0.6*$ptsize,0,
332: $x,$height-($y+fm2cm(-0.8*$yy)),$subscript);
333: }
334: $x = @bounds[2] + 1;
335: }
336:
337: sub printCharge {
338: my ($sign,$charge,$x,$y) = @_;
1.2 ! albertel 339: my $yy = 662;
1.1 albertel 340:
341: $charge = "" if ($charge == 1);
342: $charge .= $sign;
343:
344: my @bounds = GD::Image->stringTTF($black,$font,0.6*$ptsize,0,
345: $x,$height-($y+fm2cm(0.2*$yy)),$charge);
346: $im->filledRectangle(
347: @bounds[6]-1,@bounds[7]-fm2cm(45),
348: @bounds[2]+1,@bounds[3]+fm2cm(45),$white);
349:
350: $im->stringTTF($black,$font,0.6*$ptsize,0,$x,$height-($y+fm2cm(0.2*$yy)),$charge);
351: $x = @bounds[2] + 1;
352: }
353:
354:
355:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to convertjme.pl CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / homework