1 program mol2ps;
2 (*
3 mol2ps/mol2svg
4 Norbert Haider, University of Vienna, 2005-2014
5 norbert.haider@univie.ac.at
6
7 with code contributions by
8 Michael Palmer, University of Waterloo
9
10 This software is published under the terms of the GNU General Public
11 License (GPL, see below). For a detailed description of this license,
12 see http://www.gnu.org/copyleft/gpl.html
13
14 This program reads chemical structure files in MDL molfile format
15 and generates high-quality postscript output of the 2D structures.
16 Starting with version 0.2, the program processes also reaction files
17 in MDL rxn and rdf format. Starting with version 0.2a, SVG (scalable
18 vectors graphics) is supported as an alternative output format. Starting
19 from version 0.3, SVG support is enabled by default. To make use of this
20 SVG support, just rename (or copy/hard-link) the mol2ps executable into
21 "mol2svg" (for Windows: "mol2svg.exe").
22
23 The resulting postscript graphics can then be printed or converted
24 into various bitmap formats, using the well-known Ghostscript software.
25
26 For a more detailed description, please visit
27 http://merian.pch.univie.ac.at/~nhaider/cheminf/mol2ps.html
28
29 To a large extent, code of the GPL program, checkmol/matchmol, is
30 reused, for more information please visit the checkmol/matchmol
31 homepage at
32 http://merian.pch.univie.ac.at/~nhaider/cheminf/cmmm.html
33
34
35
36 Compile with fpc (Free Pascal, see http://www.freepascal.org), using
37 the -Sd or -S2 option (Delphi mode; IMPORTANT!)
38
39 example for compilation (with optimization) and installation:
40
41 fpc -S2 -O3 mol2ps.pas
42
43 as "root", do the following:
44
45 cp mol2ps /usr/local/bin/
46 ln /usr/local/bin/mol2ps /usr/local/bin/mol2svg
47 ln /usr/local/bin/mol2ps /usr/local/bin/mol2eps
48
49 Note: do NOT use symbolic links ("ln -s mol2ps mol2svg"), as this will not work!
50
51
52 Version history
53
54 v0.1 basic functionality;
55
56 v0.1a slight adjustments of H positioning
57
58 v0.1b further adjustments of H positioning; print H if bond
59 is marked "up" or "down" (new option --hydrogenonstereo)
60
61 v0.1c added bond type 'C' for complex bonds (a dashed line),
62 bug fix in printPS2DdoubleN()
63
64 v0.1d added support for colored atom labels: new option
65 --color=/path/to/color.conf (a simple ascii file with
66 4 columns, containing the element symbol and RGB values
67 as integers from 0 to 255, space-separated); added support
68 for isotopes and radicals; fixed crash when 2 atoms have
69 identical XYZ coordinates in combination with certain
70 bond types
71
72 v0.1e minor change in representation of isothiocyanates etc.
73 (now shows C for carbon); added missing interpretation for
74 "--autoscale=" option
75
76 v0.1f minor bug fix in printPSdouble(), printPStriple(), printPSchars,
77 write_PS_bonds_and_boxes; added rudimentary support for brackets
78 around (sub)structures; added some debug output; ; added some
79 debug output; merging of some more CSEARCH-related functionality
80
81 v0.2 added support for reactions (MDL rxn and rdf file formats)
82
83 v0.2a minor bug fixes; added rudimentary support for SVG (scalable
84 vector graphics) output (just rename the mol2ps executable into
85 mol2svg; disabled by default); added some support for Sgroups
86
87 v0.2b minor bug fixes; added support for deprecated "A nnn" atom aliases;
88 refined SVG output of labels
89
90 v0.3 changed SVG output to a more compact format; SVG support is no
91 longer a compile-time option, but included by default; minor bug
92 fixes; added SVG comments which enable re-adjustment of width,
93 height and viewbox dimensions
94
95 v0.3a added --showmaps parameter: displays atom-atom mapping numbers in
96 red color (useful only for reactions with atom-atom mapping)
97
98 v0.4 added EPS output option; use buffered output in order to include
99 correct %%BoundingBox and SVG viewbox dimensions (based on a code
100 contribution by Michael Palmer, University of Waterloo); added new
101 command-line options (--output=, --bgcolor=, --scaling=)
102
103 v0.4a fixed a minor color problem in PS mode; fixed a "comma vs. decimal
104 point" issue in all format() calls (i.e., now forcing decimal point
105 as decimal separator, independently of locale settings)
106
107 v0.4b minor change in center_mol (relevant for FlaME-generated rxnfiles);
108
109 ===============================================================================
110 DISCLAIMER
111 This program is free software; you can redistribute it and/or
112 modify it under the terms of the GNU General Public License
113 as published by the Free Software Foundation; either version 2
114 of the License, or (at your option) any later version.
115
116 This program is distributed in the hope that it will be useful,
117 but WITHOUT ANY WARRANTY; without even the implied warranty of
118 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
119 GNU General Public License for more details.
120
121 You should have received a copy of the GNU General Public License
122 along with this program; if not, write to the Free Software Foundation,
123 Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
124 ===============================================================================
125 *)
126
127 //{$DEFINE debug} // uncomment this to enable the -D option
128 {$DEFINE csearch_extensions} // v0.1c (complex bond encoded by MDL "stereo" = 4)
129 //{$DEFINE clean_marvin_r} // converts all atoms of type "R#" into "R"
130
131
132 {$NOTES OFF}
133 {$WARNINGS OFF}
134
135 uses
136 SYSUTILS, MATH, STRUTILS, CLASSES;
137
138
139 const
140 version = '0.4b';
141 max_atoms = 1024;
142 max_bonds = 1024;
143 max_ringsize = 128;
144 max_rings = 1024;
145 max_neighbors = 20; // was 16 in v0.1x
146 max_brackets = 64; // v0.1f
147 max_sgroups = 512; // v0.2a
148 TAB = #26;
149 max_rgbentries = 128; // v0.1d
150
151 rs_sar = 2001; // ring search mode: SAR = set of all rings
152 rs_ssr = 2002; // SSR = set of small rings
153
154 btopo_any = 0; // bond topology
155 btopo_ring = 1; //
156 btopo_chain = 2; //
157 btopo_always_any = 3; // even in "strict mode"
158 btopo_excess_rc = 4; // bond in query and candidate must have same ring count
159 btopo_exact_rc = 5; // bond in candidate must be included in _more_ rings than
160 // the matching bond in the query ==> specific search for
161 // annulated systems
162
163 bstereo_any = 0; // any E/Z isomer (for double bonds)
164 bstereo_xyz = 1; // E/Z match is checked by using XYZ coordinates of the atoms
165 bstereo_up = 11; // flags for single bonds
166 bstereo_down = 16; //
167
168 //================constants
169 blfactor = 75; // relative bond length
170 PX = 1.25;
171
172 dir_right = 1;
173 dir_rightup = 2;
174 dir_up = 3;
175 dir_leftup = 4;
176 dir_left = 5;
177 dir_leftdown = 6;
178 dir_down = 7;
179 dir_rightdown = 8;
180 dirtolerance = 5; // degrees
181
182 defaultfontname = 'Helvetica';
183 defaultfontsize1 = 14;
184 defaultfontsize2 = 9;
185 defaultlinewidth = 1.0;
186 rgbfilename : string = 'color.conf';
187 max_recursion_depth = 500000;
188
189 pmMol2PS = 2001;
190 pmMol2SVG = 2002;
191 svg_factor = 0.21; // was 0.24 initially
192 dd = 1; // decimal digits for SVG XY coordinates
193
194 type
195 str2 = string[2];
196 str3 = string[3];
197 str4 = string[4];
198 str5 = string[5];
199 str8 = string[8];
200 str80 = string[80];
201 atom_rec = record
202 element : str2;
203 atype : str3;
204 x : single;
205 y : single;
206 z : single;
207 x_orig : single;
208 y_orig : single;
209 z_orig : single;
210 formal_charge : integer;
211 real_charge : single;
212 Hexp : smallint; // explicit H count
213 Htot : smallint; // total H count
214 neighbor_count : integer;
215 ring_count : integer;
216 arom : boolean;
217 stereo_care : boolean;
218 heavy : boolean;
219 metal : boolean;
220 nvalences : integer;
221 tag : boolean;
222 hidden : boolean;
223 nucleon_number : integer;
224 radical_type : integer;
225 sg : boolean; // v0.2a
226 alias : str80; // v0.2b
227 a_just : smallint; // v0.2b; 0: left, 1: right, 2: center
228 map_id : integer; // v0.3a
229 end;
230 bond_rec = record
231 a1 : integer;
232 a2 : integer;
233 btype : char;
234 bsubtype : char;
235 a_handle : integer;
236 ring_count : integer;
237 arom : boolean;
238 topo : shortint; // see MDL file description
239 stereo : shortint;
240 mdl_stereo : shortint; // new in v0.c
241 drawn : boolean;
242 hidden : boolean;
243 sg : boolean; // v0.2a
244 end;
245 rgb_record = record
246 element : str2;
247 r : integer;
248 g : integer;
249 b : integer;
250 end;
251 ringpath_type = array[1..max_ringsize] of integer;
252
253 atomlist = array[1..max_atoms] of atom_rec;
254 bondlist = array[1..max_bonds] of bond_rec;
255 ringlist = array[1..max_rings] of ringpath_type;
256 neighbor_rec = array[1..max_neighbors] of integer;
257 molbuftype = array[1..(max_atoms+max_bonds+8192)] of string;
258
259 ringprop_rec = record
260 size : integer;
261 arom : boolean;
262 envelope : boolean;
263 end;
264
265 ringprop_type = array[1..max_rings] of ringprop_rec;
266 p_3d = record
267 x : double;
268 y : double;
269 z : double;
270 end;
271
272 bracket_rec = record // v0.1f
273 id : integer;
274 x1, y1, x2, y2, x3, y3, x4, y4 : single;
275 brtype : integer;
276 brlabel : string;
277 end;
278
279 bracket_type = array[1..max_brackets] of bracket_rec; // v0.1f
280
281 sgroup_rec = record // v0.2a, for all sgroups other than brackets (SRU)
282 id : integer;
283 sgtype : string;
284 anchor : integer;
285 justification : char;
286 sglabel : string;
287 x : single;
288 y : single;
289 end;
290
291 sgroup_type = array[1..max_sgroups] of sgroup_rec; // v0.2a
292 attr_arr = array[1..80] of byte; // v0.2b
293
294 var
295 progmode : integer;
296 progname : string;
297 li : longint;
298 ln : longint;
299
300 rxn_mode : boolean; // v0.2
301 n_reactants : integer; // v0.2
302 n_products : integer; // v0.2
303 x_shift : single; // v0.2
304 x_padding : single; // v0.2
305 y_margin : single; // v0.2
306 x_min : single; // v0.2
307 x_max : single; // v0.2
308 x_dummy : single; // v0.2
309 arrow_length : single; // v0.2
310 i : integer;
311
312 opt_stdin : boolean;
313 opt_debug : boolean;
314 opt_metalrings: boolean;
315 opt_rs : integer;
316
317 opt_autoscale : boolean;
318 opt_autorotate : boolean;
319 opt_autorotate3Donly : boolean;
320 opt_stripH : boolean;
321 opt_Honhetero : boolean;
322 opt_Honmethyl : boolean;
323 opt_Honstereo : boolean;
324 opt_showmolname : boolean;
325 opt_atomnum : boolean;
326 opt_bondnum : boolean;
327 opt_color : boolean;
328 opt_sgroups : boolean; // v0.2a
329 opt_maps : boolean; // v0.3a
330 opt_bgcolor : boolean;
331 opt_eps : boolean;
332
333 filetype : string;
334 molfile : text;
335 molfilename : string;
336 molname : string;
337 //molcomment : string;
338 n_atoms : integer;
339 n_bonds : integer;
340 n_rings : integer; // the number of rings we determined ourselves
341 n_heavyatoms : integer;
342 n_heavybonds : integer;
343 n_brackets : integer; // v0.1f
344 n_sgroups : integer; // v0.2a
345
346 atom : ^atomlist;
347 bond : ^bondlist;
348 ring : ^ringlist;
349 ringprop : ^ringprop_type;
350 bracket : ^bracket_type; // v0.1f
351 sgroup : ^sgroup_type; // v0.2a
352
353 atomtype : str4;
354 newatomtype : str3;
355
356 molbuf : ^molbuftype;
357 molbufindex : integer;
358
359 mol_in_queue : boolean;
360 mol_count : longint;
361 rxn_count : longint; // v0.2
362
363 ringsearch_mode : integer;
364 max_vringsize : integer; // for SSR ring search
365
366 rfile : text;
367 rfile_is_open : boolean;
368 mol_OK : boolean;
369 n_ar : integer;
370 prev_n_ar : integer;
371
372 maxY : double;
373 xoffset, yoffset : single;
374 std_bondlength : double;
375 db_spacingfactor : double;
376 std_blCCsingle : double;
377 std_blCCdouble : double;
378 std_blCCarom : double;
379 fontname : string;
380 fontsize1 : integer;
381 fontsize2 : integer;
382 zorder : array[1..max_atoms] of integer;
383 xrot, yrot, zrot : double;
384 linewidth : double;
385 sf_mol : double;
386 lblmargin : single;
387 rgbtable : array[1..max_rgbentries] of rgb_record;
388 rgbfile : text;
389 recursion_level : longint;
390 //recursion_depth : longint;
391 svg_yoffset : integer;
392 svg_mode : integer; // v0.2c; 1 = full (use a <line> tag for each bond), 2 = compact (use <path>)
393 svg_max_x, svg_max_y, svg_min_y : single; // v0.2c; needed for adjustment of width and height parameters
394 ytrans : integer; // v0.2c
395 max_ytrans : integer; // v0.2c
396 outbuffer : TStringList; // v0.4
397 global_scaling : single; // v0.4
398 bgcolor : rgb_record; // v0.4
399 bgrgbstr : string; // v0.4
400 bboxleft, bboxright, bboxbottom, bboxtop : integer;
401 dotscale, bboxmargin : single;
402 bbleft_int, bbright_int, bbtop_int, bbbottom_int : integer; // v0.4
403 ymargin : integer; // v0.4
404 fsettings : TFormatSettings; // v0.4a
405
406 //================= auxiliary functions & procedures
407
408 procedure init_globals;
409 var
410 i : integer;
411 begin
412 opt_debug := false;
413 opt_stdin := false;
414 opt_metalrings := false;
415 opt_stripH := true;
416 opt_Honhetero := true;
417 opt_Honmethyl := true;
418 opt_Honstereo := true;
419 opt_autoscale := true;
420 opt_autorotate := true;
421 opt_autorotate3dOnly := false;
422 opt_showmolname := false;
423 opt_atomnum := false;
424 opt_bondnum :=false;
425 opt_color := false;
426 opt_sgroups := true; // v0.2a
427 opt_maps := false; // v0.3a
428 opt_bgcolor := false; // v0.4
429 std_blCCsingle := 1.541;
430 std_blCCdouble := 1.337;
431 std_blCCarom := 1.394;
432 std_bondlength := std_blCCdouble;
433 db_spacingfactor:= 0.18;
434 fontname := 'Helvetica';
435 fontsize1 := defaultfontsize1;
436 fontsize2 := defaultfontsize2;
437 linewidth := defaultlinewidth;
438 xrot := 0;
439 yrot := 0;
440 zrot := 0;
441 sf_mol := 1.0;
442 lblmargin := 0.8;
443 opt_rs := rs_sar;
444 ringsearch_mode := rs_sar;
445 rfile_is_open := false;
446 try
447 getmem(molbuf,sizeof(molbuftype));
448 except
449 on e:Eoutofmemory do
450 begin
451 writeln('Not enough memory');
452 halt(4);
453 end;
454 end;
455 for i := 1 to max_rgbentries do
456 begin
457 rgbtable[i].element := '';
458 rgbtable[i].r := 0; rgbtable[i].g := 0; rgbtable[i].b := 0;
459 end;
460 n_brackets := 0; // v0.1f
461 n_sgroups := 0; // v0.2a
462 rxn_mode := false; // v0.2
463 ln := 0; // v0.2
464 x_padding := 1.8; // v0.2
465 y_margin := 1.0; // v0.2
466 arrow_length := 4.0; // v0.2
467 svg_yoffset := 300; // v0.2a maybe this needs some dynamic adjustment
468 svg_mode := 1; // v0.2c use "full" as default, "compact" only for really flat molecules
469 svg_max_x := -10000; // v0.2c
470 svg_max_y := -10000; // v0.2c
471 svg_min_y := 10000; // v0.2c
472 max_ytrans := 0; // v0.2c
473 global_scaling := 1.0; // v0.4
474 bgcolor.r := 255;
475 bgcolor.g := 255;
476 bgcolor.b := 255;
477 // far out starting values for bounding box, will be updated when drawing
478 bboxleft := 2000;
479 bboxright := 0;
480 bboxtop := 0;
481 bboxbottom := 2000;
482 bboxmargin := 2.0;
483 dotscale := 0.24; // to keep the scaling of bbox and dot in sync
484 fsettings.decimalseparator := '.'; // v0.4a force decimal point for floating point numbers
485 end;
486
get_stringwidthnull487 function get_stringwidth(const fs:integer; const tstr:string):double;
488 // returns a relative string width for proportional fonts (as a very crude value)
489 var
490 res, cw : double;
491 i,l : integer;
492 c : char;
493 begin
494 res := 0;
495 l := length(tstr);
496 if (l > 0) then
497 begin
498 for i := 1 to l do
499 begin
500 cw := 1.0;
501 c := tstr[i];
502 if (pos(c,'iIl1.,:;!()[]')>0) then cw := 0.4;
503 if (pos(c,'mMwW')>0) then cw := 1.7;
504 res := res + cw;
505 end;
506 end;
507 res := res * fs; // fs = font size
508 get_stringwidth := res;
509 end;
510
511 procedure writeout(const fmt: string; const args: array of const);
512 begin
513 outbuffer.append(format(fmt, args,fsettings));
514 end;
515
516 procedure writeouts(const stuff: string);
517 begin
518 outbuffer.append(stuff)
519 end;
520
521
522 procedure updatebb(const x: integer; const y: integer);
523 begin
524 if x < bboxleft then bboxleft := x;
525 if x > bboxright then bboxright := x;
526 if y < bboxbottom then bboxbottom := y;
527 if y > bboxtop then bboxtop := y;
528 end;
529
530 procedure calc_PSboundingbox;
531 begin
532 bbleft_int := round(global_scaling*dotscale*bboxleft) - round(bboxmargin*defaultfontsize1);
533 bbbottom_int := round(global_scaling*dotscale*bboxbottom) - round(0.75*bboxmargin*defaultfontsize1);
534 bbright_int := round(global_scaling*dotscale*bboxright) + round(bboxmargin*defaultfontsize1);
535 bbtop_int := round(global_scaling*dotscale*bboxtop) + round(0.75*bboxmargin*defaultfontsize1);
536 end;
537
538 procedure write_PSboundingbox;
539 begin
540 writeln('%%BoundingBox: ',bbleft_int,' ',bbbottom_int,' ',bbright_int,' ',bbtop_int);
541 end;
542
543 procedure write_PSbg;
544 begin
545 writeln;
546 writeln('% use a background as specified by the --bgcolor option');
547 writeln(bgrgbstr,' setrgbcolor');
548 writeln('newpath ',bbleft_int,' ',bbbottom_int,' moveto');
549 writeln(bbright_int,' ',bbbottom_int,' lineto');
550 writeln(bbright_int,' ',bbtop_int,' lineto');
551 writeln(bbleft_int,' ',bbtop_int,' lineto');
552 writeln(bbleft_int,' ',bbbottom_int,' lineto');
553 writeln('closepath fill');
554 writeln('0 0 0 setrgbcolor');
555 end;
556
557 procedure debugoutput(dstr:string);
558 begin
559 if opt_debug then
560 begin
561 if (progmode = pmMol2PS) then writeouts('%% '+dstr); // v0.1b; added "%" (Postscript comment line)
562 if (progmode = pmMol2SVG) then writeouts('<!-- '+dstr+' -->');
563 end;
564 end;
565
566
567 procedure left_trim(var trimstr:string);
568 begin
569 while (length(trimstr)>0) and ((trimstr[1]=' ') or (trimstr[1]=TAB)) do delete(trimstr,1,1);
570 end;
571
572
left_intnull573 function left_int(var trimstr:string):integer;
574 var
575 numstr : string;
576 auxstr : string;
577 auxint, code : integer;
578 begin
579 numstr := '-+0123456789';
580 auxstr := '';
581 auxint := 0;
582 while (length(trimstr)>0) and ((trimstr[1]=' ') or (trimstr[1]=TAB)) do
583 delete(trimstr,1,1);
584 while (length(trimstr)>0) and (pos(trimstr[1],numstr)>0) do
585 begin
586 auxstr := auxstr + trimstr[1];
587 delete(trimstr,1,1);
588 end;
589 val(auxstr,auxint,code);
590 if (code <> 0) then auxint := 0;
591 left_int := auxint;
592 end;
593
594
left_floatnull595 function left_float(var trimstr:string):single; // v0.1f
596 var
597 numstr : string;
598 auxstr : string;
599 auxfloat : single;
600 code : integer;
601 begin
602 numstr := '-+0123456789.';
603 auxstr := '';
604 auxfloat := 0;
605 while (length(trimstr)>0) and ((trimstr[1]=' ') or (trimstr[1]=TAB)) do
606 delete(trimstr,1,1);
607 while (length(trimstr)>0) and (pos(trimstr[1],numstr)>0) do
608 begin
609 auxstr := auxstr + trimstr[1];
610 delete(trimstr,1,1);
611 end;
612 val(auxstr,auxfloat,code);
613 if (code <> 0) then auxfloat := 0;
614 left_float := auxfloat;
615 end;
616
617
618 //============================= geometry functions ==========================
619
dist3dnull620 function dist3d(p1,p2:p_3d):double;
621 var
622 res : double;
623 begin
624 res := sqrt(sqr(p1.x-p2.x) + sqr(p1.y-p2.y) + sqr(p1.z-p2.z));
625 dist3d := res;
626 end;
627
628
subtract_3dnull629 function subtract_3d(p1,p2:p_3d):p_3d;
630 var
631 p : p_3d;
632 begin
633 p.x := p1.x - p2.x;
634 p.y := p1.y - p2.y;
635 p.z := p1.z - p2.z;
636 subtract_3d := p;
637 end;
638
639
add_3dnull640 function add_3d(p1,p2:p_3d):p_3d;
641 var
642 p : p_3d;
643 begin
644 p.x := p1.x + p2.x;
645 p.y := p1.y + p2.y;
646 p.z := p1.z + p2.z;
647 add_3d := p;
648 end;
649
650
651 procedure vec2origin(var p1,p2:p_3d);
652 var
653 p : p_3d;
654 begin
655 p := subtract_3d(p2,p1);
656 p2 := p;
657 p1.x := 0; p1.y := 0; p1.z := 0;
658 end;
659
660
scalar_prodnull661 function scalar_prod(p1,p2,p3:p_3d):double;
662 var
663 p : p_3d;
664 res : double;
665 begin
666 p := subtract_3d(p2,p1);
667 p2 := p;
668 p := subtract_3d(p3,p1);
669 p3 := p;
670 p1.x := 0; p1.y := 0; p1.z := 0;
671 res := p2.x*p3.x + p2.y*p3.y + p2.z*p3.z;
672 scalar_prod := res;
673 end;
674
675
cross_prodnull676 function cross_prod(p1,p2,p3:p_3d):p_3d;
677 var
678 p : p_3d;
679 orig_p1 : p_3d;
680 begin
681 orig_p1 := p1;
682 p := subtract_3d(p2,p1);
683 p2 := p;
684 p := subtract_3d(p3,p1);
685 p3 := p;
686 p.x := p2.y*p3.z - p2.z*p3.y;
687 p.y := p2.z*p3.x - p2.x*p3.z;
688 p.z := p2.x*p3.y - p2.y*p3.x;
689 cross_prod := add_3d(orig_p1,p);
690 end;
691
692
angle_3dnull693 function angle_3d(p1,p2,p3:p_3d):double;
694 var
695 lp1,lp2,lp3 : p_3d;
696 p : p_3d;
697 res : double;
698 magn_1, magn_2 : double;
699 cos_phi : double;
700 begin
701 res := 0;
702 lp1 := p1; lp2 := p2; lp3 := p3;
703 p := subtract_3d(lp2,lp1);
704 lp2 := p;
705 p := subtract_3d(lp3,lp1);
706 lp3 := p;
707 lp1.x := 0; lp1.y := 0; lp1.z := 0;
708 magn_1 := dist3d(lp1,lp2);
709 magn_2 := dist3d(lp1,lp3);
710 if (magn_1 * magn_2 = 0) then
711 begin // emergency exit
712 angle_3d := pi;
713 exit;
714 end;
715 cos_phi := scalar_prod(lp1,lp2,lp3) / (magn_1 * magn_2);
716 if cos_phi < -1 then cos_phi := -1;
717 if cos_phi > 1 then cos_phi := 1;
718 res := arccos(cos_phi);
719 angle_3d := res;
720 end;
721
722
angle_2d_XYnull723 function angle_2d_XY(p1,p2,p3:p_3d):double;
724 var // p1 is the corner
725 lp1,lp2,lp3 : p_3d;
726 p : p_3d;
727 res : double;
728 magn_1, magn_2 : double;
729 cos_phi : double;
730 begin
731 res := 0;
732 lp1 := p1; lp2 := p2; lp3 := p3;
733 lp1.z := 0; lp2.z := 0; lp3.z := 0; // quick and (very) dirty
734 p := subtract_3d(lp2,lp1);
735 lp2 := p;
736 p := subtract_3d(lp3,lp1);
737 lp3 := p;
738 lp1.x := 0; lp1.y := 0; lp1.z := 0;
739 magn_1 := dist3d(lp1,lp2);
740 magn_2 := dist3d(lp1,lp3);
741 if (magn_1 * magn_2 = 0) then
742 begin // emergency exit
743 angle_2d_XY := pi;
744 exit;
745 end;
746 cos_phi := scalar_prod(lp1,lp2,lp3) / (magn_1 * magn_2);
747 if cos_phi < -1 then cos_phi := -1;
748 if cos_phi > 1 then cos_phi := 1;
749 res := arccos(cos_phi);
750 angle_2d_XY := res;
751 end;
752
753
angle_2d_XZnull754 function angle_2d_XZ(p1,p2,p3:p_3d):double;
755 var // p1 is the corner
756 lp1,lp2,lp3 : p_3d;
757 p : p_3d;
758 res : double;
759 magn_1, magn_2 : double;
760 cos_phi : double;
761 begin
762 res := 0;
763 lp1 := p1; lp2 := p2; lp3 := p3;
764 lp1.y := 0; lp2.y := 0; lp3.y := 0; // quick and (very) dirty
765 p := subtract_3d(lp2,lp1);
766 lp2 := p;
767 p := subtract_3d(lp3,lp1);
768 lp3 := p;
769 lp1.x := 0; lp1.y := 0; lp1.z := 0;
770 magn_1 := dist3d(lp1,lp2);
771 magn_2 := dist3d(lp1,lp3);
772 if (magn_1 * magn_2 = 0) then
773 begin // emergency exit
774 angle_2d_XZ := pi;
775 exit;
776 end;
777 cos_phi := scalar_prod(lp1,lp2,lp3) / (magn_1 * magn_2);
778 if cos_phi < -1 then cos_phi := -1;
779 if cos_phi > 1 then cos_phi := 1;
780 res := arccos(cos_phi);
781 angle_2d_XZ := res;
782 end;
783
784
angle_2d_YZnull785 function angle_2d_YZ(p1,p2,p3:p_3d):double;
786 var // p1 is the corner
787 lp1,lp2,lp3 : p_3d;
788 p : p_3d;
789 res : double;
790 magn_1, magn_2 : double;
791 cos_phi : double;
792 begin
793 res := 0;
794 lp1 := p1; lp2 := p2; lp3 := p3;
795 lp1.x := 0; lp2.x := 0; lp3.x := 0; // quick and (very) dirty
796 p := subtract_3d(lp2,lp1);
797 lp2 := p;
798 p := subtract_3d(lp3,lp1);
799 lp3 := p;
800 lp1.x := 0; lp1.y := 0; lp1.z := 0;
801 magn_1 := dist3d(lp1,lp2);
802 magn_2 := dist3d(lp1,lp3);
803 if (magn_1 * magn_2 = 0) then
804 begin // emergency exit
805 angle_2d_YZ := pi;
806 exit;
807 end;
808 cos_phi := scalar_prod(lp1,lp2,lp3) / (magn_1 * magn_2);
809 if cos_phi < -1 then cos_phi := -1;
810 if cos_phi > 1 then cos_phi := 1;
811 res := arccos(cos_phi);
812 angle_2d_YZ := res;
813 end;
814
815
ctorsionnull816 function ctorsion(p1,p2,p3,p4:p_3d):double;
817 // calculates "pseudo-torsion" defined by atoms 3 and 4, being both
818 // attached to atom 2, with respect to axis of atoms 1 and 2
819 var
820 lp1,lp2,lp3,lp4 : p_3d;
821 //d1 : p_3d;
822 c1,c2 : p_3d;
823 res : double;
824 c1xc2, c2xc1 : p_3d;
825 dist1,dist2 : double;
826 sign : double;
827 begin
828 // copy everything into local variables
829 lp1 := p1; lp2 := p2; lp3 := p3; lp4 := p4;
830 // get the cross product vectors
831 c1 := cross_prod(lp2,lp1,lp3);
832 c2 := cross_prod(lp2,lp1,lp4);
833 res := angle_3d(p2,c1,c2);
834 //now check if it is clockwise or anticlockwise:
835 //first, make the cross products of the two cross products c1 and c2 (both ways)
836 c1xc2 := cross_prod(lp2,c1,c2);
837 c2xc1 := cross_prod(lp2,c2,c1);
838 //next, get the distances from these points to our refernce point lp1
839 dist1 := dist3d(lp1,c1xc2);
840 dist2 := dist3d(lp1,c2xc1);
841 if (dist1 <= dist2) then sign := 1 else sign := -1;
842 ctorsion := sign*res;
843 end;
844
845 //====================== end of geometry functions ==========================
846
847 procedure show_usage;
848 var
849 appname : string;
850 outputstr, outputext : string;
851 begin
852 if (progmode = pmMol2PS) then
853 begin
854 appname := 'mol2ps';
855 outputstr := 'Postscript';
856 outputext := 'ps';
857 end else
858 begin
859 appname := 'mol2ps';
860 appname := 'mol2svg';
861 outputstr := 'SVG';
862 outputext := 'svg';
863 end;
864 writeln;
865 writeln(appname,' version ',version,' N. Haider 2014');
866 writeln('Usage: ',appname,' [options] <inputfile>');
867 writeln(' where <inputfile> is the file containing the molecular structure');
868 writeln(' (supported formats: MDL *.mol or *.sdf, Alchemy *.mol, Sybyl *.mol2)');
869 writeln(' if <inputfile> is "-" (without quotes), the program reads from standard input');
870 writeln;
871 writeln('valid options are:');
872 writeln(' -R (reaction mode, for MDL rxn and rdf files)');
873 writeln(' --font=<Helvetica|Times>, default: Helvetica');
874 writeln(' --fontsize=<any number in points>, default: 14');
875 writeln(' --fontsizesmall=<any number in points>, default: 9 (for subscripts)');
876 writeln(' --linewidth=<n.n>, default: 1.0 (linewidth in points; use 1 decimal)');
877 writeln(' --rotate=<auto|auto3Donly|n,n,n>, default: auto (n,n,n specifies the');
878 writeln(' angles to rotate the molecule around the X, Y, and Z axis (in degrees)');
879 writeln(' --autoscale=<on|off>, default: on (scales the molecule to fit the natural');
880 writeln(' C-C bond length)');
881 writeln(' --striphydrogen=<on|off>, default: on (strips all explicit H atoms)');
882 writeln(' --hydrogenonhetero=<on|off>, default: on (adds H to all hetero atoms)');
883 writeln(' --hydrogenonmethyl=<on|off>, default: on (adds H to all methyl C atoms)');
884 writeln(' --hydrogenonstereo=<on|off>, default: on (shows H if bond is "up" or "down")');
885 writeln(' --showmolname=<on|off>, default: off (prints name above the structure)');
886 writeln(' --atomnumbers=<on|off>, default: off (prints atom numbers)');
887 writeln(' --bondnumbers=<on|off>, default: off (prints bond numbers)');
888 writeln(' --sgroups=<on|off>, default: on (uses Sgroup abbreviations if present)');
889 writeln(' --showmaps=<on|off>, default: off (prints atom-atom mapping numbers)');
890 writeln(' --color=</path/to/color.conf>, default: no colors for atom labels');
891 writeln(' --bgcolor=<white|gray|n,n,n> where n,n,n are the RGB values (0-255)');
892 writeln(' --scaling=<n.n>, default: 1.0 (any scaling factor from 0.1 to 10.0)');
893 writeln(' --output=<ps|eps|svg>, default depends on prog name (mol2ps, mol2eps, mol2svg)');
894 writeln;
895 writeln(outputstr,' output will be written to standard output. To write it to a');
896 writeln('file, enter something like the following:');
897 writeln(appname,' [options] mymolecule.mol > mymolecule.',outputext);
898 writeln;
899 end;
900
901
902 procedure parse_args;
903 var
904 p : integer;
905 parstr : string;
906 tmpstr : string;
907 valstr : string;
908 xvalstr, yvalstr, zvalstr : string;
909 tmpint, code : integer;
910 tmpdbl : double;
911 int1, int2, int3 : integer;
912 begin
913 tmpstr := '';
914 for p := 1 to paramcount do
915 begin
916 parstr := paramstr(p);
917 if (p < paramcount) then
918 begin
919 if (pos('-R',parstr)>0) then rxn_mode := true;
920 if (pos('--',parstr)=1) then
921 begin
922 tmpstr := paramstr(p);
923 left_trim(tmpstr);
924 tmpstr := lowercase(tmpstr);
925 if (pos('--font=',tmpstr)=0) and
926 (pos('--fontsize=',tmpstr)=0) and
927 (pos('--fontsizesmall=',tmpstr)=0) and
928 (pos('--linewidth=',tmpstr)=0) and
929 (pos('--rotate=',tmpstr)=0) and
930 (pos('--autoscale=',tmpstr)=0) and
931 (pos('--striphydrogen=',tmpstr)=0) and
932 (pos('--hydrogenonhetero=',tmpstr)=0) and
933 (pos('--hydrogenonmethyl=',tmpstr)=0) and
934 (pos('--atomnumbers=',tmpstr)=0) and
935 (pos('--bondnumbers=',tmpstr)=0) and
936 (pos('--showmolname=',tmpstr)=0) and
937 (pos('--sgroups=',tmpstr)=0) and
938 (pos('--showmaps=',tmpstr)=0) and
939 (pos('--scaling=',tmpstr)=0) and
940 (pos('--output=',tmpstr)=0) and
941 (pos('--bgcolor=',tmpstr)=0) and
942 (pos('--color=',tmpstr)=0) then
943 begin
944 show_usage;
945 halt(1);
946 end;
947 if pos('--font=',tmpstr)>0 then
948 begin
949 if pos('=helvetica',tmpstr)>0 then
950 begin
951 fontname := 'Helvetica';
952 end else
953 begin
954 if pos('=times',tmpstr)>0 then
955 begin
956 if progmode = pmMol2PS then fontname := 'Times Roman';
957 if progmode = pmMol2SVG then fontname := 'Times';
958 end else fontname := defaultfontname;
959 end;
960 end;
961 if pos('--fontsize=',tmpstr)>0 then
962 begin
963 valstr := tmpstr;
964 delete(valstr,1,pos('=',tmpstr));
965 trimleft(valstr); trimright(valstr);
966 val(valstr,tmpint,code);
967 if (code = 0) then
968 begin
969 if (tmpint >= 6) and (tmpint <= 64) then
970 begin
971 fontsize1 := tmpint;
972 end;
973 end;
974 end;
975 if pos('--fontsizesmall=',tmpstr)>0 then
976 begin
977 valstr := tmpstr;
978 delete(valstr,1,pos('=',tmpstr));
979 trimleft(valstr); trimright(valstr);
980 val(valstr,tmpint,code);
981 if (code = 0) then
982 begin
983 if (tmpint >= 6) and (tmpint <= 64) then
984 begin
985 fontsize2 := tmpint;
986 end;
987 end;
988 end;
989 if pos('--linewidth=',tmpstr)>0 then
990 begin
991 valstr := tmpstr;
992 delete(valstr,1,pos('=',tmpstr));
993 trimleft(valstr); trimright(valstr);
994 val(valstr,tmpdbl,code);
995 if (code = 0) then
996 begin
997 if (tmpdbl >= 0.1) and (tmpdbl <= 10) then
998 begin
999 linewidth := tmpdbl;
1000 end;
1001 end;
1002 end;
1003 if pos('--rotate=',tmpstr)>0 then
1004 begin
1005 opt_autorotate := false;
1006 opt_autorotate3Donly := false;
1007 valstr := tmpstr;
1008 delete(valstr,1,pos('=',tmpstr));
1009 trimleft(valstr); trimright(valstr);
1010 if (valstr = 'auto') or (valstr = 'auto3Donly') then
1011 begin
1012 if (valstr = 'auto') then opt_autorotate := true;
1013 if (valstr = 'auto3Donly') then opt_autorotate3Donly := true;
1014 end else
1015 begin
1016 opt_autorotate := false;
1017 opt_autorotate3Donly := false;
1018 xvalstr := ''; yvalstr := ''; zvalstr := '';
1019 while (length(valstr)>0) and (valstr[1] <> ',') do
1020 begin
1021 xvalstr := xvalstr + valstr[1];
1022 delete(valstr,1,1);
1023 end;
1024 while (length(valstr)>0) and (valstr[1] = ',') do delete(valstr,1,1);
1025 while (length(valstr)>0) and (valstr[1] <> ',') do
1026 begin
1027 yvalstr := yvalstr + valstr[1];
1028 delete(valstr,1,1);
1029 end;
1030 while (length(valstr)>0) and (valstr[1] = ',') do delete(valstr,1,1);
1031 while (length(valstr)>0) and (valstr[1] <> ',') do
1032 begin
1033 zvalstr := zvalstr + valstr[1];
1034 delete(valstr,1,1);
1035 end;
1036 val(xvalstr,tmpdbl,code);
1037 if (code = 0) then
1038 begin
1039 xrot := degtorad(tmpdbl);
1040 end else xrot := 0;
1041 val(yvalstr,tmpdbl,code);
1042 if (code = 0) then
1043 begin
1044 yrot := degtorad(tmpdbl);
1045 end else yrot := 0;
1046 val(zvalstr,tmpdbl,code);
1047 if (code = 0) then
1048 begin
1049 zrot := degtorad(tmpdbl);
1050 end else zrot := 0;
1051 end;
1052 end; // rotate=
1053 if pos('--autoscale=',tmpstr)>0 then
1054 begin
1055 valstr := tmpstr;
1056 delete(valstr,1,pos('=',tmpstr));
1057 trimleft(valstr); trimright(valstr);
1058 if (valstr = 'on') then opt_autoscale := true;
1059 if (valstr = 'off') then opt_autoscale := false;
1060 end;
1061 if pos('--striphydrogen=',tmpstr)>0 then
1062 begin
1063 valstr := tmpstr;
1064 delete(valstr,1,pos('=',tmpstr));
1065 trimleft(valstr); trimright(valstr);
1066 if (valstr = 'on') then opt_stripH := true;
1067 if (valstr = 'off') then opt_stripH := false;
1068 end;
1069 if pos('--hydrogenonhetero=',tmpstr)>0 then
1070 begin
1071 valstr := tmpstr;
1072 delete(valstr,1,pos('=',tmpstr));
1073 trimleft(valstr); trimright(valstr);
1074 if (valstr = 'on') then opt_Honhetero := true;
1075 if (valstr = 'off') then opt_Honhetero := false;
1076 end;
1077 if pos('--hydrogenonmethyl=',tmpstr)>0 then
1078 begin
1079 valstr := tmpstr;
1080 delete(valstr,1,pos('=',tmpstr));
1081 trimleft(valstr); trimright(valstr);
1082 if (valstr = 'on') then opt_Honmethyl := true;
1083 if (valstr = 'off') then opt_Honmethyl := false;
1084 end;
1085 if pos('--hydrogenonstereo=',tmpstr)>0 then
1086 begin
1087 valstr := tmpstr;
1088 delete(valstr,1,pos('=',tmpstr));
1089 trimleft(valstr); trimright(valstr);
1090 if (valstr = 'on') then opt_Honstereo := true;
1091 if (valstr = 'off') then opt_Honstereo := false;
1092 end;
1093 if pos('--showmolname=',tmpstr)>0 then
1094 begin
1095 valstr := tmpstr;
1096 delete(valstr,1,pos('=',tmpstr));
1097 trimleft(valstr); trimright(valstr);
1098 if (valstr = 'on') then opt_showmolname := true;
1099 if (valstr = 'off') then opt_showmolname := false;
1100 end;
1101 if pos('--atomnumbers=',tmpstr)>0 then
1102 begin
1103 valstr := tmpstr;
1104 delete(valstr,1,pos('=',tmpstr));
1105 trimleft(valstr); trimright(valstr);
1106 if (valstr = 'on') then opt_atomnum := true;
1107 if (valstr = 'off') then opt_atomnum := false;
1108 end;
1109 if pos('--bondnumbers=',tmpstr)>0 then
1110 begin
1111 valstr := tmpstr;
1112 delete(valstr,1,pos('=',tmpstr));
1113 trimleft(valstr); trimright(valstr);
1114 if (valstr = 'on') then opt_bondnum := true;
1115 if (valstr = 'off') then opt_bondnum := false;
1116 end;
1117 if pos('--color=',tmpstr)>0 then
1118 begin
1119 valstr := tmpstr;
1120 delete(valstr,1,pos('=',tmpstr));
1121 trimleft(valstr); trimright(valstr);
1122 rgbfilename := valstr;
1123 opt_color := true;
1124 end;
1125 if pos('--sgroups=',tmpstr)>0 then // v0.2a
1126 begin
1127 valstr := tmpstr;
1128 delete(valstr,1,pos('=',tmpstr));
1129 trimleft(valstr); trimright(valstr);
1130 if (valstr = 'on') then opt_sgroups := true;
1131 if (valstr = 'off') then opt_sgroups := false;
1132 end;
1133 if pos('--showmaps=',tmpstr)>0 then // v0.3a
1134 begin
1135 valstr := tmpstr;
1136 delete(valstr,1,pos('=',tmpstr));
1137 trimleft(valstr); trimright(valstr);
1138 if (valstr = 'on') then opt_maps := true;
1139 if (valstr = 'off') then opt_maps := false;
1140 end;
1141 if pos('--scaling=',tmpstr)>0 then
1142 begin
1143 valstr := tmpstr;
1144 delete(valstr,1,pos('=',tmpstr));
1145 trimleft(valstr); trimright(valstr);
1146 val(valstr,tmpdbl,code);
1147 if (code = 0) then
1148 begin
1149 if (tmpdbl >= 0.1) and (tmpdbl <= 10) then
1150 begin
1151 global_scaling := tmpdbl;
1152 end;
1153 end;
1154 end;
1155 if pos('--bgcolor=',tmpstr)>0 then
1156 begin
1157 valstr := tmpstr;
1158 delete(valstr,1,pos('=',tmpstr));
1159 trimleft(valstr); trimright(valstr);
1160 if (valstr = 'white') or (valstr = 'gray') then
1161 begin
1162 opt_bgcolor := true;
1163 if (valstr = 'white') then
1164 begin
1165 bgcolor.r := 255;
1166 bgcolor.g := 255;
1167 bgcolor.b := 255;
1168 end;
1169 if (valstr = 'gray') then
1170 begin
1171 bgcolor.r := 224;
1172 bgcolor.g := 224;
1173 bgcolor.b := 224;
1174 end;
1175 end else
1176 begin
1177 xvalstr := ''; yvalstr := ''; zvalstr := '';
1178 while (length(valstr)>0) and (valstr[1] <> ',') do
1179 begin
1180 xvalstr := xvalstr + valstr[1];
1181 delete(valstr,1,1);
1182 end;
1183 while (length(valstr)>0) and (valstr[1] = ',') do delete(valstr,1,1);
1184 while (length(valstr)>0) and (valstr[1] <> ',') do
1185 begin
1186 yvalstr := yvalstr + valstr[1];
1187 delete(valstr,1,1);
1188 end;
1189 while (length(valstr)>0) and (valstr[1] = ',') do delete(valstr,1,1);
1190 while (length(valstr)>0) and (valstr[1] <> ',') do
1191 begin
1192 zvalstr := zvalstr + valstr[1];
1193 delete(valstr,1,1);
1194 end;
1195 val(xvalstr,int1,code);
1196 if (code <> 0) then int1 := -1;
1197 val(yvalstr,int2,code);
1198 if (code <> 0) then int2 := -1;
1199 val(zvalstr,int3,code);
1200 if (code <> 0) then int3 := -1;
1201 if ((int1 >= 0) and (int1 <= 255) and
1202 (int2 >= 0) and (int2 <= 255) and
1203 (int3 >= 0) and (int3 <= 255)) then
1204 begin
1205 opt_bgcolor := true;
1206 bgcolor.r := int1;
1207 bgcolor.g := int2;
1208 bgcolor.b := int3;
1209 end;
1210 end;
1211 end; // bgcolor=
1212 if pos('--output=',tmpstr)>0 then
1213 begin
1214 if pos('=ps',tmpstr)>0 then
1215 begin
1216 progmode := pmMol2PS;
1217 opt_eps := false;
1218 end else
1219 begin
1220 if pos('=eps',tmpstr)>0 then
1221 begin
1222 progmode := pmMol2PS;
1223 opt_eps := true;
1224 end else progmode := pmMol2SVG;
1225 end;
1226 end;
1227 // some more options still to come...
1228 end;
1229 {$IFDEF debug}
1230 if (parstr = '-D') then opt_debug := true; // v0.1f
1231 {$ENDIF}
1232 end else
1233 begin
1234 if (pos('-',parstr)=1) then
1235 begin
1236 if (length(parstr)>1) and (rxn_mode = false) then
1237 begin
1238 show_usage;
1239 halt(1);
1240 end else
1241 begin
1242 opt_stdin := true;
1243 end;
1244 end else
1245 begin
1246 opt_stdin := false;
1247 molfilename := parstr;
1248 end;
1249 end;
1250 end;
1251 end;
1252
1253
1254 //============== input-related functions & procedures =====================
1255
get_filetypenull1256 function get_filetype(f:string):string;
1257 var
1258 rline : string;
1259 auxstr : string;
1260 i : integer;
1261 mdl1 : boolean;
1262 ri : integer;
1263 sepcount : integer;
1264 begin
1265 auxstr := 'unknown';
1266 i := li; mdl1 := false;
1267 ri := li -1;
1268 sepcount := 0;
1269 while (ri < molbufindex) and (sepcount < 1) do
1270 begin
1271 inc(ri);
1272 rline := molbuf^[ri];
1273 if (pos('$$$$',rline)>0) then inc(sepcount);
1274 if (i = li) and (copy(rline,7,5)='ATOMS')
1275 and (copy(rline,20,5)='BONDS')
1276 and (copy(rline,33,7)='CHARGES') then
1277 begin
1278 auxstr := 'alchemy';
1279 end;
1280 if (i = li+3) // and (copy(rline,31,3)='999')
1281 and (copy(rline,35,5)='V2000') then mdl1 := true;
1282 if (i = li+1) and (copy(rline,3,6)='-ISIS-') then mdl1 := true;
1283 if (i = li+1) and (copy(rline,3,8)='WLViewer') then mdl1 := true;
1284 if (i = li+1) and (copy(rline,3,8)='CheckMol') then mdl1 := true;
1285 if (i = li+1) and (copy(rline,3,8)='CATALYST') then
1286 begin
1287 mdl1 := true;
1288 auxstr := 'mdl';
1289 end;
1290 if (pos('M END',rline)=1) or mdl1 then
1291 begin
1292 auxstr := 'mdl';
1293 end;
1294 if pos('@<TRIPOS>MOLECULE',rline)>0 then
1295 begin
1296 auxstr := 'sybyl';
1297 end;
1298 inc(i);
1299 end;
1300 // try to identify non-conformant SD-files
1301 if (auxstr = 'unknown') and (sepcount > 0) then auxstr := 'mdl';
1302 get_filetype := auxstr;
1303 end;
1304
1305
1306 procedure zap_molecule;
1307 begin
1308 try
1309 if atom <> nil then
1310 begin
1311 freemem(atom,n_atoms*sizeof(atom_rec));
1312 atom := nil;
1313 end;
1314 if bond <> nil then
1315 begin
1316 freemem(bond,n_bonds*sizeof(bond_rec));
1317 bond := nil;
1318 end;
1319 if ring <> nil then
1320 begin
1321 freemem(ring,sizeof(ringlist));
1322 ring := nil;
1323 end;
1324 if ringprop <> nil then
1325 begin
1326 freemem(ringprop,sizeof(ringprop_type));
1327 ringprop := nil;
1328 end;
1329 if bracket <> nil then // v0.1f
1330 begin
1331 freemem(bracket,sizeof(bracket_type));
1332 bracket := nil;
1333 end;
1334 if sgroup <> nil then // v0.2a
1335 begin
1336 freemem(sgroup,sizeof(sgroup_type));
1337 sgroup := nil;
1338 end;
1339 except
1340 on e:Einvalidpointer do begin end;
1341 end;
1342 n_atoms := 0;
1343 n_bonds := 0;
1344 n_rings := 0;
1345 n_brackets := 0; // v0.1f
1346 n_sgroups := 0; // v0.2a
1347 end;
1348
1349
is_heavyatomnull1350 function is_heavyatom(id:integer):boolean;
1351 var
1352 r : boolean;
1353 el : str2;
1354 begin
1355 r := true;
1356 el := atom^[id].element;
1357 if (el = 'H ') or (el = 'DU') or (el = 'LP') then r := false;
1358 if (el = 'H ') and (atom^[id].nucleon_number > 1) then r:= true;
1359 is_heavyatom := r;
1360 end;
1361
1362
is_metalnull1363 function is_metal(id:integer):boolean;
1364 var
1365 r : boolean;
1366 el : str2;
1367 begin
1368 r := false;
1369 el := atom^[id].element;
1370 if (el = 'LI') or (el = 'NA') or (el = 'K ') or (el = 'RB') or (el = 'CS') or
1371 (el = 'BE') or (el = 'MG') or (el = 'CA') or (el = 'SR') or (el = 'BA') or
1372 (el = 'TI') or (el = 'ZR') or (el = 'CR') or (el = 'MO') or (el = 'MN') or
1373 (el = 'FE') or (el = 'CO') or (el = 'NI') or (el = 'PD') or (el = 'PT') or
1374 (el = 'SN') or (el = 'CU') or (el = 'AG') or (el = 'AU') or (el = 'ZN') or
1375 (el = 'CD') or (el = 'HG') or (el = 'AL') or (el = 'SN') or (el = 'PB') or
1376 (el = 'SB') or (el = 'BI') // etc. etc.
1377 then r := true;
1378 is_metal := r;
1379 end;
1380
1381
get_nvalencesnull1382 function get_nvalences(a_el:str2):integer;
1383 // preliminary version; should be extended to element/atomtype
1384 var
1385 res : integer;
1386 begin
1387 res := 1;
1388 if a_el = 'H ' then res := 1;
1389 if a_el = 'D ' then res := 1;
1390 if a_el = 'C ' then res := 4;
1391 if a_el = 'N ' then res := 3;
1392 if a_el = 'O ' then res := 2;
1393 if a_el = 'S ' then res := 2;
1394 if a_el = 'SE' then res := 2;
1395 if a_el = 'TE' then res := 2;
1396 if a_el = 'P ' then res := 3;
1397 if a_el = 'F ' then res := 1;
1398 if a_el = 'CL' then res := 1;
1399 if a_el = 'BR' then res := 1;
1400 if a_el = 'I ' then res := 1;
1401 if a_el = 'B ' then res := 3;
1402 if a_el = 'LI' then res := 1;
1403 if a_el = 'NA' then res := 1;
1404 if a_el = 'K ' then res := 1;
1405 if a_el = 'CA' then res := 2;
1406 if a_el = 'SR' then res := 2;
1407 if a_el = 'MG' then res := 2;
1408 if a_el = 'FE' then res := 3;
1409 if a_el = 'MN' then res := 2;
1410 if a_el = 'HG' then res := 2;
1411 if a_el = 'SI' then res := 4;
1412 if a_el = 'SN' then res := 4;
1413 if a_el = 'ZN' then res := 2;
1414 if a_el = 'CU' then res := 2;
1415 if a_el = 'A ' then res := 4;
1416 if a_el = 'Q ' then res := 4;
1417 get_nvalences := res;
1418 end;
1419
1420
convert_typenull1421 function convert_type(oldtype : str4):str3;
1422 var
1423 i : integer;
1424 newtype : str3;
1425 begin
1426 newtype := copy(oldtype,1,3);
1427 for i := 1 to 3 do newtype[i] := upcase(newtype[i]);
1428 if newtype[1] = '~' then newtype := 'VAL';
1429 If newtype[1] = '*' then newtype := 'STR';
1430 convert_type := newtype;
1431 end;
1432
1433
convert_sybtypenull1434 function convert_sybtype(oldtype : str5):str3;
1435 var
1436 newtype : str3;
1437 begin
1438 // NewType := Copy(OldType,1,3);
1439 // For i := 1 To 3 Do NewType[i] := UpCase(NewType[i]);
1440 // If NewType[1] = '~' Then NewType := 'VAL';
1441 // If NewType[1] = '*' Then NewType := 'STR';
1442 newtype := 'DU ';
1443 if oldtype = 'H ' then newtype := 'H ';
1444 if oldtype = 'C.ar ' then newtype := 'CAR';
1445 if oldtype = 'C.2 ' then newtype := 'C2 ';
1446 if oldtype = 'C.3 ' then newtype := 'C3 ';
1447 if oldtype = 'C.1 ' then newtype := 'C1 ';
1448 if oldtype = 'O.2 ' then newtype := 'O2 ';
1449 if oldtype = 'O.3 ' then newtype := 'O3 ';
1450 if oldtype = 'O.co2' then newtype := 'O2 ';
1451 if oldtype = 'O.spc' then newtype := 'O3 ';
1452 if oldtype = 'O.t3p' then newtype := 'O3 ';
1453 if oldtype = 'N.1 ' then newtype := 'N1 ';
1454 if oldtype = 'N.2 ' then newtype := 'N2 ';
1455 if oldtype = 'N.3 ' then newtype := 'N3 ';
1456 if oldtype = 'N.pl3' then newtype := 'NPL';
1457 if oldtype = 'N.4 ' then newtype := 'N3+';
1458 if oldtype = 'N.am ' then newtype := 'NAM';
1459 if oldtype = 'N.ar ' then newtype := 'NAR';
1460 if oldtype = 'F ' then newtype := 'F ';
1461 if oldtype = 'Cl ' then newtype := 'CL ';
1462 if oldtype = 'Br ' then newtype := 'BR ';
1463 if oldtype = 'I ' then newtype := 'I ';
1464 if oldtype = 'Al ' then newtype := 'AL ';
1465 if oldtype = 'ANY ' then newtype := 'A ';
1466 if oldtype = 'Ca ' then newtype := 'CA ';
1467 if oldtype = 'Du ' then newtype := 'DU ';
1468 if oldtype = 'Du.C ' then newtype := 'DU ';
1469 if oldtype = 'H.spc' then newtype := 'H ';
1470 if oldtype = 'H.t3p' then newtype := 'H ';
1471 if oldtype = 'HAL ' then newtype := 'Cl ';
1472 if oldtype = 'HET ' then newtype := 'Q ';
1473 if oldtype = 'HEV ' then newtype := 'DU ';
1474 if oldtype = 'K ' then newtype := 'K ';
1475 if oldtype = 'Li ' then newtype := 'LI ';
1476 if oldtype = 'LP ' then newtype := 'LP ';
1477 if oldtype = 'Na ' then newtype := 'NA ';
1478 if oldtype = 'P.3 ' then newtype := 'P3 ';
1479 if oldtype = 'S.2 ' then newtype := 'S2 ';
1480 if oldtype = 'S.3 ' then newtype := 'S3 ';
1481 if oldtype = 'S.o ' then newtype := 'SO ';
1482 if oldtype = 'S.o2 ' then newtype := 'SO2';
1483 if oldtype = 'Si ' then newtype := 'SI ';
1484 if oldtype = 'P.4 ' then newtype := 'P4 ';
1485 convert_sybtype := newtype;
1486 end;
1487
1488
convert_MDLtypenull1489 function convert_MDLtype(oldtype : str3):str3;
1490 var
1491 newtype : str3;
1492 begin
1493 // NewType := Copy(OldType,1,3);
1494 // For i := 1 To 3 Do NewType[i] := UpCase(NewType[i]);
1495 // If NewType[1] = '~' Then NewType := 'VAL';
1496 // If NewType[1] = '*' Then NewType := 'STR';
1497 newtype := 'DU ';
1498 if oldtype = 'H ' then newtype := 'H ';
1499 if oldtype = 'C ' then newtype := 'C3 ';
1500 if oldtype = 'O ' then newtype := 'O2 ';
1501 if oldtype = 'N ' then newtype := 'N3 ';
1502 if oldtype = 'F ' then newtype := 'F ';
1503 if oldtype = 'Cl ' then newtype := 'CL ';
1504 if oldtype = 'Br ' then newtype := 'BR ';
1505 if oldtype = 'I ' then newtype := 'I ';
1506 if oldtype = 'Al ' then newtype := 'AL ';
1507 if oldtype = 'ANY' then newtype := 'A ';
1508 if oldtype = 'Ca ' then newtype := 'CA ';
1509 if oldtype = 'Du ' then newtype := 'DU ';
1510 if oldtype = 'K ' then newtype := 'K ';
1511 if oldtype = 'Li ' then newtype := 'LI ';
1512 if oldtype = 'LP ' then newtype := 'LP ';
1513 if oldtype = 'Na ' then newtype := 'NA ';
1514 if oldtype = 'P ' then newtype := 'P3 ';
1515 if oldtype = 'S ' then newtype := 'S3 ';
1516 if oldtype = 'Si ' then newtype := 'SI ';
1517 if oldtype = 'P ' then newtype := 'P4 ';
1518 if oldtype = 'A ' then newtype := 'A ';
1519 if oldtype = 'Q ' then newtype := 'Q ';
1520 convert_MDLtype := NewType;
1521 end;
1522
1523
get_elementnull1524 function get_element(oldtype:str4):str2;
1525 var
1526 elemstr : string;
1527 begin
1528 if oldtype = 'H ' then elemstr := 'H ';
1529 if oldtype = 'CAR ' then elemstr := 'C ';
1530 if oldtype = 'C2 ' then elemstr := 'C ';
1531 if oldtype = 'C3 ' then elemstr := 'C ';
1532 if oldtype = 'C1 ' then elemstr := 'C ';
1533 if oldtype = 'O2 ' then elemstr := 'O ';
1534 if oldtype = 'O3 ' then elemstr := 'O ';
1535 if oldtype = 'O2 ' then elemstr := 'O ';
1536 if oldtype = 'O3 ' then elemstr := 'O ';
1537 if oldtype = 'O3 ' then elemstr := 'O ';
1538 if oldtype = 'N1 ' then elemstr := 'N ';
1539 if oldtype = 'N2 ' then elemstr := 'N ';
1540 if oldtype = 'N3 ' then elemstr := 'N ';
1541 if oldtype = 'NPL ' then elemstr := 'N ';
1542 if oldtype = 'N3+ ' then elemstr := 'N ';
1543 if oldtype = 'NAM ' then elemstr := 'N ';
1544 if oldtype = 'NAR ' then elemstr := 'N ';
1545 if oldtype = 'F ' then elemstr := 'F ';
1546 if oldtype = 'CL ' then elemstr := 'CL';
1547 if oldtype = 'BR ' then elemstr := 'BR';
1548 if oldtype = 'I ' then elemstr := 'I ';
1549 if oldtype = 'AL ' then elemstr := 'AL';
1550 if oldtype = 'DU ' then elemstr := 'DU';
1551 if oldtype = 'CA ' then elemstr := 'CA';
1552 if oldtype = 'DU ' then elemstr := 'DU';
1553 if oldtype = 'Cl ' then elemstr := 'CL';
1554 if oldtype = 'K ' then elemstr := 'K ';
1555 if oldtype = 'LI ' then elemstr := 'LI';
1556 if oldtype = 'LP ' then elemstr := 'LP';
1557 if oldtype = 'NA ' then elemstr := 'NA';
1558 if oldtype = 'P3 ' then elemstr := 'P ';
1559 if oldtype = 'S2 ' then elemstr := 'S ';
1560 if oldtype = 'S3 ' then elemstr := 'S ';
1561 if oldtype = 'SO ' then elemstr := 'S ';
1562 if oldtype = 'SO2 ' then elemstr := 'S ';
1563 if oldtype = 'SI ' then elemstr := 'SI';
1564 if oldtype = 'P4 ' then elemstr := 'P ';
1565 if oldtype = 'A ' then elemstr := 'A ';
1566 if oldtype = 'Q ' then elemstr := 'Q ';
1567 get_element := elemstr;
1568 end;
1569
1570
get_sybelementnull1571 function get_sybelement(oldtype:str5):str2;
1572 var
1573 i : integer;
1574 elemstr : str2;
1575 begin
1576 if pos('.',oldtype)<2 then
1577 begin
1578 elemstr := copy(oldtype,1,2);
1579 end else
1580 begin
1581 elemstr := copy(oldtype,1,pos('.',oldtype)-1);
1582 if length(elemstr)<2 then elemstr := elemstr+' ';
1583 end;
1584 for i := 1 to 2 do elemstr[i] := upcase(elemstr[i]);
1585 get_sybelement := elemstr;
1586 end;
1587
1588
get_MDLelementnull1589 function get_MDLelement(oldtype:str3):str2;
1590 var
1591 i : integer;
1592 elemstr : str2;
1593 begin
1594 elemstr := copy(oldtype,1,2);
1595 for i := 1 to 2 do elemstr[i] := upcase(elemstr[i]);
1596 if elemstr[1] = '~' then elemstr := '??';
1597 if elemstr[1] = '*' then elemstr := '??';
1598 {$IFDEF clean_marvin_r}
1599 if elemstr = 'R#' then elemstr := 'R ';
1600 {$ENDIF}
1601 get_MDLelement := elemstr;
1602 end;
1603
1604
1605 procedure read_molfile(mfilename:string); // reads ALCHEMY mol files
1606 var
1607 n, code : integer;
1608 rline, tmpstr : string;
1609 xstr, ystr, zstr, chgstr : string;
1610 xval, yval, zval, chgval : single;
1611 a1str, a2str, elemstr : string;
1612 a1val, a2val : integer;
1613 ri : integer;
1614 begin
1615 if n_atoms > 0 then zap_molecule;
1616 ri := li;
1617 rline := molbuf^[ri];
1618 tmpstr := copy(rline,1,5);
1619 val(tmpstr,n_atoms,code);
1620 tmpstr := copy(rline,14,5);
1621 val(tmpstr,n_bonds,code);
1622 molname := copy(rline,42,length(rline)-42);
1623 try
1624 getmem(atom,n_atoms*sizeof(atom_rec));
1625 getmem(bond,n_bonds*sizeof(bond_rec));
1626 getmem(ring,sizeof(ringlist));
1627 getmem(ringprop,sizeof(ringprop_type));
1628 getmem(bracket,sizeof(bracket_type)); // v0.1f
1629 getmem(sgroup,sizeof(sgroup_type)); // v0.2a
1630 except
1631 on e:Eoutofmemory do
1632 begin
1633 writeln('Not enough memory');
1634 halt(4);
1635 end;
1636 end;
1637 n_heavyatoms := 0;
1638 n_heavybonds := 0;
1639 for n := 1 to n_atoms do
1640 begin
1641 with atom^[n] do
1642 begin
1643 x := 0; y := 0; z := 0;
1644 formal_charge := 0;
1645 real_charge := 0;
1646 Hexp := 0;
1647 Htot := 0;
1648 neighbor_count := 0;
1649 ring_count := 0;
1650 arom := FALSE;
1651 stereo_care := FALSE;
1652 map_id := 0;
1653 end;
1654 inc(ri);
1655 rline := molbuf^[ri];
1656 atomtype := copy(rline,7,4);
1657 atomtype := upcase(atomtype);
1658 elemstr := get_element(atomtype);
1659 newatomtype := convert_type(atomtype);
1660 xstr := copy(rline,14,7);
1661 ystr := copy(rline,23,7);
1662 zstr := copy(rline,32,7);
1663 chgstr := copy(rline,43,7);
1664 val(xstr,xval,code);
1665 val(ystr,yval,code);
1666 val(zstr,zval,code);
1667 val(chgstr,chgval,code);
1668 with atom^[n] do
1669 begin
1670 element := elemstr;
1671 atype := newatomtype;
1672 x := xval; y := yval; z := zval; real_charge := chgval;
1673 x_orig := xval; y_orig := yval; z_orig := zval;
1674 end;
1675 if is_heavyatom(n) then inc(n_heavyatoms);
1676 end;
1677 for n := 1 to n_bonds do
1678 begin
1679 inc(ri);
1680 rline := molbuf^[ri];
1681 a1str := copy(rline,9,3);
1682 a2str := copy(rline,15,3);
1683 val(a1str,a1val,code);
1684 if code <> 0 then beep;
1685 val(a2str,a2val,code);
1686 if code <> 0 then beep;
1687 with bond^[n] do
1688 begin
1689 a1 := a1val; a2 := a2val; btype := rline[20];
1690 ring_count := 0; arom := false; topo := btopo_any; stereo := bstereo_any;
1691 bsubtype := 'N';
1692 a_handle := 0;
1693 end;
1694 if is_heavyatom(a1val) and is_heavyatom(a2val) then inc(n_heavybonds);
1695 end;
1696 fillchar(ring^,sizeof(ringlist),0);
1697 for n := 1 to max_rings do
1698 begin
1699 ringprop^[n].size := 0;
1700 ringprop^[n].arom := false;
1701 ringprop^[n].envelope := false;
1702 end;
1703 li := ri + 1;
1704 end;
1705
1706
1707 procedure read_mol2file(mfilename:string); // reads SYBYL mol2 files
1708 var
1709 n, code : integer;
1710 sybatomtype : string[5];
1711 tmpstr, rline : string;
1712 xstr, ystr, zstr, chgstr : string;
1713 xval, yval, zval, chgval : single;
1714 a1str, a2str, elemstr : string;
1715 a1val, a2val : integer;
1716 ri : integer;
1717 begin
1718 if n_atoms > 0 then zap_molecule;
1719 rline := '';
1720 ri := li -1;
1721 while (ri < molbufindex) and (pos('@<TRIPOS>MOLECULE',rline)=0) do
1722 begin
1723 inc(ri);
1724 rline := molbuf^[ri];
1725 end;
1726 if ri < molbufindex then
1727 begin
1728 inc(ri);
1729 molname := molbuf^[ri];
1730 end;
1731 if ri < molbufindex then
1732 begin
1733 inc(ri);
1734 rline := molbuf^[ri];
1735 end;
1736 tmpstr := copy(rline,1,5);
1737 val(tmpstr,n_atoms,code);
1738 tmpstr := copy(rline,7,5);
1739 val(tmpstr,n_bonds,code);
1740 try
1741 getmem(atom,n_atoms*sizeof(atom_rec));
1742 getmem(bond,n_bonds*sizeof(bond_rec));
1743 getmem(ring,sizeof(ringlist));
1744 getmem(ringprop,sizeof(ringprop_type));
1745 getmem(bracket,sizeof(bracket_type)); // v0.1f
1746 getmem(sgroup,sizeof(sgroup_type)); // v0.2a
1747 except
1748 on e:Eoutofmemory do
1749 begin
1750 writeln('Not enough memory');
1751 halt(4);
1752 end;
1753 end;
1754 n_heavyatoms := 0;
1755 n_heavybonds := 0;
1756 while ((ri < molbufindex) and (pos('@<TRIPOS>ATOM',rline)=0)) do
1757 begin
1758 inc(ri);
1759 rline := molbuf^[ri];
1760 end;
1761 for n := 1 to n_atoms do
1762 begin
1763 with atom^[n] do
1764 begin
1765 x := 0; y := 0; z := 0;
1766 formal_charge := 0;
1767 real_charge := 0;
1768 Hexp := 0;
1769 Htot := 0;
1770 neighbor_count := 0;
1771 ring_count := 0;
1772 arom := FALSE;
1773 stereo_care := false;
1774 map_id := 0;
1775 end;
1776 if (ri < molbufindex) then
1777 begin
1778 inc(ri);
1779 rline := molbuf^[ri];
1780 end;
1781 sybatomtype := copy(rline,48,5);
1782 elemstr := get_sybelement(sybatomtype);
1783 newatomtype := convert_sybtype(sybatomtype);
1784 xstr := copy(rline,18,9);
1785 ystr := copy(rline,28,9);
1786 zstr := copy(rline,38,9);
1787 chgstr := copy(rline,70,9);
1788 val(xstr,xval,code);
1789 val(ystr,yval,code);
1790 val(zstr,zval,code);
1791 val(chgstr,chgval,code);
1792 with atom^[n] do
1793 begin
1794 element := elemstr;
1795 atype := newatomtype;
1796 x := xval; y := yval; z := zval; real_charge := chgval;
1797 x_orig := xval; y_orig := yval; z_orig := zval;
1798 end;
1799 if is_heavyatom(n) then inc(n_heavyatoms);
1800 end;
1801 while ((ri < molbufindex) and (pos('@<TRIPOS>BOND',rline)=0)) do
1802 begin
1803 inc(ri);
1804 rline := molbuf^[ri];
1805 end;
1806 for n := 1 to n_bonds do
1807 begin
1808 if (ri < molbufindex) then
1809 begin
1810 inc(ri);
1811 rline := molbuf^[ri];
1812 end;
1813 a1str := copy(rline,9,3);
1814 a2str := copy(rline,14,3);
1815 val(a1str,a1val,code);
1816 if code <> 0 then writeln(rline, #7);
1817 val(a2str,a2val,code);
1818 if code <> 0 then writeln(rline,#7);
1819 with bond^[n] do
1820 begin
1821 a1 := a1val; a2 := a2val;
1822 if rline[18] = '1' then btype := 'S';
1823 if rline[18] = '2' then btype := 'D';
1824 if rline[18] = '3' then btype := 'T';
1825 if rline[18] = 'a' then btype := 'A';
1826 ring_count := 0; arom := false; topo := btopo_any; stereo := bstereo_any;
1827 bsubtype := 'N';
1828 a_handle := 0;
1829 end;
1830 if is_heavyatom(a1val) and is_heavyatom(a2val) then inc(n_heavybonds);
1831 end;
1832 fillchar(ring^,sizeof(ringlist),0);
1833 for n := 1 to max_rings do
1834 begin
1835 ringprop^[n].size := 0;
1836 ringprop^[n].arom := false;
1837 ringprop^[n].envelope := false;
1838 end;
1839 li := ri + 1;
1840 end;
1841
1842
get_bracket_indexnull1843 function get_bracket_index(id:integer):integer;
1844 var
1845 i, r : integer;
1846 begin
1847 r := 0;
1848 if (n_brackets > 0) then
1849 begin
1850 for i := 1 to n_brackets do
1851 begin
1852 if bracket^[i].id = id then r := i;
1853 end;
1854 end;
1855 get_bracket_index := r;
1856 end;
1857
1858
get_sgroup_indexnull1859 function get_sgroup_index(id:integer):integer;
1860 var
1861 i, r : integer;
1862 begin
1863 r := 0;
1864 if (n_sgroups > 0) then
1865 begin
1866 for i := 1 to n_sgroups do
1867 begin
1868 if sgroup^[i].id = id then r := i;
1869 end;
1870 end;
1871 get_sgroup_index := r;
1872 end;
1873
1874 procedure read_alias(astring,line2:string); // v0.2b
1875 var
1876 a_id : integer;
1877 a_alias : string;
1878 a_j : integer;
1879 // typical example:
1880 // A 39
1881 // Atto647N
1882 // always 2 lines, the first one with "A nnn" where nnn is the atom number,
1883 // the second line contains the alias;
1884 // the usual markups apply: \S = superscript, \s = subscript, \n = normal
1885 begin
1886 // MDL specs:
1887 // A nnn // nnn = atom number
1888 // xxx // xxx = the alias text
1889 // mol2ps extension:
1890 // A nnnjjj // nnn = atom number jjj = justification ( 0 = left, 1 = right, 2 = center
1891 // xxx // xxx = the alias text
1892 if (pos('A ',astring)>0) then
1893 begin
1894 delete(astring,1,3);
1895 left_trim(astring);
1896 a_id := left_int(astring); // atom number (MDL standard
1897 a_j := left_int(astring); // justification (mol2ps extension)
1898 {$IFDEF debug}
1899 if (a_id = 0) then debugoutput('strange... label for atom 0');
1900 {$ENDIF}
1901 if (length(line2) <= 80) then a_alias := line2 else a_alias := copy(line2,1,80);
1902 if (a_id > 0) and (a_id <= n_atoms) then
1903 begin
1904 {$IFDEF debug}
1905 debugoutput('adding alias '+a_alias+' to atom '+inttostr(a_id));
1906 {$ENDIF}
1907 atom^[a_id].alias := a_alias;
1908 atom^[a_id].a_just := 0; // default
1909 if (a_j = 1) or (a_j = 2) then atom^[a_id].a_just := a_j;
1910 end;
1911 end;
1912 end;
1913
1914
1915
1916 procedure read_charges(chgstring:string);
1917 var
1918 a_id, a_chg : integer;
1919 n_chrg : integer;
1920 // typical example: a molecule with 2 cations + 1 anion
1921 // M CHG 3 8 1 10 1 11 -1
1922 begin
1923 if (pos('M CHG',chgstring)>0) then
1924 begin
1925 delete(chgstring,1,6);
1926 left_trim(chgstring);
1927 n_chrg := left_int(chgstring); // this assignment must be kept also in non-debug mode!
1928 {$IFDEF debug}
1929 if (n_chrg = 0) then debugoutput('strange... M CHG present, but no charges found');
1930 {$ENDIF}
1931 while (length(chgstring) > 0) do
1932 begin
1933 a_id := left_int(chgstring);
1934 a_chg := left_int(chgstring);
1935 if (a_id <> 0) and (a_chg <> 0) then atom^[a_id].formal_charge := a_chg;
1936 end;
1937 end;
1938 end;
1939
1940
1941 procedure read_isotopes(isotopestring:string);
1942 var
1943 a_id, a_nucleon_number : integer;
1944 n_isotopes : integer;
1945 // typical example: a molecule with 3 isotopes
1946 // M ISO 3 8 15 10 13 11 17
1947 begin
1948 if (pos('M ISO',isotopestring) > 0) then
1949 begin
1950 delete(isotopestring,1,6);
1951 left_trim(isotopestring);
1952 n_isotopes := left_int(isotopestring); // this assignment must be kept also in non-debug mode!
1953 {$IFDEF debug}
1954 if (n_isotopes = 0) then debugoutput('strange... M ISO with nucleon_numer = 0');
1955 {$ENDIF}
1956 while (length(isotopestring) > 0) do
1957 begin
1958 a_id := left_int(isotopestring);
1959 a_nucleon_number := left_int(isotopestring);
1960 if (a_id <> 0) and (a_nucleon_number > 0) then
1961 begin
1962 atom^[a_id].nucleon_number := a_nucleon_number;
1963 if (atom^[a_id].element = 'H ') and (a_nucleon_number > 1) then
1964 begin
1965 //keep_DT := false;
1966 //if opt_iso then
1967 begin
1968 atom^[a_id].heavy := true;
1969 inc(n_heavyatoms);
1970 end;
1971 atom^[a_id].atype := 'DU ';
1972 end;
1973 end;
1974 end;
1975 end;
1976 end;
1977
1978
1979 procedure read_radicals(radstring:string);
1980 var
1981 a_id, a_rad : integer;
1982 n_rads : integer;
1983 // typical example: a molecule with a radical
1984 // M RAD 1 8 2
1985 begin
1986 if (pos('M RAD',radstring) > 0) then
1987 begin
1988 delete(radstring,1,6);
1989 left_trim(radstring);
1990 n_rads := left_int(radstring); // this assignment must be kept also in non-debug mode!
1991 {$IFDEF debug}
1992 if (n_rads = 0) then debugoutput('strange... M RAD present, but no radicals found');
1993 {$ENDIF}
1994 while (length(radstring) > 0) do
1995 begin
1996 a_id := left_int(radstring);
1997 a_rad := left_int(radstring);
1998 if (a_id <> 0) and (a_rad <> 0) then atom^[a_id].radical_type := a_rad;
1999 end;
2000 end;
2001 end;
2002
2003
2004 procedure read_brackets(sgroupstring:string);
2005 var
2006 br_id : integer;
2007 br_index : integer;
2008 n_tmp : integer;
2009 xtmp, ytmp : single;
2010 k : integer;
2011 begin
2012 if (pos('M SDI',sgroupstring) > 0) then
2013 begin
2014 delete(sgroupstring,1,6);
2015 left_trim(sgroupstring);
2016 br_id := left_int(sgroupstring); // this assignment must be kept also in non-debug mode!
2017 n_tmp := left_int(sgroupstring); // this assignment must be kept also in non-debug mode!
2018 {$IFDEF debug}
2019 {$ENDIF}
2020 br_index := get_bracket_index(br_id);
2021 if (br_index > 0) and (br_index <= n_brackets) then
2022 begin
2023 k := 1;
2024 if (bracket^[br_index].x1 = 0) and (bracket^[br_index].y1 = 0) and
2025 (bracket^[br_index].x2 = 0) and (bracket^[br_index].y2 = 0) then k := 1;
2026 if (bracket^[br_index].x1 <> 0) or (bracket^[br_index].y1 <> 0) or
2027 (bracket^[br_index].x2 <> 0) or (bracket^[br_index].y2 <> 0) then k := 3;
2028 while (length(sgroupstring) > 0) do
2029 begin
2030 xtmp := left_float(sgroupstring);
2031 ytmp := left_float(sgroupstring);
2032 with bracket^[br_index] do
2033 begin
2034 if k = 1 then
2035 begin
2036 x1 := xtmp;
2037 y1 := ytmp;
2038 end;
2039 if k = 2 then
2040 begin
2041 x2 := xtmp;
2042 y2 := ytmp;
2043 end;
2044 if k = 3 then
2045 begin
2046 x3 := xtmp;
2047 y3 := ytmp;
2048 end;
2049 if k = 4 then
2050 begin
2051 x4 := xtmp;
2052 y4 := ytmp;
2053 end;
2054 end;
2055 inc(k);
2056 end; // while
2057 end;
2058 end;
2059 end;
2060
2061
2062 procedure read_sgroups(sgroupstring:string);
2063 var
2064 i, n_sg, sg_id, sg_index : integer;
2065 n_tmp, a, a1, a2, b : integer;
2066 xtmp, ytmp : single;
2067 sg_type : string;
2068 tmpstr : string;
2069 begin
2070 if (pos('M STY',sgroupstring) > 0) then
2071 begin
2072 delete(sgroupstring,1,6);
2073 left_trim(sgroupstring);
2074 n_sg := left_int(sgroupstring); // this assignment must be kept also in non-debug mode!
2075 for i := 1 to n_sg do
2076 begin
2077 sg_id := left_int(sgroupstring);
2078 left_trim(sgroupstring);
2079 if length(sgroupstring) >= 3 then
2080 begin
2081 sg_type := copy(sgroupstring,1,3);
2082 delete(sgroupstring,1,3);
2083 if ((sg_type = 'SUP') or (sg_type = 'DAT')) and (n_sgroups < max_sgroups) then
2084 begin
2085 inc(n_sgroups);
2086 sgroup^[n_sgroups].id := sg_id;
2087 sgroup^[n_sgroups].sgtype := sg_type;
2088 end;
2089 if (sg_type = 'SRU') and (n_brackets < max_brackets) then
2090 begin
2091 inc(n_brackets);
2092 bracket^[n_brackets].id := sg_id;
2093 bracket^[n_brackets].x1 := 0;
2094 bracket^[n_brackets].y1 := 0;
2095 bracket^[n_brackets].x2 := 0;
2096 bracket^[n_brackets].y2 := 0;
2097 bracket^[n_brackets].x3 := 0;
2098 bracket^[n_brackets].y3 := 0;
2099 bracket^[n_brackets].x4 := 0;
2100 bracket^[n_brackets].y4 := 0;
2101 //bracket^[n_brackets].brtype := what??;
2102 end;
2103 end;
2104 end;
2105
2106 end;
2107 if (pos('M SMT',sgroupstring) > 0) then
2108 begin
2109 delete(sgroupstring,1,6);
2110 left_trim(sgroupstring);
2111 sg_id := left_int(sgroupstring); // this assignment must be kept also in non-debug mode!
2112 left_trim(sgroupstring);
2113 sg_index := get_sgroup_index(sg_id);
2114 if (sg_index > 0) then sgroup^[sg_index].sglabel := sgroupstring;
2115 sg_index := get_bracket_index(sg_id);
2116 if (sg_index > 0) then bracket^[sg_index].brlabel := sgroupstring;
2117 end;
2118 if (pos('M SDD',sgroupstring) > 0) then
2119 begin
2120 tmpstr := copy(sgroupstring,8,3);
2121 sg_id := left_int(tmpstr);
2122 sg_index := get_sgroup_index(sg_id);
2123 if (sg_index > 0) then
2124 begin
2125 tmpstr := copy(sgroupstring,12,10);
2126 xtmp := left_float(tmpstr);
2127 tmpstr := copy(sgroupstring,22,10);
2128 ytmp := left_float(tmpstr);
2129 sgroup^[sg_index].x := xtmp;
2130 sgroup^[sg_index].y := ytmp;
2131 sgroup^[sg_index].justification := 'L'; // preliminary (maybe "centered" would look better
2132 //with sgroup^[sg_index] do writeln('% ',sg_index,': x = ',x:1:5,', y = ',y:1:5,' label = ',sglabel);
2133 end;
2134 end;
2135 if (pos('M SED',sgroupstring) > 0) then
2136 begin
2137 delete(sgroupstring,1,6);
2138 left_trim(sgroupstring);
2139 sg_id := left_int(sgroupstring); // this assignment must be kept also in non-debug mode!
2140 left_trim(sgroupstring);
2141 sg_index := get_sgroup_index(sg_id);
2142 if (sg_index > 0) then sgroup^[sg_index].sglabel := sgroupstring;
2143 //with sgroup^[sg_index] do writeln('% ',sg_index,': x = ',x:1:5,', y = ',y:1:5,' label = ',sglabel);
2144 end;
2145 if (pos('M SAL',sgroupstring) > 0) then
2146 begin
2147 delete(sgroupstring,1,6);
2148 left_trim(sgroupstring);
2149 sg_id := left_int(sgroupstring);
2150 n_tmp := left_int(sgroupstring);
2151 sg_index := get_sgroup_index(sg_id);
2152 if (sg_index > 0) and (sgroup^[sg_index].sgtype = 'SUP') then
2153 begin
2154 for i := 1 to n_tmp do
2155 begin
2156 a := left_int(sgroupstring);
2157 if (a > 0) and (a <= n_atoms) then atom^[a].sg := true;
2158 end;
2159 end;
2160 end;
2161 if (pos('M SBV',sgroupstring) > 0) then
2162 begin
2163 delete(sgroupstring,1,6);
2164 left_trim(sgroupstring);
2165 sg_id := left_int(sgroupstring);
2166 sg_index := get_sgroup_index(sg_id);
2167 b := left_int(sgroupstring);
2168 if (b > 0) and (b <= n_bonds) then
2169 begin
2170 a1 := bond^[b].a1;
2171 a2 := bond^[b].a2;
2172 if (atom^[a1].sg = true) then sgroup^[sg_index].anchor := a1; // one of these two atoms should
2173 if (atom^[a2].sg = true) then sgroup^[sg_index].anchor := a2; // be _not_ in the Sgroup
2174 xtmp := left_float(sgroupstring);
2175 ytmp := left_float(sgroupstring);
2176 if (xtmp <= 0) then sgroup^[sg_index].justification := 'L' else
2177 sgroup^[sg_index].justification := 'R';
2178 end;
2179 end;
2180 end;
2181
2182
2183 procedure read_MDLmolfile(mfilename:string); // reads MDL mol files
2184 var
2185 n, code : integer;
2186 rline, tmpstr : string;
2187 xstr, ystr, zstr, chgstr : string;
2188 xval, yval, zval, chgval : single;
2189 a1str, a2str, elemstr : string;
2190 a1val, a2val : integer;
2191 ri, rc, bt,bs : integer;
2192 sepcount : integer;
2193 i : integer; // new in mol2ps
2194 clearcharges : boolean; // new in mol2ps
2195 mstr : string; // v0.3a
2196 mval : integer; // v0.3a
2197 begin
2198 clearcharges := true; // new in mol2ps
2199 if n_atoms > 0 then zap_molecule;
2200 rline := '';
2201 ri := li;
2202 molname := molbuf^[ri]; // line 1
2203 if ri < molbufindex then inc(ri); // line 2
2204 rline := molbuf^[ri];
2205 if ri < molbufindex then inc(ri); // line 3
2206 rline := molbuf^[ri];
2207 //molcomment := rline;
2208 if ri < molbufindex then inc(ri); // line 4
2209 rline := molbuf^[ri];
2210 tmpstr := copy(rline,1,3);
2211 val(tmpstr,n_atoms,code);
2212 tmpstr := copy(rline,4,3);
2213 val(tmpstr,n_bonds,code);
2214 try
2215 getmem(atom,n_atoms*sizeof(atom_rec));
2216 getmem(bond,n_bonds*sizeof(bond_rec));
2217 getmem(ring,sizeof(ringlist));
2218 getmem(ringprop,sizeof(ringprop_type));
2219 getmem(bracket,sizeof(bracket_type)); // v0.1f
2220 getmem(sgroup,sizeof(sgroup_type)); // v0.2a
2221 except
2222 on e:Eoutofmemory do
2223 begin
2224 writeln('Not enough memory');
2225 close(molfile);
2226 halt(4);
2227 exit;
2228 end;
2229 end;
2230 n_heavyatoms := 0;
2231 n_heavybonds := 0;
2232 for n := 1 to n_atoms do
2233 begin
2234 with atom^[n] do
2235 begin
2236 x := 0; y := 0; z := 0;
2237 formal_charge := 0;
2238 real_charge := 0;
2239 Hexp := 0;
2240 Htot := 0;
2241 neighbor_count := 0;
2242 ring_count := 0;
2243 arom := FALSE;
2244 stereo_care := false;
2245 metal := false;
2246 heavy := false;
2247 tag := false;
2248 nucleon_number := 0;
2249 radical_type := 0;
2250 sg := false;
2251 alias := ''; // v0.2b
2252 a_just := 0; // v0.2b
2253 map_id := 0; // v0.3a
2254 end;
2255 if ri < molbufindex then
2256 begin
2257 inc(ri); // v0.2b
2258 rline := molbuf^[ri];
2259 atomtype := copy(rline,32,3);
2260 elemstr := get_MDLelement(atomtype);
2261 newatomtype := convert_MDLtype(atomtype);
2262 xstr := copy(rline,2,9);
2263 ystr := copy(rline,12,9);
2264 zstr := copy(rline,22,9);
2265 chgstr := copy(rline,37,3); // new in mol2ps v0.1
2266 mstr := copy(rline,61,3); // v0.3a
2267 val(xstr,xval,code);
2268 val(ystr,yval,code);
2269 val(zstr,zval,code);
2270 val(chgstr,chgval,code);
2271 val(mstr,mval,code);
2272 if (chgval <> 0) then
2273 begin
2274 if (chgval >= 1) and (chgval <= 7) then
2275 chgval := 4 - chgval else chgval := 0;
2276 end; // end
2277 with atom^[n] do
2278 begin
2279 element := elemstr;
2280 atype := newatomtype;
2281 x := xval; y := yval; z := zval; formal_charge := round(chgval); real_charge := 0;
2282 x_orig := xval; y_orig := yval; z_orig := zval;
2283 // read aromaticity flag from CheckMol-tweaked MDL molfile
2284 if (length(rline) > 37) and (rline[38] = '0') then
2285 begin
2286 arom := true;
2287 end;
2288 if (length(rline) > 47) and (rline[48] = '1') then stereo_care := true;
2289 if (is_heavyatom(n)) then
2290 begin
2291 inc(n_heavyatoms);
2292 heavy := true;
2293 if is_metal(n) then metal := true;
2294 end;
2295 nvalences := get_nvalences(element); // v0.3m
2296 map_id := mval; // v0.3a
2297 end;
2298 end;
2299 end;
2300 for n := 1 to n_bonds do
2301 begin
2302 if ri < molbufindex then
2303 begin
2304 inc(ri); // v0.2b
2305 rline := molbuf^[ri];
2306 a1str := copy(rline,1,3);
2307 a2str := copy(rline,4,3);
2308 val(a1str,a1val,code);
2309 if code <> 0 then beep;
2310 val(a2str,a2val,code);
2311 if code <> 0 then beep;
2312 with bond^[n] do
2313 begin
2314 a1 := a1val; a2 := a2val;
2315 if rline[9] = '1' then btype := 'S'; // single
2316 if rline[9] = '2' then btype := 'D'; // double
2317 if rline[9] = '3' then btype := 'T'; // triple
2318 if rline[9] = '4' then btype := 'A'; // aromatic
2319 if rline[9] = '5' then btype := 'l'; // single or double
2320 if rline[9] = '6' then btype := 's'; // single or aromatic
2321 if rline[9] = '7' then btype := 'd'; // double or aromatic
2322 if rline[9] = '8' then btype := 'a'; // any
2323 bsubtype := 'N'; // mol2ps
2324 a_handle := 0; // mol2ps
2325 arom := false;
2326 // read aromaticity flag from CheckMol-tweaked MDL molfile
2327 if (btype = 'A') or (rline[8] = '0') then
2328 begin
2329 arom := true;
2330 end;
2331 tmpstr := copy(rline,13,3); // read ring_count from tweaked molfile
2332 val(tmpstr,rc,code);
2333 tmpstr := copy(rline,16,3); // read bond topology;
2334 val(tmpstr,bt,code); // extended features are encoded by leading zero
2335 if ((code <> 0) or (bt < 0) or (bt > 5)) then topo := btopo_any else
2336 begin
2337 if (tmpstr[2] = '0') then topo := bt + 3 else topo := bt;
2338 end;
2339 // stereo property from MDL "stereo care" flag in atom block
2340 stereo := bstereo_any;
2341 if (btype ='D') then
2342 begin
2343 if (atom^[a1].stereo_care and atom^[a2].stereo_care) then
2344 begin // this is the MDL-conformant encoding,
2345 stereo := bstereo_xyz; // for an alternative see below
2346 end else
2347 begin
2348 tmpstr := copy(rline,10,3); // read bond stereo specification;
2349 val(tmpstr,bs,code); // this extended feature is encoded by a leading zero
2350 if ((code <> 0) or (bs <= 0) or (bs > 2)) then stereo := bstereo_any
2351 else stereo := bstereo_xyz;
2352 if (tmpstr[2] = '0') then stereo := bstereo_xyz;
2353 end;
2354 end;
2355 //if stereo <> bstereo_any then ez_search := true;
2356 if (btype ='S') and (length(rline)>11) and (rline[12]='1') then stereo := bstereo_up;
2357 if (btype ='S') and (length(rline)>11) and (rline[12]='6') then stereo := bstereo_down;
2358 tmpstr := copy(rline,10,3); // new in v0.1c: save original bond stereo specification;
2359 val(tmpstr,bs,code); // v0.1c
2360 mdl_stereo := bs; // v0.1c
2361 {$IFDEF csearch_extensions}
2362 if ((btype = 'S') and (mdl_stereo = 4)) then btype := 'C'; // v0.1c complex bonds
2363 {$ENDIF}
2364 sg := false;
2365 end;
2366 if is_heavyatom(a1val) and is_heavyatom(a2val) then inc(n_heavybonds);
2367 end;
2368 end;
2369 fillchar(bracket^,sizeof(bracket_type),0); // v0.1f
2370 n_brackets := 0; // v0.1f
2371 fillchar(sgroup^,sizeof(sgroup_type),0); // v0.2a
2372 n_sgroups := 0; // v0.2a
2373 sepcount := 0;
2374 while (ri < molbufindex) and (sepcount < 1) do
2375 begin
2376 inc(ri);
2377 rline := molbuf^[ri];
2378 if (pos('M CHG',rline) > 0) then
2379 begin
2380 if clearcharges then // "M CHG" supersedes all "old-style" charge values
2381 begin
2382 for i := 1 to n_atoms do atom^[i].formal_charge := 0;
2383 end;
2384 read_charges(rline);
2385 clearcharges := false; // subsequent "M CHG" lines must not clear previous values
2386 end;
2387 if (pos('A ',rline) = 1) then // v0.2b
2388 begin
2389 tmpstr := '';
2390 if ri < molbufindex then inc(ri); // line 2
2391 tmpstr := molbuf^[ri];
2392 read_alias(rline,tmpstr);
2393 end;
2394 if (pos('M ISO',rline) > 0) then read_isotopes(rline);
2395 if (pos('M RAD',rline) > 0) then read_radicals(rline);
2396 if (pos('M SDI',rline) > 0) then read_brackets(rline);
2397 if (pos('M STY',rline) > 0)
2398 or (pos('M SAL',rline) > 0)
2399 or (pos('M SMT',rline) > 0)
2400 or (pos('M SBV',rline) > 0)
2401 or (pos('M SDD',rline) > 0)
2402 or (pos('M SED',rline) > 0) then read_sgroups(rline);
2403 if (pos('$$$$',rline)>0) then
2404 begin
2405 inc(sepcount);
2406 if (molbufindex > (ri + 2)) then mol_in_queue := true; // we assume this is an SDF file
2407 end;
2408 end;
2409 fillchar(ring^,sizeof(ringlist),0);
2410 for n := 1 to max_rings do
2411 begin
2412 ringprop^[n].size := 0;
2413 ringprop^[n].arom := false;
2414 ringprop^[n].envelope := false;
2415 end;
2416 li := ri + 1;
2417 end;
2418
2419 //============= chemical processing functions & procedures ============
2420
nvalencesnull2421 function nvalences(a_el:str2):integer;
2422 // preliminary version; should be extended to element/atomtype
2423 var
2424 res : integer;
2425 begin
2426 res := 1;
2427 if a_el = 'H ' then res := 1;
2428 if a_el = 'C ' then res := 4;
2429 if a_el = 'N ' then res := 3;
2430 if a_el = 'O ' then res := 2;
2431 if a_el = 'S ' then res := 2;
2432 if a_el = 'SE' then res := 2;
2433 if a_el = 'TE' then res := 2;
2434 if a_el = 'P ' then res := 3;
2435 if a_el = 'F ' then res := 1;
2436 if a_el = 'CL' then res := 1;
2437 if a_el = 'BR' then res := 1;
2438 if a_el = 'I ' then res := 1;
2439 if a_el = 'B ' then res := 3;
2440 if a_el = 'LI' then res := 1;
2441 if a_el = 'NA' then res := 1;
2442 if a_el = 'K ' then res := 1;
2443 if a_el = 'CA' then res := 2;
2444 if a_el = 'SR' then res := 2;
2445 if a_el = 'MG' then res := 2;
2446 if a_el = 'FE' then res := 3;
2447 if a_el = 'MN' then res := 2;
2448 if a_el = 'HG' then res := 2;
2449 if a_el = 'SI' then res := 4;
2450 if a_el = 'SN' then res := 4;
2451 if a_el = 'ZN' then res := 2;
2452 if a_el = 'CU' then res := 2;
2453 if a_el = 'A ' then res := 4;
2454 if a_el = 'Q ' then res := 4;
2455 nvalences := res;
2456 end;
2457
2458
is_electronegnull2459 function is_electroneg(a_el:str2):boolean;
2460 var
2461 res : boolean;
2462 begin
2463 res := false;;
2464 if a_el = 'N ' then res := true;
2465 if a_el = 'P ' then res := true;
2466 if a_el = 'O ' then res := true;
2467 if a_el = 'S ' then res := true;
2468 if a_el = 'SE' then res := true;
2469 if a_el = 'TE' then res := true;
2470 if a_el = 'F ' then res := true;
2471 if a_el = 'CL' then res := true;
2472 if a_el = 'BR' then res := true;
2473 if a_el = 'I ' then res := true;
2474 if a_el = 'SI' then res := true; // v0.f
2475 is_electroneg := res;
2476 end;
2477
2478
2479 procedure count_neighbors;
2480 // counts heavy-atom neighbors and explicit hydrogens
2481 var
2482 i : integer;
2483 begin
2484 if (n_atoms < 1) or (n_bonds < 1) then exit;
2485 for i := 1 to n_bonds do
2486 begin
2487 if is_heavyatom(bond^[i].a1) then inc(atom^[(bond^[i].a2)].neighbor_count);
2488 if is_heavyatom(bond^[i].a2) then inc(atom^[(bond^[i].a1)].neighbor_count);
2489 if (atom^[(bond^[i].a1)].element = 'H ') then inc(atom^[(bond^[i].a2)].Hexp);
2490 if (atom^[(bond^[i].a2)].element = 'H ') then inc(atom^[(bond^[i].a1)].Hexp);
2491 // plausibility check
2492 if (atom^[(bond^[i].a1)].neighbor_count > max_neighbors) or
2493 (atom^[(bond^[i].a2)].neighbor_count > max_neighbors) then
2494 begin
2495 mol_OK := false;
2496 //writeln('invalid molecule!');
2497 end;
2498 end;
2499 end;
2500
2501
get_neighborsnull2502 function get_neighbors(id:integer):neighbor_rec;
2503 var
2504 i : integer;
2505 nb_tmp : neighbor_rec;
2506 nb_count : integer;
2507 begin
2508 fillchar(nb_tmp,sizeof(neighbor_rec),0);
2509 nb_count := 0;
2510 for i := 1 to n_bonds do
2511 begin
2512 if ((bond^[i].a1 = id) and (nb_count < max_neighbors)) and (is_heavyatom(bond^[i].a2)) then
2513 begin
2514 inc(nb_count);
2515 nb_tmp[nb_count] := bond^[i].a2;
2516 end;
2517 if ((bond^[i].a2 = id) and (nb_count < max_neighbors)) and (is_heavyatom(bond^[i].a1)) then
2518 begin
2519 inc(nb_count);
2520 nb_tmp[nb_count] := bond^[i].a1;
2521 end;
2522 end;
2523 get_neighbors := nb_tmp;
2524 end;
2525
2526
get_nextneighborsnull2527 function get_nextneighbors(id:integer;prev_id:integer):neighbor_rec;
2528 var
2529 i : integer;
2530 nb_tmp : neighbor_rec;
2531 nb_count : integer;
2532 begin
2533 // gets all neighbors except prev_id (usually the atom where we came from
2534 fillchar(nb_tmp,sizeof(neighbor_rec),0);
2535 nb_count := 0;
2536 for i := 1 to n_bonds do
2537 begin
2538 if ((bond^[i].a1 = id) and (bond^[i].a2 <> prev_id) and (nb_count < max_neighbors))
2539 and (is_heavyatom(bond^[i].a2)) then
2540 begin
2541 inc(nb_count);
2542 nb_tmp[nb_count] := bond^[i].a2;
2543 end;
2544 if ((bond^[i].a2 = id) and (bond^[i].a1 <> prev_id) and (nb_count < max_neighbors))
2545 and (is_heavyatom(bond^[i].a1)) then
2546 begin
2547 inc(nb_count);
2548 nb_tmp[nb_count] := bond^[i].a1;
2549 end;
2550 end;
2551 get_nextneighbors := nb_tmp;
2552 end;
2553
2554
get_allneighborsnull2555 function get_allneighbors(id:integer):neighbor_rec; // v0.1f
2556 var
2557 i : integer;
2558 nb_tmp : neighbor_rec;
2559 nb_count : integer;
2560 begin
2561 fillchar(nb_tmp,sizeof(neighbor_rec),0);
2562 nb_count := 0;
2563 for i := 1 to n_bonds do
2564 begin
2565 if ((bond^[i].a1 = id) and (nb_count < max_neighbors)) then
2566 begin
2567 inc(nb_count);
2568 nb_tmp[nb_count] := bond^[i].a2;
2569 end;
2570 if ((bond^[i].a2 = id) and (nb_count < max_neighbors)) then
2571 begin
2572 inc(nb_count);
2573 nb_tmp[nb_count] := bond^[i].a1;
2574 end;
2575 end;
2576 get_allneighbors := nb_tmp;
2577 end;
2578
2579
path_posnull2580 function path_pos(id:integer;a_path:ringpath_type):integer;
2581 var
2582 i, pp : integer;
2583 begin
2584 pp := 0;
2585 for i := max_ringsize downto 1 do
2586 begin
2587 if (a_path[i] = id) then pp := i;
2588 end;
2589 path_pos := pp;
2590 end;
2591
2592
path_lengthnull2593 function path_length(a_path:ringpath_type):integer;
2594 begin
2595 if (a_path[max_ringsize] <> 0) and (path_pos(0,a_path)=0) then path_length := max_ringsize else
2596 begin
2597 path_length := path_pos(0,a_path)-1;
2598 end;
2599 end;
2600
2601
get_bondnull2602 function get_bond(ba1,ba2:integer):integer;
2603 var
2604 i, b_id : integer;
2605 begin
2606 b_id := 0;
2607 if n_bonds > 0 then begin
2608 for i := 1 to n_bonds do
2609 begin
2610 if ((bond^[i].a1 = ba1) and (bond^[i].a2 = ba2)) or
2611 ((bond^[i].a1 = ba2) and (bond^[i].a2 = ba1)) then
2612 b_id := i;
2613 end;
2614 end;
2615 get_bond := b_id;
2616 end;
2617
2618
2619 procedure order_ringpath(var r_path:ringpath_type);
2620 // order should be: array starts with atom of lowest number, followed by neighbor atom with lower number
2621 var
2622 i, pl : integer;
2623 a_ref, a_left, a_right, a_tmp : integer;
2624 begin
2625 pl := path_length(r_path);
2626 if (pl < 3) then exit;
2627 a_ref := n_atoms; // start with highest possible value for an atom number
2628 for i := 1 to pl do
2629 begin
2630 if r_path[i] < a_ref then a_ref := r_path[i]; // find the minimum value ==> reference atom
2631 end;
2632 if a_ref < 1 then exit; // just to be sure
2633 if path_pos(a_ref,r_path) < pl then a_right := r_path[(path_pos(a_ref,r_path)+1)] else a_right := r_path[1];
2634 if path_pos(a_ref,r_path) > 1 then a_left := r_path[(path_pos(a_ref,r_path)-1)] else a_left := r_path[pl];
2635 if a_right = a_left then exit; // should never happen
2636 if a_right < a_left then
2637 begin // correct ring numbering direction, only shift of the reference atom to the left end required
2638 while path_pos(a_ref,r_path) > 1 do
2639 begin
2640 a_tmp := r_path[1];
2641 for i := 1 to (pl - 1) do r_path[i] := r_path[(i+1)];
2642 r_path[pl] := a_tmp;
2643 end;
2644 end else
2645 begin // wrong ring numbering direction, two steps required
2646 while path_pos(a_ref,r_path) < pl do
2647 begin // step one: create "mirrored" ring path with reference atom at right end
2648 a_tmp := r_path[pl];
2649 for i := pl downto 2 do r_path[i] := r_path[(i-1)];
2650 r_path[1] := a_tmp;
2651 end;
2652 for i := 1 to (pl div 2) do
2653 begin // one more mirroring
2654 a_tmp := r_path[i];
2655 r_path[i] := r_path[(pl+1)-i];
2656 r_path[(pl+1)-i] := a_tmp;
2657 end;
2658 end;
2659 end;
2660
2661
ringcomparenull2662 function ringcompare(rp1,rp2:ringpath_type):integer;
2663 var
2664 i, j, rc, rs1, rs2 : integer;
2665 n_common, max_cra : integer;
2666 begin
2667 rc := 0;
2668 n_common := 0;
2669 rs1 := path_length(rp1);
2670 rs2 := path_length(rp2);
2671 if rs1 < rs2 then max_cra := rs1 else max_cra := rs2;
2672 for i := 1 to rs1 do
2673 for j := 1 to rs2 do
2674 if rp1[i] = rp2[j] then inc(n_common);
2675 if (rs1 = rs2) and (n_common = max_cra) then rc := 0 else
2676 begin
2677 if n_common = 0 then inc(rc,8);
2678 if n_common < max_cra then inc(rc,4) else
2679 begin
2680 if rs1 < rs2 then inc(rc,1) else inc(rc,2);
2681 end;
2682 end;
2683 ringcompare := rc;
2684 end;
2685
2686
rc_identicalnull2687 function rc_identical(rc_int:integer):boolean;
2688 begin
2689 if rc_int = 0 then rc_identical := true else rc_identical := false;
2690 end;
2691
2692
rc_1in2null2693 function rc_1in2(rc_int:integer):boolean;
2694 begin
2695 if odd(rc_int) then rc_1in2 := true else rc_1in2 := false;
2696 end;
2697
2698
rc_2in1null2699 function rc_2in1(rc_int:integer):boolean;
2700 begin
2701 rc_int := rc_int div 2;
2702 if odd(rc_int) then rc_2in1 := true else rc_2in1 := false;
2703 end;
2704
2705
rc_differentnull2706 function rc_different(rc_int:integer):boolean;
2707 begin
2708 rc_int := rc_int div 4;
2709 if odd(rc_int) then rc_different := true else rc_different := false;
2710 end;
2711
2712
rc_independentnull2713 function rc_independent(rc_int:integer):boolean;
2714 begin
2715 rc_int := rc_int div 8;
2716 if odd(rc_int) then rc_independent := true else rc_independent := false;
2717 end;
2718
2719
is_newringnull2720 function is_newring(n_path:ringpath_type):boolean;
2721 var
2722 i, j : integer;
2723 nr, same_ring : boolean;
2724 tmp_path : ringpath_type;
2725 rc_result : integer;
2726 found_ring : boolean;
2727 pl : integer;
2728 begin
2729 nr := true;
2730 pl := path_length(n_path);
2731 if n_rings > 0 then
2732 begin
2733 case ringsearch_mode of
2734 rs_sar : begin
2735 found_ring := false;
2736 i := 0;
2737 while ((i < n_rings) and (not found_ring)) do
2738 begin
2739 inc(i);
2740 if (pl = ringprop^[i].size) then // compare only rings of same size
2741 begin
2742 same_ring := true;
2743 for j := 1 to max_ringsize do
2744 begin
2745 if (ring^[i,j] <> n_path[j]) then same_ring := false;
2746 end;
2747 if same_ring then
2748 begin
2749 nr := false;
2750 found_ring := true;
2751 end;
2752 end;
2753 end; // while
2754 end;
2755 rs_ssr : begin
2756 for i := 1 to n_rings do
2757 begin
2758 for j := 1 to max_ringsize do tmp_path[j] := ring^[i,j];
2759 rc_result := ringcompare(n_path,tmp_path);
2760 if rc_identical(rc_result) then nr := false;
2761 if rc_1in2(rc_result) then
2762 begin
2763 // exchange existing ring by smaller one
2764 for j := 1 to max_ringsize do ring^[i,j] := n_path[j];
2765 // update ring property record
2766 ringprop^[i].size := pl;
2767 nr := false;
2768 {$IFDEF debug}
2769 debugoutput('replacing ring '+inttostr(i)+' by smaller one (ringsize: '+inttostr(path_length(n_path))+')');
2770 {$ENDIF}
2771 end;
2772 if rc_2in1(rc_result) then
2773 begin
2774 // new ring contains existing one, but is larger ==> discard
2775 nr := false;
2776 end;
2777 end;
2778 end;
2779 end; // case
2780 end;
2781 is_newring := nr;
2782 end;
2783
2784
2785 procedure add_ring(n_path:ringpath_type);
2786 // store rings in an ordered way (with ascending ring size)
2787 var
2788 i, j, k, s, pl : integer;
2789 begin
2790 pl := path_length(n_path);
2791 if pl < 1 then exit;
2792 if n_rings < max_rings then
2793 begin
2794 inc(n_rings);
2795 j := 0;
2796 if (n_rings > 1) then
2797 begin
2798 for i := 1 to (n_rings - 1) do
2799 begin
2800 s := ringprop^[i].size;
2801 if (pl >= s) then j := i;
2802 end;
2803 end;
2804 inc(j); // the next position is ours
2805 if (j < n_rings) then
2806 begin // push up the remaining rings by one position
2807 for k := n_rings downto (j+1) do
2808 begin
2809 ringprop^[k].size := ringprop^[(k-1)].size;
2810 for i := 1 to max_ringsize do
2811 begin
2812 ring^[k,i] := ring^[(k-1),i];
2813 end;
2814 end;
2815 end;
2816 ringprop^[j].size := pl;
2817 for i := 1 to max_ringsize do
2818 begin
2819 ring^[j,i] := n_path[i];
2820 end;
2821 end else
2822 begin
2823 {$IFDEF debug}
2824 debugoutput('max_rings exceeded!');
2825 {$ENDIF}
2826 end;
2827 end;
2828
2829
is_ringpathnull2830 function is_ringpath(s_path:ringpath_type):boolean;
2831 var
2832 i, j : integer;
2833 nb : neighbor_rec;
2834 rp, new_atom : boolean;
2835 a_last, pl : integer;
2836 l_path : ringpath_type;
2837 begin
2838 rp := false;
2839 new_atom := false;
2840 fillchar(nb,sizeof(neighbor_rec),0);
2841 fillchar(l_path,sizeof(ringpath_type),0);
2842 pl := path_length(s_path);
2843 if pl < 1 then
2844 begin
2845 {$IFDEF debug}
2846 debugoutput('Oops! Got zero-length s_path!');
2847 {$ENDIF}
2848 exit;
2849 end;
2850 for i := 1 to pl do
2851 begin
2852 l_path[i] := s_path[i];
2853 end;
2854 // check if the last atom is a metal and stop if opt_metalrings is not set (v0.3)
2855 if (opt_metalrings = false) then
2856 begin
2857 if atom^[l_path[pl]].metal then
2858 begin
2859 {$IFDEF debug}
2860 debugoutput('skipping metal in ring search');
2861 {$ENDIF}
2862 is_ringpath := false;
2863 exit;
2864 end;
2865 end;
2866 // check if ring is already closed
2867 if (pl > 2) and (l_path[pl] = l_path[1]) then
2868 begin
2869 l_path[pl] := 0; // remove last entry (redundant!)
2870 order_ringpath(l_path);
2871 if is_newring(l_path) then
2872 begin
2873 if (n_rings < max_rings) then add_ring(l_path) else
2874 begin
2875 {$IFDEF debug}
2876 debugoutput('maximum number of rings exceeded!');
2877 {$ENDIF}
2878 is_ringpath := false;
2879 exit;
2880 end;
2881 end;
2882 rp := true;
2883 is_ringpath := true;
2884 exit;
2885 end;
2886 // any other case: ring is not (yet) closed
2887 a_last := l_path[pl];
2888 nb := get_neighbors(a_last);
2889 if atom^[a_last].neighbor_count > 1 then
2890 begin
2891 if ((rp = false) and (n_rings < max_rings)) then // added in v0.2: check if max_rings is reached
2892 begin // if ring is not closed, continue searching
2893 for i := 1 to atom^[a_last].neighbor_count do
2894 begin
2895 new_atom := true;
2896 for j := 2 to pl do if nb[i] = l_path[j] then
2897 begin // v0.3k
2898 new_atom := false;
2899 break; // v0.3k
2900 end;
2901 // added in v0.1a: check if max_rings not yet reached
2902 // added in v0.2: limit ring size to max_vringsize instead of max_ringsize
2903 if (new_atom) and (pl < max_vringsize) and (n_rings < max_rings) then
2904 begin
2905 l_path[(pl+1)] := nb[i];
2906 if (pl < max_ringsize-1) then l_path[pl+2] := 0; // just to be sure
2907 inc(recursion_level); //
2908 if (recursion_level > max_recursion_depth) then
2909 begin
2910 n_rings := max_rings;
2911 is_ringpath := false;
2912 exit;
2913 end; //
2914 if is_ringpath(l_path) then rp := true;
2915 end;
2916 end;
2917 end;
2918 end;
2919 is_ringpath := rp;
2920 end;
2921
2922
is_ringbondnull2923 function is_ringbond(b_id:integer):boolean;
2924 var
2925 i : integer;
2926 ra1, ra2 : integer;
2927 nb : neighbor_rec;
2928 search_path : ringpath_type;
2929 rb : boolean;
2930 begin
2931 rb := false;
2932 recursion_level := 0;
2933 ra1 := bond^[b_id].a1;
2934 ra2 := bond^[b_id].a2;
2935 fillchar(nb,sizeof(neighbor_rec),0);
2936 fillchar(search_path,sizeof(ringpath_type),0);
2937 nb := get_neighbors(ra2);
2938 if (atom^[ra2].neighbor_count > 1) and (atom^[ra1].neighbor_count > 1) then
2939 begin
2940 search_path[1] := ra1;
2941 search_path[2] := ra2;
2942 for i := 1 to atom^[ra2].neighbor_count do
2943 begin
2944 if (nb[i] <> ra1) and (atom^[nb[i]].heavy) then
2945 begin
2946 search_path[3] := nb[i];
2947 if is_ringpath(search_path) then rb := true;
2948 end;
2949 end;
2950 end;
2951 is_ringbond := rb;
2952 end;
2953
2954
2955 procedure chk_ringbonds;
2956 var
2957 i : integer;
2958 a1rc, a2rc : integer;
2959 begin
2960 if n_bonds < 1 then exit;
2961 for i := 1 to n_bonds do
2962 begin
2963 a1rc := atom^[(bond^[i].a1)].ring_count;
2964 a2rc := atom^[(bond^[i].a2)].ring_count;
2965 if ((n_rings = 0) or ((a1rc < n_rings) and (a2rc < n_rings) )) then
2966 begin
2967 if is_ringbond(i) then
2968 begin
2969 //inc(bond^[i].ring_count);
2970 end;
2971 end;
2972 end;
2973 end;
2974
2975
is_oxo_Cnull2976 function is_oxo_C(id:integer):boolean;
2977 var
2978 i : integer;
2979 r : boolean;
2980 nb : neighbor_rec;
2981 begin
2982 r := false;
2983 fillchar(nb,sizeof(neighbor_rec),0);
2984 if (id < 1) or (id > n_atoms) then exit;
2985 nb := get_neighbors(id);
2986 if (atom^[id].element = 'C ') and (atom^[id].neighbor_count > 0) then
2987 begin
2988 for i := 1 to atom^[id].neighbor_count do
2989 begin
2990 if (bond^[get_bond(id,nb[i])].btype = 'D') and
2991 ((atom^[(nb[i])].element = 'O ') { or
2992 (atom^[(nb[i])].element = 'S ') or
2993 (atom^[(nb[i])].element = 'SE') } ) then // no N, amidines are different...
2994 r := true;
2995 end;
2996 end;
2997 is_oxo_C := r;
2998 end;
2999
3000
is_thioxo_Cnull3001 function is_thioxo_C(id:integer):boolean;
3002 var
3003 i : integer;
3004 r : boolean;
3005 nb : neighbor_rec;
3006 begin
3007 r := false;
3008 fillchar(nb,sizeof(neighbor_rec),0);
3009 if (id < 1) or (id > n_atoms) then exit;
3010 nb := get_neighbors(id);
3011 if (atom^[id].element = 'C ') and (atom^[id].neighbor_count > 0) then
3012 begin
3013 for i := 1 to atom^[id].neighbor_count do
3014 begin
3015 if (bond^[get_bond(id,nb[i])].btype = 'D') and
3016 ((atom^[(nb[i])].element = 'S ') or
3017 (atom^[(nb[i])].element = 'SE')) then // no N, amidines are different...
3018 r := true;
3019 end;
3020 end;
3021 is_thioxo_C := r;
3022 end;
3023
3024
is_exocyclic_imino_Cnull3025 function is_exocyclic_imino_C(id,r_id:integer):boolean;
3026 var
3027 i,j : integer;
3028 r : boolean;
3029 nb : neighbor_rec;
3030 testring : ringpath_type;
3031 ring_size : integer;
3032 begin
3033 r := false;
3034 fillchar(nb,sizeof(neighbor_rec),0);
3035 if (id < 1) or (id > n_atoms) then exit;
3036 nb := get_neighbors(id);
3037 fillchar(testring,sizeof(ringpath_type),0);
3038 for j := 1 to max_ringsize do if ring^[r_id,j] > 0 then testring[j] := ring^[r_id,j];
3039 ring_size := path_length(testring);
3040 if (atom^[id].element = 'C ') and (atom^[id].neighbor_count > 0) then
3041 begin
3042 for i := 1 to atom^[id].neighbor_count do
3043 begin
3044 if (bond^[get_bond(id,nb[i])].btype = 'D') and
3045 (atom^[(nb[i])].element = 'N ') then
3046 begin
3047 r := true;
3048 for j := 1 to ring_size do
3049 if nb[i] = ring^[r_id,j] then r := false;
3050 end;
3051 end;
3052 end;
3053 is_exocyclic_imino_C := r;
3054 end;
3055
3056
find_exocyclic_methylene_Cnull3057 function find_exocyclic_methylene_C(id,r_id:integer):integer;
3058 var // renamed and rewritten in v0.3j
3059 i,j : integer;
3060 r : integer;
3061 nb : neighbor_rec;
3062 testring : ringpath_type;
3063 ring_size : integer;
3064 begin
3065 r := 0;
3066 fillchar(nb,sizeof(neighbor_rec),0);
3067 if (id < 1) or (id > n_atoms) then
3068 begin
3069 find_exocyclic_methylene_C := 0;
3070 exit;
3071 end;
3072 nb := get_neighbors(id);
3073 fillchar(testring,sizeof(ringpath_type),0);
3074 for j := 1 to max_ringsize do if ring^[r_id,j] > 0 then testring[j] := ring^[r_id,j];
3075 ring_size := path_length(testring);
3076 if (atom^[id].element = 'C ') and (atom^[id].neighbor_count > 0) then
3077 begin
3078 for i := 1 to atom^[id].neighbor_count do
3079 begin
3080 if (bond^[get_bond(id,nb[i])].btype = 'D') and
3081 (atom^[(nb[i])].element = 'C ') then
3082 begin
3083 r := nb[i];
3084 for j := 1 to ring_size do
3085 if nb[i] = ring^[r_id,j] then r := 0;
3086 end;
3087 end;
3088 end;
3089 find_exocyclic_methylene_C := r;
3090 end;
3091
3092
is_methylCnull3093 function is_methylC(a1:integer): boolean;
3094 var
3095 res : boolean;
3096 nb : neighbor_rec;
3097 a2, b : integer;
3098 begin
3099 res := false;
3100 if (atom^[a1].atype = 'C3 ') and (atom^[a1].neighbor_count = 1) then
3101 begin
3102 nb := get_neighbors(a1);
3103 a2 := nb[1];
3104 b := get_bond(a1,a2);
3105 if bond^[b].btype = 'S' then res := true;
3106 end;
3107 is_methylC := res;
3108 end;
3109
3110
is_diazoniumnull3111 function is_diazonium(a_view,a_ref:integer):boolean;
3112 var
3113 r : boolean;
3114 nb : neighbor_rec;
3115 bond_count : integer;
3116 chg_count : integer;
3117 n1, n2 : integer;
3118 begin
3119 r := false;
3120 bond_count := 0;
3121 chg_count := 0;
3122 n1 := 0; n2 := 0;
3123 if (is_heavyatom(a_view)) and (bond^[get_bond(a_view,a_ref)].btype = 'S') then
3124 begin
3125 if (atom^[a_ref].element = 'N ') and (atom^[a_ref].neighbor_count = 2) then
3126 begin
3127 n1 := a_ref;
3128 chg_count := atom^[n1].formal_charge;
3129 fillchar(nb,sizeof(neighbor_rec),0);
3130 nb := get_nextneighbors(n1,a_view);
3131 if (atom^[(nb[1])].element = 'N ') then
3132 begin
3133 n2 := nb[1];
3134 chg_count := chg_count + atom^[n2].formal_charge;
3135 if (bond^[get_bond(n1,n2)].btype = 'S') then inc(bond_count);
3136 if (bond^[get_bond(n1,n2)].btype = 'D') then inc(bond_count,2);
3137 if (bond^[get_bond(n1,n2)].btype = 'T') then inc(bond_count,3);
3138 end;
3139 if (n1 > 0) and (n2 > 0) and (atom^[n2].neighbor_count = 1) and
3140 (bond_count >= 2) and (chg_count > 0) then r := true
3141 end;
3142 end;
3143 is_diazonium := r;
3144 end;
3145
3146
3147 procedure update_Htotal;
3148 var
3149 i, j, b_id : integer;
3150 nb : neighbor_rec;
3151 single_count, double_count, triple_count, arom_count : integer;
3152 total_bonds : integer;
3153 Htotal : integer;
3154 nval : integer; // new in v0.3
3155 diazon : boolean; // new in v0.3j
3156 nb2 : neighbor_rec; // new in v0.3j
3157 a1, a2, a3 : integer; // new in v0.3j
3158 begin
3159 if n_atoms < 1 then exit;
3160 diazon := false;
3161 fillchar(nb,sizeof(neighbor_rec),0);
3162 for i := 1 to n_atoms do
3163 begin
3164 single_count := 0;
3165 double_count := 0;
3166 triple_count := 0;
3167 arom_count := 0;
3168 total_bonds := 0;
3169 Htotal := 0;
3170 nb := get_neighbors(i);
3171 if atom^[i].neighbor_count > 0 then
3172 begin // count single, double, triple, and aromatic bonds to all neighbor atoms
3173 for j := 1 to atom^[i].neighbor_count do
3174 begin
3175 b_id := get_bond(i,nb[j]);
3176 if b_id > 0 then
3177 begin
3178 if bond^[b_id].btype = 'S' then inc(single_count);
3179 if bond^[b_id].btype = 'D' then inc(double_count);
3180 if bond^[b_id].btype = 'T' then inc(triple_count);
3181 if bond^[b_id].btype = 'A' then inc(arom_count);
3182 if bond^[b_id].btype = 'a' then inc(single_count); // v0.2b, treat "any" as "single"
3183 end;
3184 end;
3185 //check for diazonium salts
3186 a1 := i; a2 := nb[1];
3187 if (atom^[a1].element = 'N ') and (atom^[a2].element = 'N ') then
3188 begin
3189 if (atom^[a2].neighbor_count = 2) then
3190 begin
3191 nb2 := get_nextneighbors(a2,a1);
3192 a3 := nb2[1];
3193 if (atom^[a3].element = 'C ') and is_diazonium(a3,a2) then diazon := true;
3194 end;
3195 end;
3196 end;
3197 total_bonds := single_count + 2*double_count + 3*triple_count + trunc(1.5*arom_count);
3198 // calculate number of total hydrogens per atom
3199 //nval := nvalences(atom^[i].element); // new in v0.3
3200 nval := atom^[i].nvalences; // new in v0.3m
3201 if (atom^[i].element = 'P ') then
3202 begin
3203 if ((total_bonds - atom^[i].formal_charge) > 3) then nval := 5; // refined in v0.3n
3204 end; //
3205 if (atom^[i].element = 'S ') then // v0.3h
3206 begin
3207 if (total_bonds > 2) and (atom^[i].formal_charge < 1) then nval := 4; // updated in v0.3j
3208 if total_bonds > 4 then nval := 6; // this will need some refinement...
3209 end; //
3210 Htotal := nval - total_bonds + atom^[i].formal_charge;
3211 if (atom^[i].radical_type = 1) or (atom^[i].radical_type = 3) then Htotal := Htotal - 2; // v0.3p
3212 if (atom^[i].radical_type = 2) then Htotal := Htotal - 1; // v0.3p
3213 if diazon then Htotal := 0; // v0.3j
3214 if Htotal < 0 then Htotal := 0; // e.g., N in nitro group
3215 atom^[i].Htot := Htotal;
3216 if atom^[i].Hexp > atom^[i].Htot then atom^[i].Htot := atom^[i].Hexp; // v0.3n; just to be sure...
3217 if is_metal(i) then atom^[i].Htot := atom^[i].Hexp; // v0.2b (accept only explicit H on metals)
3218 end;
3219 end;
3220
3221
3222 procedure update_atypes;
3223 var
3224 i, j, b_id : integer;
3225 nb : neighbor_rec;
3226 single_count, double_count, triple_count, arom_count, acyl_count : integer;
3227 C_count, O_count : integer;
3228 total_bonds : integer;
3229 NdO_count : integer;
3230 NdC_count : integer;
3231 Htotal : integer;
3232 begin
3233 if n_atoms < 1 then exit;
3234 fillchar(nb,sizeof(neighbor_rec),0);
3235 for i := 1 to n_atoms do
3236 begin
3237 single_count := 0;
3238 double_count := 0;
3239 triple_count := 0;
3240 arom_count := 0;
3241 total_bonds := 0;
3242 acyl_count := 0;
3243 C_count := 0;
3244 O_count := 0;
3245 NdO_count := 0;
3246 NdC_count := 0;
3247 Htotal := 0;
3248 nb := get_neighbors(i);
3249 if atom^[i].neighbor_count > 0 then
3250 begin // count single, double, triple, and aromatic bonds to all neighbor atoms
3251 for j := 1 to atom^[i].neighbor_count do
3252 begin
3253 if (is_oxo_C(nb[j])) or (is_thioxo_C(nb[j])) then inc(acyl_count);
3254 if atom^[(nb[j])].element = 'C ' then inc(C_count);
3255 if atom^[(nb[j])].element = 'O ' then inc(O_count);
3256 b_id := get_bond(i,nb[j]);
3257 if b_id > 0 then
3258 begin
3259 if bond^[b_id].btype = 'S' then inc(single_count);
3260 if bond^[b_id].btype = 'D' then inc(double_count);
3261 if bond^[b_id].btype = 'T' then inc(triple_count);
3262 if bond^[b_id].btype = 'A' then inc(arom_count);
3263 if ((atom^[i].element = 'N ') and (atom^[(nb[j])].element = 'O ')) or
3264 ((atom^[i].element = 'O ') and (atom^[(nb[j])].element = 'N ')) then
3265 begin
3266 // check if it is an N-oxide drawn with a double bond ==> should be N3
3267 if bond^[b_id].btype = 'D' then inc(NdO_count);
3268 end;
3269 if ((atom^[i].element = 'N ') and (atom^[(nb[j])].element = 'C ')) or
3270 ((atom^[i].element = 'C ') and (atom^[(nb[j])].element = 'N ')) then
3271 begin
3272 if bond^[b_id].btype = 'D' then inc(NdC_count);
3273 end;
3274 end;
3275 end;
3276 total_bonds := single_count + 2*double_count + 3*triple_count + trunc(1.5*arom_count);
3277 // calculate number of total hydrogens per atom
3278 Htotal := nvalences(atom^[i].element) - total_bonds + atom^[i].formal_charge;
3279 if Htotal < 0 then Htotal := 0; // e.g., N in nitro group
3280 atom^[i].Htot := Htotal;
3281 // refine atom types, based on bond types
3282 if atom^[i].element = 'C ' then
3283 begin
3284 if (arom_count > 1) then atom^[i].atype := 'CAR';
3285 if (triple_count = 1) or (double_count = 2) then atom^[i].atype := 'C1 ';
3286 if (double_count = 1) then atom^[i].atype := 'C2 ';
3287 if (triple_count = 0) and (double_count = 0) and (arom_count < 2) then atom^[i].atype := 'C3 ';
3288 end;
3289 if atom^[i].element = 'O ' then
3290 begin
3291 if (double_count = 1) then atom^[i].atype := 'O2 ';
3292 if (double_count = 0) then atom^[i].atype := 'O3 ';
3293 end;
3294 if atom^[i].element = 'N ' then
3295 begin
3296 if total_bonds > 3 then
3297 begin
3298 if O_count = 0 then
3299 begin
3300 if (single_count > 3) or
3301 ((single_count = 2) and (double_count = 1) and (C_count >=2)) then
3302 atom^[i].formal_charge := 1;
3303 end else // could be an N-oxide -> should be found elsewhere
3304 begin
3305 // left empty, so far....
3306 end;
3307 end;
3308 if (triple_count = 1) or (double_count = 2) then atom^[i].atype := 'N1 ';
3309 if (double_count = 1) then
3310 begin
3311 //if NdC_count > 0 then atom^[i].atype := 'N2 ';
3312 if (NdC_count = 0) and (NdO_count > 0) and
3313 (C_count >= 2) then atom^[i].atype := 'N3 ' // N-oxide is N3 except in hetarene etc.
3314 else atom^[i].atype := 'N2 '; // fallback
3315 end;
3316 if (arom_count > 1) then atom^[i].atype := 'NAR';
3317 if (triple_count = 0) and (double_count = 0) then
3318 begin
3319 if (atom^[i].formal_charge = 0) then
3320 begin
3321 if (acyl_count = 0) then atom^[i].atype := 'N3 ';
3322 if (acyl_count > 0) then atom^[i].atype := 'NAM';
3323 end;
3324 if (atom^[i].formal_charge = 1) then atom^[i].atype := 'N3+';
3325 end;
3326 end;
3327 if atom^[i].element = 'P ' then
3328 begin
3329 if (single_count > 4) then atom^[i].atype := 'P4 ';
3330 if (single_count <= 4) and (double_count = 0) then atom^[i].atype := 'P3 ';
3331 if (double_count = 2) then atom^[i].atype := 'P3D';
3332 end;
3333 if atom^[i].element = 'S ' then
3334 begin
3335 if (double_count = 1) and (single_count = 0) then atom^[i].atype := 'S2 ';
3336 if (double_count = 0) then atom^[i].atype := 'S3 ';
3337 if (double_count = 1) and (single_count > 0) then atom^[i].atype := 'SO ';
3338 if (double_count = 2) and (single_count > 0) then atom^[i].atype := 'SO2';
3339 end;
3340 // further atom types should go here
3341 end;
3342 end;
3343 end;
3344
3345
3346 procedure chk_arom;
3347 var
3348 i, j, pi_count, ring_size : integer;
3349 testring : ringpath_type;
3350 a_ref, a_prev, a_next : integer;
3351 b_bk, b_fw, b_exo : integer;
3352 bt_bk, bt_fw : char;
3353 ar_bk, ar_fw, ar_exo : boolean; // new in v0.3
3354 conj_intr, ko, aromatic : boolean;
3355 n_db, n_sb, n_ar : integer;
3356 cumul : boolean;
3357 exo_mC : integer;
3358 begin
3359 if n_rings < 1 then exit;
3360 // first, do a very quick check for benzene, pyridine, etc.
3361 for i := 1 to n_rings do
3362 begin
3363 ring_size := ringprop^[i].size;
3364 if (ring_size = 6) then
3365 begin
3366 fillchar(testring,sizeof(ringpath_type),0);
3367 for j := 1 to ring_size do testring[j] := ring^[i,j];
3368 cumul := false;
3369 n_sb := 0;
3370 n_db := 0;
3371 n_ar := 0;
3372 a_prev := testring[ring_size];
3373 for j := 1 to ring_size do
3374 begin
3375 a_ref := testring[j];
3376 if (j < ring_size) then a_next := testring[(j+1)] else a_next := testring[1];
3377 b_bk := get_bond(a_prev,a_ref);
3378 b_fw := get_bond(a_ref,a_next);
3379 bt_bk := bond^[b_bk].btype;
3380 bt_fw := bond^[b_fw].btype;
3381 if (bt_fw = 'S') then inc(n_sb);
3382 if (bt_fw = 'D') then inc(n_db);
3383 if (bt_fw = 'A') then inc(n_ar);
3384 if (bt_fw <> 'A') and (bt_bk = bt_fw) then cumul := true;
3385 a_prev := a_ref;
3386 end;
3387 if (n_ar = 6) or ((n_sb = 3) and (n_db = 3) and (cumul = false)) then
3388 begin // this ring is aromatic
3389 a_prev := testring[ring_size];
3390 for j := 1 to ring_size do
3391 begin
3392 a_ref := testring[j];
3393 b_bk := get_bond(a_prev,a_ref);
3394 bond^[b_bk].arom := true;
3395 a_prev := a_ref;
3396 end;
3397 ringprop^[i].arom := true;
3398 end;
3399 end;
3400 end;
3401 for i := 1 to n_rings do
3402 begin
3403 if (ringprop^[i].arom = false) then
3404 begin // do the hard work only for those rings which are not yet flagged aromatic
3405 fillchar(testring,sizeof(ringpath_type),0);
3406 for j := 1 to max_ringsize do if ring^[i,j] > 0 then testring[j] := ring^[i,j];
3407 ring_size := path_length(testring);
3408 {$IFDEF debug}
3409 if (ring_size <> ringprop^[i].size) then
3410 begin
3411 debugoutput('Oops! Ring size mismatch in chk_arom');
3412 end;
3413 {$ENDIF}
3414 pi_count := 0;
3415 conj_intr := false;
3416 ko := false;
3417 a_prev := testring[ring_size];
3418 for j := 1 to ring_size do
3419 begin
3420 a_ref := testring[j];
3421 if (j < ring_size) then a_next := testring[(j+1)] else a_next := testring[1];
3422 b_bk := get_bond(a_prev,a_ref);
3423 b_fw := get_bond(a_ref,a_next);
3424 bt_bk := bond^[b_bk].btype;
3425 bt_fw := bond^[b_fw].btype;
3426 ar_bk := bond^[b_bk].arom;
3427 ar_fw := bond^[b_fw].arom;
3428 if ((bt_bk = 'S') and (bt_fw = 'S') and (ar_bk = false) and (ar_fw = false)) then
3429 begin
3430 // first, assume the worst case (interrupted conjugation)
3431 conj_intr := true;
3432 // conjugation can be restored by hetero atoms
3433 if (atom^[a_ref].atype = 'O3 ') or (atom^[a_ref].atype = 'S3 ') or
3434 (atom^[a_ref].element = 'N ') or (atom^[a_ref].element = 'SE') then
3435 begin
3436 conj_intr := false;
3437 inc(pi_count,2); // lone pair adds for 2 pi electrons
3438 end;
3439 // conjugation can be restored by a formal charge at a methylene group
3440 if (atom^[a_ref].element = 'C ') and (atom^[a_ref].formal_charge <> 0) then
3441 begin
3442 conj_intr := false;
3443 pi_count := pi_count - atom^[a_ref].formal_charge; // neg. charge increases pi_count!
3444 end;
3445 // conjugation can be restored by carbonyl groups etc.
3446 if (is_oxo_C(a_ref)) or (is_thioxo_C(a_ref)) or (is_exocyclic_imino_C(a_ref,i)) then
3447 begin
3448 conj_intr := false;
3449 end;
3450 // conjugation can be restored by exocyclic C=C double bond,
3451 // adds 2 pi electrons to 5-membered rings, not to 7-membered rings (CAUTION!)
3452 // apply only to non-aromatic exocyclic C=C bonds
3453 exo_mC := find_exocyclic_methylene_C(a_ref,i); // v0.3j
3454 if ((exo_mC > 0) and odd(ring_size)) then // v0.3j
3455 begin
3456 b_exo := get_bond(a_ref,exo_mC); // v0.3j
3457 ar_exo := bond^[b_exo].arom;
3458 if ((ring_size - 1) mod 4 = 0) then // 5-membered rings and related
3459 begin
3460 conj_intr := false;
3461 inc(pi_count,2);
3462 end else // 7-membered rings and related
3463 begin
3464 if not ar_exo then conj_intr := false;
3465 end;
3466 end;
3467 // if conjugation is still interrupted ==> knock-out
3468 if conj_intr then ko := true;
3469 end else
3470 begin
3471 if ((bt_bk = 'S') and (bt_fw = 'S') and (ar_bk = true) and (ar_fw = true)) then
3472 begin
3473 if (atom^[a_ref].atype = 'O3 ') or (atom^[a_ref].atype = 'S3 ') or
3474 (atom^[a_ref].element = 'N ') or (atom^[a_ref].element = 'SE') then
3475 begin
3476 inc(pi_count,2); // lone pair adds for 2 pi electrons
3477 end;
3478 if (atom^[a_ref].element = 'C ') and (atom^[a_ref].formal_charge <> 0) then
3479 begin
3480 pi_count := pi_count - atom^[a_ref].formal_charge; // neg. charge increases pi_count!
3481 end;
3482 exo_mC := find_exocyclic_methylene_C(a_ref,i); // v0.3j
3483 if ((exo_mC > 0) and odd(ring_size)) then // v0.3j
3484 begin
3485 b_exo := get_bond(a_ref,exo_mC); // v0.3j
3486 ar_exo := bond^[b_exo].arom;
3487 if ((ring_size - 1) mod 4 = 0) then // 5-membered rings and related
3488 begin
3489 inc(pi_count,2);
3490 end;
3491 end;
3492 end else // any other case: increase pi count by one electron
3493 inc(pi_count);
3494 end;
3495 // last command:
3496 a_prev := a_ref;
3497 end; // for j := 1 to ring_size
3498 // now we can draw our conclusion
3499 if not ((ko) or (odd(pi_count))) then
3500 begin // apply Hueckel's rule
3501 if (abs(ring_size - pi_count) < 2) and ((pi_count - 2) mod 4 = 0) then
3502 begin
3503 // this ring is aromatic
3504 ringprop^[i].arom := true;
3505 // now mark _all_ bonds in the ring as aromatic
3506 a_prev := testring[ring_size];
3507 for j := 1 to ring_size do
3508 begin
3509 a_ref := testring[j];
3510 bond^[get_bond(a_prev,a_ref)].arom := true;
3511 a_prev := a_ref;
3512 end;
3513 end;
3514 end;
3515
3516 end;
3517 end; // (for i := 1 to n_rings)
3518 // finally, mark all involved atoms as aromatic
3519 for i := 1 to n_bonds do
3520 begin
3521 if bond^[i].arom then
3522 begin
3523 atom^[(bond^[i].a1)].arom := true;
3524 atom^[(bond^[i].a2)].arom := true;
3525 end;
3526 end;
3527 // update aromaticity information in ringprop
3528 for i := 1 to n_rings do
3529 begin
3530 testring := ring^[i];
3531 ring_size := path_length(testring);
3532 aromatic := true;
3533 a_prev := testring[ring_size];
3534 for j := 1 to ring_size do
3535 begin
3536 a_ref := testring[j];
3537 if (not bond^[get_bond(a_prev,a_ref)].arom) then aromatic := false;
3538 a_prev := a_ref;
3539 end;
3540 if aromatic then ringprop^[i].arom := true else ringprop^[i].arom := false;
3541 end;
3542 end;
3543
3544
3545 procedure readinputfile(molfilename:string);
3546 var
3547 rline : string;
3548 begin
3549 molbufindex := 0;
3550 if not opt_stdin then
3551 begin
3552 if not rfile_is_open then
3553 begin
3554 assign(rfile,molfilename);
3555 reset(rfile);
3556 rfile_is_open := true;
3557 end;
3558 rline := '';
3559 mol_in_queue := false;
3560 while (not eof(rfile)) and (pos('$$$$',rline) = 0) do
3561 begin
3562 readln(rfile,rline);
3563 //mol_in_queue := false;
3564 if molbufindex < (max_atoms+max_bonds+64) then
3565 begin
3566 inc(molbufindex);
3567 molbuf^[molbufindex] := rline;
3568 end else
3569 begin
3570 writeln('Not enough memory for molfile! ',molbufindex);
3571 close(rfile);
3572 halt(1);
3573 end;
3574 if pos('$$$$',rline) > 0 then mol_in_queue := true;
3575 end;
3576 if eof(rfile) then
3577 begin
3578 close(rfile);
3579 rfile_is_open := false;
3580 mol_in_queue := false;
3581 end;
3582 end else // read from standard input
3583 begin
3584 rline := '';
3585 mol_in_queue := false;
3586 while (not eof) and (pos('$$$$',rline) = 0) do
3587 begin
3588 readln(rline);
3589 if molbufindex < (max_atoms+max_bonds+64) then
3590 begin
3591 inc(molbufindex);
3592 molbuf^[molbufindex] := rline;
3593 end else
3594 begin
3595 writeln('Not enough memory!');
3596 halt(1);
3597 end;
3598 if pos('$$$$',rline) > 0 then mol_in_queue := true;
3599 end;
3600 end;
3601 end;
3602
3603
3604 procedure open_rfile(molfilename:string);
3605 begin
3606 if not opt_stdin then
3607 begin
3608 if not rfile_is_open then
3609 begin
3610 assign(rfile,molfilename);
3611 reset(rfile);
3612 rfile_is_open := true;
3613 end;
3614 if eof(rfile) then
3615 begin
3616 close(rfile);
3617 rfile_is_open := false;
3618 end;
3619 end else
3620 begin
3621 if not rfile_is_open then
3622 begin
3623 assign(rfile,'');
3624 reset(rfile);
3625 //rfile_is_open := true;
3626 end;
3627 if eof(rfile) then
3628 begin
3629 close(rfile);
3630 rfile_is_open := false;
3631 end;
3632 end;
3633 end;
3634
3635
3636 function read_rxnheader:boolean;
3637 var
3638 rline : string;
3639 is_OK : boolean;
3640 n_reactants_str : string;
3641 n_products_str : string;
3642 begin
3643 is_OK := true;
3644 n_reactants_str := '';
3645 n_products_str := '';
3646 readln(rfile,rline); inc(ln);
3647 if (pos('$RDFILE',rline)=1) then // this is an RDF file
3648 begin
3649 while not eof(rfile) and (pos('$RFMT',rline)=0) do
3650 begin
3651 readln(rfile,rline);
3652 inc(ln);
3653 end
3654 end;
3655 while not eof(rfile) and (pos('$RXN',rline)=0) do
3656 begin
3657 readln(rfile,rline); inc(ln); // this should be "$RXN"
3658 end;
3659 if (pos('$RXN',rline)=1) then
3660 begin
3661 readln(rfile,rline); inc(ln);
3662 readln(rfile,rline); inc(ln);
3663 readln(rfile,rline); inc(ln);
3664 readln(rfile,rline); inc(ln);
3665 n_reactants_str := copy(rline,1,3);
3666 n_products_str := copy(rline,4,3);
3667 n_reactants := strtoint(n_reactants_str);
3668 n_products := strtoint(n_products_str);
3669 //writeln('number of reactants: ',n_reactants,' number of products: ',n_products);
3670 end else is_OK := false;
3671 read_rxnheader := is_OK;
3672 end;
3673
3674
3675 procedure read_rxnmol; // v0.2
3676 var
3677 rline : string;
3678 begin
3679 rline := '';
3680 molbufindex := 0;
3681 while not eof(rfile) and (pos('$MOL',rline)=0) do
3682 begin
3683 readln(rfile,rline);
3684 inc(ln);
3685 end;
3686 while not eof(rfile) and (pos('M END',rline)=0) do
3687 begin
3688 readln(rfile,rline); inc(ln);
3689 if molbufindex < (max_atoms+max_bonds+64) then
3690 begin
3691 inc(molbufindex);
3692 molbuf^[molbufindex] := rline;
3693 end else
3694 begin
3695 writeln('Not enough memory for molfile! ',molbufindex);
3696 close(rfile);
3697 halt(1);
3698 end;
3699 end;
3700 li := 1;
3701 read_MDLmolfile('');
3702 end;
3703
3704
3705 procedure skip_data;
3706 var
3707 rline : string;
3708 begin
3709 rline := '';
3710 while not eof(rfile) and (pos('$RFMT',rline)=0) do
3711 begin
3712 readln(rfile,rline);
3713 inc(ln);
3714 end;
3715 end;
3716
3717
3718 procedure clear_rings;
3719 var
3720 i : integer;
3721 begin
3722 n_rings := 0;
3723 fillchar(ring^, sizeof(ringlist),0);
3724 for i := 1 to max_rings do
3725 begin
3726 ringprop^[i].size := 0;
3727 ringprop^[i].arom := false;
3728 ringprop^[i].envelope := false;
3729 end;
3730 if n_atoms > 0 then
3731 begin
3732 for i := 1 to n_atoms do atom^[i].ring_count := 0;
3733 end;
3734 if n_bonds > 0 then
3735 begin
3736 for i := 1 to n_bonds do bond^[i].ring_count := 0;
3737 end;
3738 end;
3739
3740
3741 function ring_lastpos(s:ringpath_type):integer;
3742 var
3743 i, rc, rlp : integer;
3744 begin
3745 rlp := 0;
3746 if n_rings > 0 then
3747 begin
3748 for i := 1 to n_rings do
3749 begin
3750 rc := ringcompare(s, ring^[i]);
3751 if rc_identical(rc) then rlp := i;
3752 end;
3753 end;
3754 ring_lastpos := rlp;
3755 end;
3756
3757
3758 procedure remove_redundant_rings;
3759 var
3760 i, j, k, rlp : integer;
3761 tmp_path : ringpath_type;
3762 begin
3763 if n_rings < 2 then exit;
3764 for i := 1 to (n_rings - 1) do
3765 begin
3766 tmp_path := ring^[i];
3767 rlp := ring_lastpos(tmp_path);
3768 while rlp > i do
3769 begin
3770 for j := rlp to (n_rings - 1) do
3771 begin
3772 ring^[j] := ring^[(j+1)];
3773 ringprop^[j].size := ringprop^[(j+1)].size;
3774 ringprop^[j].arom := ringprop^[(j+1)].arom;
3775 ringprop^[j].envelope := ringprop^[(j+1)].envelope;
3776 end;
3777 for k := 1 to max_ringsize do ring^[n_rings,k] := 0;
3778 dec(n_rings);
3779 rlp := ring_lastpos(tmp_path);
3780 end;
3781 end;
3782 end;
3783
3784
3785 function count_aromatic_rings:integer;
3786 var
3787 i, n : integer;
3788 begin
3789 n := 0;
3790 if n_rings > 0 then
3791 begin
3792 for i := 1 to n_rings do
3793 if ringprop^[i].arom then inc(n);
3794 end;
3795 count_aromatic_rings := n;
3796 end;
3797
3798
3799 procedure chk_envelopes;
3800 // checks if a ring completely contains one or more other rings
3801 var
3802 a,i,j,k,l,pl,pli : integer;
3803 found_atom, found_all_atoms, found_ring : boolean;
3804 begin
3805 if n_rings < 2 then exit;
3806 for i := 2 to n_rings do
3807 begin
3808 found_ring := false;
3809 j := 0;
3810 pli := ringprop^[i].size;
3811 while ((j < (i-1)) and (found_ring = false)) do
3812 begin
3813 inc(j);
3814 found_all_atoms := true;
3815 pl := ringprop^[j].size;
3816 for k := 1 to pl do
3817 begin
3818 found_atom := false;
3819 a := ring^[j,k];
3820 for l := 1 to pli do
3821 begin
3822 if ring^[i,l] = a then found_atom := true;
3823 end;
3824 if found_atom = false then found_all_atoms := false;
3825 end;
3826 if found_all_atoms then found_ring := true;
3827 end;
3828 if found_ring then ringprop^[i].envelope := true;
3829 end;
3830 end;
3831
3832
3833 procedure update_ringcount;
3834 var
3835 i, j, a1, a2, b, pl : integer;
3836 begin
3837 if n_rings > 0 then
3838 begin
3839 chk_envelopes;
3840 for i := 1 to n_rings do
3841 begin
3842 if (ringprop^[i].envelope = false) then
3843 begin
3844 pl := ringprop^[i].size; // path_length(ring^[i]);
3845 a2 := ring^[i,pl];
3846 for j := 1 to pl do
3847 begin
3848 a1 := ring^[i,j];
3849 inc(atom^[a1].ring_count);
3850 b := get_bond(a1,a2);
3851 inc(bond^[b].ring_count);
3852 a2 := a1;
3853 end;
3854 end;
3855 end;
3856 end;
3857 end;
3858
3859 //==================================molecule adjustment routines====
3860
3861 procedure scale_mol;
3862 var
3863 i, a1, a2 : integer;
3864 a1el, a2el : str2;
3865 bt : char;
3866 ar : boolean;
3867 sum_CCsingle : double;
3868 sum_CCdouble : double;
3869 sum_CCarom : double;
3870 sum_XY : double;
3871 n_CCsingle : integer;
3872 n_CCdouble : integer;
3873 n_CCarom : integer;
3874 n_XY : integer;
3875 a1p, a2p : p_3d;
3876 a1a2dist : double;
3877 sf1, sf2, sfa : double;
3878 begin
3879 if n_bonds < 1 then exit;
3880 sum_CCsingle := 0;
3881 sum_CCdouble := 0;
3882 sum_CCarom := 0;
3883 sum_XY := 0;
3884 n_CCsingle := 0;
3885 n_CCdouble := 0;
3886 n_CCarom := 0;
3887 n_XY := 0;
3888 for i := 1 to n_bonds do
3889 begin
3890 ar := bond^[i].arom;
3891 bt := bond^[i].btype;
3892 a1 := bond^[i].a1;
3893 a2 := bond^[i].a2;
3894 a1el := atom^[a1].element;
3895 a2el := atom^[a2].element;
3896 a1p.x := atom^[a1].x;
3897 a1p.y := atom^[a1].y;
3898 a1p.z := atom^[a1].z;
3899 a2p.x := atom^[a2].x;
3900 a2p.y := atom^[a2].y;
3901 a2p.z := atom^[a2].z;
3902 a1a2dist := dist3d(a1p,a2p);
3903 sum_XY := sum_XY + a1a2dist;
3904 inc(n_XY);
3905 if ((a1el = 'C ') and (a2el = 'C ')) then
3906 begin
3907 if (not ar) then
3908 begin
3909 if ((bt = 'S')) then
3910 begin
3911 inc(n_CCsingle);
3912 sum_CCsingle := sum_CCsingle + a1a2dist;
3913 end;
3914 if ((bt = 'D')) then
3915 begin
3916 inc(n_CCdouble);
3917 sum_CCdouble := sum_CCdouble + a1a2dist;
3918 end;
3919 end else
3920 begin
3921 inc(n_CCarom);
3922 sum_CCarom := sum_CCarom + a1a2dist;
3923 end;
3924 end;
3925 end;
3926 sf1 := 1; sf2 := 1; sfa := 1; sf_mol := 1;
3927 if (n_CCsingle > 0) then sf1 := std_blCCsingle / (sum_CCsingle / n_CCsingle);
3928 if (n_CCdouble > 0) then sf2 := std_blCCdouble / (sum_CCdouble / n_CCdouble);
3929 if (n_CCarom > 0) then sfa := std_blCCarom / (sum_CCarom / n_CCarom);
3930 if (n_CCsingle > 0) then
3931 begin
3932 if (n_CCdouble > 0) then
3933 begin
3934 if (n_CCarom > 0) then sf_mol := ((sf1 + sf2 + sfa) / 3) else sf_mol := ((sf1 + sf2) / 2);
3935 end else
3936 begin
3937 if (n_CCarom > 0) then sf_mol := ((sf1 + sfa) / 2) else sf_mol := sf1;
3938 end;
3939 end else
3940 begin
3941 if (n_CCdouble > 0) then
3942 begin
3943 if (n_CCarom > 0) then sf_mol := ((sf2 + sfa) / 2) else sf_mol := sf2;
3944 end else sf_mol := sfa;
3945 end;
3946 if ((n_CCsingle + n_CCdouble + n_CCarom) = 0) then
3947 begin
3948 sf_mol := std_bondlength / (sum_XY / n_XY);
3949 //writeln('% emergency scaling: ',sf_mol:1:4);
3950 end;
3951 if (sf_mol <> 1) then
3952 begin
3953 for i := 1 to n_atoms do
3954 begin
3955 atom^[i].x := atom^[i].x * sf_mol;
3956 atom^[i].y := atom^[i].y * sf_mol;
3957 atom^[i].z := atom^[i].z * sf_mol;
3958 end;
3959 if n_brackets > 0 then
3960 begin
3961 for i := 1 to n_atoms do
3962 begin
3963 with bracket^[i] do
3964 begin
3965 x1 := x1 * sf_mol;
3966 y1 := y1 * sf_mol;
3967 x2 := x2 * sf_mol;
3968 y2 := y2 * sf_mol;
3969 x3 := x3 * sf_mol;
3970 y3 := y3 * sf_mol;
3971 x4 := x4 * sf_mol;
3972 y4 := y4 * sf_mol;
3973 end;
3974 end;
3975 end;
3976 if n_sgroups > 0 then
3977 begin
3978 for i := 1 to n_sgroups do
3979 begin
3980 with sgroup^[i] do
3981 begin
3982 x := x * sf_mol;
3983 y := y * sf_mol;
3984 end;
3985 end;
3986 end;
3987
3988 end;
3989 //if (n_CCsingle > 0 ) then writeln('% avg. C-C single bond length: ',(sum_CCsingle / n_CCsingle):1:4);
3990 //if (n_CCdouble > 0 ) then writeln('% avg. C=C double bond length: ',(sum_CCdouble / n_CCdouble):1:4);
3991 //if (n_CCarom > 0 ) then writeln('% avg. C=C arom. bond length: ',(sum_CCarom / n_CCarom):1:4);
3992 //writeln('% molecule scaled by ',sf_mol:1:5);
3993 end;
3994
3995
3996 procedure center_mol;
3997 var
3998 i : integer;
3999 xmin, xmax, ymin, ymax, zmin, zmax : single;
4000 xcenter, ycenter, zcenter, xcurr : single;
4001 halfheight : single;
4002 al, lstr : string;
4003 ap : integer;
4004 just : char;
4005 lw : double;
4006 begin
4007 if n_atoms = 0 then exit;
4008 xmax := -1000; xmin := 1000;
4009 ymax := -1000; ymin := 1000;
4010 zmax := -1000; zmin := 1000;
4011 for i := 1 to n_atoms do
4012 begin
4013 if atom^[i].x > xmax then xmax := atom^[i].x;
4014 if atom^[i].x < xmin then xmin := atom^[i].x;
4015 if atom^[i].y > ymax then ymax := atom^[i].y;
4016 if atom^[i].y < ymin then ymin := atom^[i].y;
4017 if atom^[i].z > zmax then zmax := atom^[i].z;
4018 if atom^[i].z < zmin then zmin := atom^[i].z;
4019
4020 // check also for left parts of alias labels (the right parts
4021 // will be checked elsewhere) v0.4
4022 if atom^[i].alias <> '' then
4023 begin
4024 xcurr := atom^[i].x;
4025 al := atom^[i].alias;
4026 case atom^[i].a_just of
4027 0 : just := 'L';
4028 1 : just := 'R';
4029 2 : just := 'C';
4030 end;
4031 while (pos('\S',al)>0) do delete(al,pos('\S',al),2);
4032 while (pos('\s',al)>0) do delete(al,pos('\s',al),2);
4033 while (pos('\n',al)>0) do delete(al,pos('\n',al),2);
4034 ap := pos('^',al);
4035 if (ap = 0) then
4036 begin
4037 if (just = 'R') then ap := length(al)-1;
4038 if (just = 'C') then ap := length(al) div 2;
4039 end;
4040 if (ap > 1) then
4041 begin
4042 lstr := copy(al,1,(ap-1));
4043 lw := 0.0375*get_stringwidth(fontsize1,lstr);
4044 if (xcurr - lw) < xmin then xmin := (xcurr - lw);
4045 end;
4046 end;
4047 end;
4048 xcenter := (xmax + xmin) / 2;
4049 ycenter := (ymax + ymin) / 2;
4050 zcenter := (zmax + zmin) / 2;
4051 if rxn_mode then // v0.2
4052 begin
4053 //xcenter := 0; // removed in v0.4b
4054 halfheight := (ymax - ymin) / 2;
4055 if ((ycenter - (ycenter - 1.05*halfheight)) > (yoffset - y_margin)) then
4056 begin
4057 ycenter := ycenter - (1.05*halfheight - (yoffset - y_margin));
4058 end;
4059 end;
4060 for i := 1 to n_atoms do
4061 begin
4062 atom^[i].x := atom^[i].x - xcenter; // v0.2
4063 atom^[i].y := atom^[i].y - ycenter;
4064 atom^[i].z := atom^[i].z - zcenter;
4065 end;
4066 if n_brackets > 0 then // v0.1f
4067 begin
4068 for i := 1 to n_brackets do
4069 begin
4070 with bracket^[i] do
4071 begin
4072 x1 := x1 - xcenter;
4073 y1 := y1 - ycenter;
4074 x2 := x2 - xcenter;
4075 y2 := y2 - ycenter;
4076 x3 := x3 - xcenter;
4077 y3 := y3 - ycenter;
4078 x4 := x4 - xcenter;
4079 y4 := y4 - ycenter;
4080 end;
4081 end;
4082 end;
4083 if n_sgroups > 0 then // v0.1f
4084 begin
4085 for i := 1 to n_sgroups do
4086 begin
4087 with sgroup^[i] do
4088 begin
4089 x := x - xcenter;
4090 y := y - ycenter;
4091 end;
4092 end;
4093 end;
4094 if not rxn_mode then
4095 begin
4096 xoffset := abs(xcenter-xmin) + 1.75; // may require some adjustment
4097 yoffset := abs(ycenter-ymin) + 1.2; // may require some adjustment
4098 maxY := 2 * yoffset;
4099 end;
4100 end;
4101
4102
4103 function get_pivotscore(r:integer):integer;
4104 var
4105 j : integer;
4106 a1, a2, b, rc, nrc, maxrc, rs : integer;
4107 ar : boolean;
4108 res : integer;
4109 begin
4110 res := 0;
4111 if (n_rings >= r) then
4112 begin
4113 rs := ringprop^[r].size;
4114 ar := ringprop^[r].arom;
4115 a2 := ring^[r,rs];
4116 maxrc := 1;
4117 nrc := 0;
4118 for j := 1 to rs do
4119 begin
4120 a1 := ring^[r,j];
4121 b := get_bond(a1,a2);
4122 rc := bond^[b].ring_count;
4123 if rc > maxrc then maxrc := rc;
4124 if rc > 1 then inc(nrc);
4125 a2 := a1;
4126 end;
4127 if ar then res := res + 1000;
4128 res := res + maxrc * 10 + nrc * 100;
4129 res := res + (max_ringsize - (6 - rs));
4130 end;
4131 get_pivotscore := res;
4132 end;
4133
4134
4135 function find_pivotring:integer;
4136 var
4137 i : integer;
4138 p, pscore : integer;
4139 res : integer;
4140 begin
4141 res := 0;
4142 pscore := 0;
4143 if (n_rings > 0) then
4144 begin
4145 for i := 1 to n_rings do
4146 begin
4147 if (not ringprop^[i].envelope) then
4148 begin
4149 p := get_pivotscore(i);
4150 //writeln('% pivotscore for ring ',i,': ',p);
4151 if p > pscore then
4152 begin
4153 pscore := p;
4154 res := i;
4155 end;
4156 end;
4157 end;
4158 end;
4159 find_pivotring := res;
4160 end;
4161
4162
4163 procedure rotxz(theta:double);
4164 var
4165 i : integer;
4166 cost, sint : double;
4167 ax, az : double;
4168 begin
4169 cost := cos(theta);
4170 sint := sin(theta);
4171 for i := 1 to n_atoms do
4172 begin
4173 ax := atom^[i].x;
4174 az := atom^[i].z;
4175 atom^[i].x := cost*ax - sint*az;
4176 atom^[i].z := cost*az + sint*ax;
4177 end;
4178 end;
4179
4180
4181 procedure rotxy(theta:double);
4182 var
4183 i : integer;
4184 cost, sint : double;
4185 ax, ay : double;
4186 begin
4187 cost := cos(theta);
4188 sint := sin(theta);
4189 for i := 1 to n_atoms do
4190 begin
4191 ax := atom^[i].x;
4192 ay := atom^[i].y;
4193 atom^[i].x := cost*ax - sint*ay;
4194 atom^[i].y := cost*ay + sint*ax;
4195 end;
4196 end;
4197
4198
4199 procedure rotzy(theta:double);
4200 var
4201 i : integer;
4202 cost, sint : double;
4203 az, ay : double;
4204 begin
4205 cost := cos(theta);
4206 sint := sin(theta);
4207 for i := 1 to n_atoms do
4208 begin
4209 az := atom^[i].z;
4210 ay := atom^[i].y;
4211 atom^[i].z := cost*az - sint*ay;
4212 atom^[i].y := cost*ay + sint*az;
4213 end;
4214 end;
4215
4216
4217 function find_pivotbond(r:integer):integer;
4218 var
4219 j : integer;
4220 a1, a2, b, rc, maxrc, rs : integer;
4221 res : integer;
4222 begin
4223 res := 0;
4224 if (n_rings >= r) then
4225 begin
4226 rs := ringprop^[r].size;
4227 a2 := ring^[r,rs];
4228 maxrc := 1;
4229 for j := 1 to rs do
4230 begin
4231 a1 := ring^[r,j];
4232 b := get_bond(a1,a2);
4233 rc := bond^[b].ring_count;
4234 if rc > maxrc then
4235 begin
4236 maxrc := rc;
4237 res := b;
4238 end;
4239 a2 := a1;
4240 end;
4241 end;
4242 find_pivotbond := res;
4243 end;
4244
4245
4246 procedure rotate_mol;
4247 var
4248 pr, pb : integer;
4249 acorner, a1, a2 : integer;
4250 rs, a1pos, a2pos : integer;
4251 acp, a1p, a2p, pp, refp, viewp : p_3d;
4252 ppnorm, origin, dummy : p_3d;
4253 xyangle, xzangle, yzangle : double;
4254 begin
4255 if n_brackets > 0 then exit; // avoid any rotation when brackets are present; v0.1f
4256 if (n_sgroups > 0) and (opt_sgroups = true) then exit; // v0.2a
4257 if (n_rings < 1) then
4258 begin
4259 // whatever...
4260 end else
4261 begin
4262 pr := find_pivotring;
4263 if (pr > 0) and (pr <= n_rings) then
4264 begin
4265 rs := ringprop^[pr].size;
4266 a1pos := 1 + round(rs/3);
4267 a2pos := (rs + 1) - round(rs/3);
4268 acorner := ring^[pr,1];
4269 a1 := ring^[pr,a1pos];
4270 a2 := ring^[pr,a2pos];
4271 origin.x := 0; origin.y := 0; origin.z := 0;
4272 acp.x := atom^[acorner].x; acp.y := atom^[acorner].y; acp.z := atom^[acorner].z;
4273 a1p.x := atom^[a1].x; a1p.y := atom^[a1].y; a1p.z := atom^[a1].z;
4274 a2p.x := atom^[a2].x; a2p.y := atom^[a2].y; a2p.z := atom^[a2].z;
4275 pp := cross_prod(acp,a1p,a2p); // normal vector
4276 if (pp.z < acp.z) then pp := cross_prod(acp,a2p,a1p);
4277 ppnorm := pp;
4278 dummy := acp;
4279 vec2origin(dummy,ppnorm);
4280 //====now get the angles
4281 // XZ (rotate around Y axis
4282 refp.x := 0; refp.y := 0; refp.z := 2;
4283 viewp.x := 0; viewp.y := 2; viewp.z := 0;
4284 xzangle := ctorsion(viewp,origin,refp,ppnorm);
4285 // YZ (rotate around X axis
4286 viewp.x := 2; viewp.y := 0; viewp.z := 0;
4287 yzangle := ctorsion(viewp,origin,refp,ppnorm);
4288 if (abs(xzangle) > 0) then
4289 begin
4290 rotxz(xzangle);
4291 yrot := xzangle;
4292 end;
4293 if (abs(yzangle) > 0) then
4294 begin
4295 rotzy(yzangle);
4296 xrot := yzangle;
4297 end;
4298 pb := 0;
4299 pb := find_pivotbond(pr);
4300 if (pb > 0) then
4301 begin
4302 a1 := bond^[pb].a1;
4303 a2 := bond^[pb].a2;
4304 a1p.x := atom^[a1].x; a1p.y := atom^[a1].y; a1p.z := atom^[a1].z;
4305 a2p.x := atom^[a2].x; a2p.y := atom^[a2].y; a2p.z := atom^[a2].z;
4306 refp.x := a1p.x; refp.y := (a1p.y + 2); refp.z := a1p.z;
4307 viewp.x := a1p.x; viewp.y := a1p.y; viewp.z := (a1p.z + 2);
4308 if (a2p.y < a1p.y) then refp.y := (a1p.y - 2);
4309 xyangle := ctorsion(viewp,a1p,refp,a2p);
4310 if (abs(xyangle) > 0) then
4311 begin
4312 rotxy(-xyangle);
4313 zrot := xyangle;
4314 end;
4315 end;
4316 end;
4317 end;
4318 end;
4319
4320
4321 function is_3dfile:boolean;
4322 var
4323 i : integer;
4324 res : boolean;
4325 begin
4326 res := false;
4327 if (n_atoms > 0) then
4328 begin
4329 for i := 1 to n_atoms do if (atom^[i].z <> 0) then res := true;
4330 end;
4331 is_3dfile := res;
4332 end;
4333
4334
4335 procedure adjust_mol;
4336 begin
4337 if opt_autoscale then scale_mol;
4338 if opt_autorotate or (opt_autorotate3Donly and is_3dfile) then rotate_mol else
4339 begin
4340 if (xrot <> 0) then rotzy(xrot);
4341 if (yrot <> 0) then rotxz(yrot);
4342 if (zrot <> 0) then rotxy(zrot);
4343 end;
4344 center_mol;
4345 end;
4346
4347
4348 function in_ring(r,a1,a2,a3:integer):boolean;
4349 var
4350 j : integer;
4351 res : boolean;
4352 complete : boolean;
4353 missing : boolean;
4354 begin
4355 res := false;
4356 if n_rings >= r then
4357 begin
4358 complete := true;
4359 missing := true;
4360 for j := 1 to max_ringsize do
4361 begin
4362 if ring^[r,j] = a1 then missing := false;
4363 end;
4364 if missing then complete := false;
4365 missing := true;
4366 for j := 1 to max_ringsize do
4367 begin
4368 if ring^[r,j] = a2 then missing := false;
4369 end;
4370 if missing then complete := false;
4371 missing := true;
4372 for j := 1 to max_ringsize do
4373 begin
4374 if ring^[r,j] = a3 then missing := false;
4375 end;
4376 if missing then complete := false;
4377 if complete then res := true;
4378 end;
4379 in_ring := res;
4380 end;
4381
4382
4383 function is_kekulering(r:integer):boolean;
4384 var
4385 i : integer;
4386 res : boolean;
4387 a1, a2 : integer;
4388 bt : char;
4389 b, rs : integer;
4390 ns, nd, na : integer;
4391 begin
4392 res := false;
4393 if n_rings >= r then
4394 begin
4395 rs := ringprop^[r].size;
4396 a1 := ring^[r,rs];
4397 ns := 0; nd := 0; na := 0;
4398 for i := 1 to rs do
4399 begin
4400 a2 := ring^[r,i];
4401 b := get_bond(a1,a2);
4402 bt := bond^[b].btype;
4403 if bt = 'D' then inc(nd);
4404 if bt = 'S' then inc(ns);
4405 if bt = 'A' then inc(na);
4406 a1 := a2;
4407 end;
4408 if na = rs then res := true;
4409 if (ns > 0) and (nd > 0) and (ns = nd) then res := true;
4410 end;
4411 if not ringprop^[r].arom then res := false;
4412 is_kekulering := res;
4413 end;
4414
4415
4416 function get_ringscore(a1,a2,a3:integer):integer;
4417 var
4418 i : integer;
4419 res : integer;
4420 atoms_in_ring : boolean;
4421 atoms_in_aromring : boolean;
4422 atoms_in_kekulering : boolean;
4423 rsize : integer;
4424 begin
4425 res := 0;
4426 if (n_rings > 0) then
4427 begin
4428 atoms_in_ring := false;
4429 atoms_in_aromring := false;
4430 atoms_in_kekulering := false;
4431 rsize := max_ringsize;
4432 for i := 1 to n_rings do
4433 begin
4434 if in_ring(i,a1,a2,a3) then
4435 begin
4436 atoms_in_ring := true;
4437 if ringprop^[i].arom then atoms_in_aromring := true;
4438 if ringprop^[i].size < rsize then rsize := ringprop^[i].size;
4439 if is_kekulering(i) then atoms_in_kekulering := true;
4440 end;
4441 end;
4442 if atoms_in_ring then res := res + 10;
4443 if atoms_in_aromring then res := res + 1000;
4444 if atoms_in_kekulering then res := res + 1;
4445 case rsize of
4446 6 : res := res + 100;
4447 5 : res := res + 90;
4448 7 : res := res + 80;
4449 8 : res := res + 70;
4450 9 : res := res + 60;
4451 10 : res := res + 50;
4452 end;
4453 end;
4454 get_ringscore := res;
4455 end;
4456
4457
4458 procedure refine_bonds;
4459 var
4460 i, j : integer;
4461 ba1, ba2 : integer;
4462 nb1, nb2 : neighbor_rec;
4463 nb_bond : integer;
4464 cand1, cand2 : integer;
4465 rs1, rs2 : integer;
4466 begin
4467 if n_bonds < 1 then exit;
4468 for i := 1 to n_bonds do
4469 begin
4470 if ((bond^[i].btype = 'D') or (bond^[i].btype = 'A')) then
4471 begin
4472 ba1 := bond^[i].a1;
4473 ba2 := bond^[i].a2;
4474 if (atom^[ba1].neighbor_count = 1) and (atom^[ba2].neighbor_count > 1) then
4475 begin
4476 nb2 := get_nextneighbors(ba2,ba1);
4477 bond^[i].bsubtype := 'A';
4478 bond^[i].a_handle := nb2[1];
4479 if (atom^[ba2].neighbor_count >= 2) then
4480 begin
4481 for j := 1 to atom^[ba2].neighbor_count do
4482 begin
4483 nb_bond := get_bond(ba2,nb2[j]);
4484 if (bond^[nb_bond].btype = 'D') then // ==> allene, sulfate etc.!
4485 begin
4486 bond^[i].bsubtype := 'N';
4487 bond^[i].a_handle := 0;
4488 end;
4489 end;
4490 end;
4491 if (atom^[ba2].neighbor_count >= 3) then
4492 begin
4493 bond^[i].bsubtype := 'N';
4494 end;
4495 end;
4496 if (atom^[ba1].neighbor_count > 1) and (atom^[ba2].neighbor_count = 1) then
4497 begin
4498 nb1 := get_nextneighbors(ba1,ba2);
4499 bond^[i].bsubtype := 'A';
4500 bond^[i].a_handle := nb1[1];
4501 if (atom^[ba1].neighbor_count >= 2) then
4502 begin
4503 for j := 1 to atom^[ba1].neighbor_count do
4504 begin
4505 nb_bond := get_bond(ba1,nb1[j]);
4506 if (bond^[nb_bond].btype = 'D') then // ==> allene, sulfate etc.!
4507 begin
4508 bond^[i].bsubtype := 'N';
4509 bond^[i].a_handle := 0;
4510 end;
4511 end;
4512 end;
4513 if (atom^[ba1].neighbor_count >= 3) then
4514 begin
4515 bond^[i].bsubtype := 'N';
4516 end;
4517 end;
4518 if (atom^[ba1].neighbor_count = 2) and (atom^[ba2].neighbor_count = 2) then
4519 begin
4520 nb1 := get_nextneighbors(ba1,ba2);
4521 nb2 := get_nextneighbors(ba2,ba1);
4522 bond^[i].bsubtype := 'A';
4523 cand1 := nb1[1];
4524 cand2 := nb2[1];
4525 if is_heavyatom(cand1) then bond^[i].a_handle := cand1 else
4526 bond^[i].a_handle := cand2; // some more refinement still missing....
4527 end;
4528 if (atom^[ba1].neighbor_count = 2) and (atom^[ba2].neighbor_count = 3) then
4529 begin
4530 nb1 := get_nextneighbors(ba1,ba2);
4531 bond^[i].bsubtype := 'A';
4532 bond^[i].a_handle := nb1[1];
4533 end;
4534 if (atom^[ba1].neighbor_count = 3) and (atom^[ba2].neighbor_count = 2) then
4535 begin
4536 nb2 := get_nextneighbors(ba2,ba1);
4537 bond^[i].bsubtype := 'A';
4538 bond^[i].a_handle := nb2[1];
4539 end;
4540 if (atom^[ba1].neighbor_count = 3) and (atom^[ba2].neighbor_count = 3) then
4541 begin
4542 nb1 := get_nextneighbors(ba1,ba2);
4543 cand1 := nb1[1];
4544 cand2 := nb1[2];
4545 rs1 := get_ringscore(cand1,ba1,ba2);
4546 rs2 := get_ringscore(cand2,ba1,ba2);
4547 bond^[i].a_handle := cand1; // default
4548 if (rs1 <> rs2) then
4549 begin
4550 bond^[i].bsubtype := 'A';
4551 if rs1 > rs2 then bond^[i].a_handle := cand1 else
4552 bond^[i].a_handle := cand2;
4553 end else
4554 begin
4555 nb2 := get_nextneighbors(ba2,ba1);
4556 cand1 := nb2[1];
4557 cand2 := nb2[2];
4558 rs1 := get_ringscore(cand1,ba1,ba2);
4559 rs2 := get_ringscore(cand2,ba1,ba2);
4560 bond^[i].a_handle := cand1; // default
4561 if (rs1 <> rs2) then
4562 begin
4563 bond^[i].bsubtype := 'A';
4564 if rs1 > rs2 then bond^[i].a_handle := cand1 else
4565 bond^[i].a_handle := cand2;
4566 end else
4567 begin
4568 if (rs1 > 0) then
4569 begin
4570 bond^[i].bsubtype := 'A';
4571 bond^[i].a_handle := cand1;
4572 end;
4573 end;
4574 end;
4575 end;
4576 if (opt_stripH = false) then // v0.1f
4577 begin
4578 if ((atom^[ba1].neighbor_count + atom^[ba1].Hexp = 1) or
4579 (atom^[ba1].neighbor_count + atom^[ba1].Hexp >= 3)) and
4580 ((atom^[ba2].neighbor_count + atom^[ba2].Hexp = 1) or
4581 (atom^[ba2].neighbor_count + atom^[ba2].Hexp >= 3)) then
4582 begin
4583 if (bond^[i].ring_count = 0) then bond^[i].bsubtype := 'N';
4584 end;
4585 end;
4586 end; // end check of double bonds
4587 if ((bond^[i].btype = 'S') and (bond^[i].stereo = bstereo_up)) then
4588 bond^[i].bsubtype := 'W';
4589 if ((bond^[i].btype = 'S') and (bond^[i].stereo = bstereo_down)) then
4590 bond^[i].bsubtype := 'H';
4591 end;
4592 for i := 1 to n_bonds do // 2nd run
4593 begin
4594 if ((bond^[i].btype = 'D') and (bond^[i].a_handle = 0)) then
4595 begin
4596 ba1 := bond^[i].a1;
4597 ba2 := bond^[i].a2;
4598 if ((atom^[ba1].neighbor_count = 1) and (atom^[ba2].neighbor_count = 2)) then
4599 begin
4600 nb2 := get_nextneighbors(ba2,ba1);
4601 nb_bond := get_bond(ba2,nb2[1]);
4602 if (bond^[nb_bond].btype = 'D') then // ==> allene etc.!
4603 begin
4604 if (bond^[nb_bond].a_handle > 0) then bond^[i].a_handle := bond^[nb_bond].a_handle;
4605 bond^[i].bsubtype := bond^[nb_bond].bsubtype;
4606 end;
4607 end;
4608 if ((atom^[ba1].neighbor_count = 2) and (atom^[ba2].neighbor_count = 1)) then
4609 begin
4610 nb1 := get_nextneighbors(ba1,ba2);
4611 nb_bond := get_bond(ba1,nb1[1]);
4612 if (bond^[nb_bond].btype = 'D') then // ==> allene etc.!
4613 begin
4614 if (bond^[nb_bond].a_handle > 0) then bond^[i].a_handle := bond^[nb_bond].a_handle;
4615 bond^[i].bsubtype := bond^[nb_bond].bsubtype;
4616 end;
4617 end;
4618 end;
4619 end;
4620 end;
4621
4622
4623 procedure chk_hidden;
4624 var
4625 i, j : integer;
4626 a1, a2, b : integer;
4627 el1, el2 : str2;
4628 nb : neighbor_rec;
4629 n_db : integer;
4630 begin
4631 if n_atoms > 0 then
4632 begin
4633 for i := 1 to n_atoms do
4634 begin
4635 el1 := atom^[i].element;
4636 nb := get_neighbors(i);
4637 a1 := i;
4638 n_db := 0;
4639 for j := 1 to atom^[i].neighbor_count do
4640 begin
4641 a2 := nb[j];
4642 b := get_bond(a1,a2);
4643 if (bond^[b].btype = 'D') then inc(n_db);
4644 end;
4645 if (atom^[i].alias <> '') then atom^[i].hidden := false; // v0.2b
4646 if (el1 = 'C ') then atom^[i].hidden := true else atom^[i].hidden := false;
4647 if (el1 = 'C ') and (atom^[i].neighbor_count = 2) and (n_db = 2) then atom^[i].hidden := false;
4648 if (el1 = 'H ') and opt_stripH then atom^[i].hidden := true;
4649 if (opt_Honmethyl and is_methylC(i) and opt_stripH) then atom^[i].hidden := false;
4650 //if atom^[i].formal_charge <> 0 then atom^[i].hidden := false; // v0.1d
4651 if atom^[i].nucleon_number > 0 then atom^[i].hidden := false;
4652 atom^[i].tag := false; // reset atom tags; v0.1f
4653 end;
4654 end;
4655 if n_bonds > 0 then
4656 begin
4657 for i := 1 to n_bonds do
4658 begin
4659 a1 := bond^[i].a1;
4660 a2 := bond^[i].a2;
4661 el1 := atom^[a1].element;
4662 el2 := atom^[a2].element;
4663 bond^[i].hidden := false;
4664 if (el1 = 'H ') or (el2 = 'H ') then
4665 begin
4666 if opt_stripH then bond^[i].hidden := true;
4667 if (el1 = 'H ') and (el2 = 'H ') then bond^[i].hidden := false;
4668 if opt_Honstereo then
4669 begin
4670 if (bond^[i].stereo = bstereo_up) or (bond^[i].stereo = bstereo_down) then
4671 begin
4672 bond^[i].hidden := false;
4673 if (el1 = 'H ') then
4674 begin
4675 atom^[a1].hidden := false;
4676 if is_methylC(a2) then atom^[a2].hidden := true;
4677 end;
4678 if (el2 = 'H ') then
4679 begin
4680 atom^[a2].hidden := false;
4681 if is_methylC(a1) then atom^[a1].hidden := true;
4682 end;
4683 end;
4684 end;
4685 if (el1 = 'H ') and (atom^[a1].nucleon_number > 0) then
4686 begin
4687 bond^[i].hidden := false;
4688 atom^[a2].tag := true; // v0.1f; mark Deuterium or Tritium-bearing atoms
4689 end;
4690 if (el2 = 'H ') and (atom^[a2].nucleon_number > 0) then
4691 begin
4692 bond^[i].hidden := false;
4693 atom^[a1].tag := true; // v0.1f
4694 end;
4695 end;
4696 end;
4697 end;
4698 end;
4699
4700 //==============================Postscript and SVG output routines======
4701
4702 procedure printBBdef;
4703 begin
4704 writeln('/bb {');
4705 //writeln('1.0 setgray');
4706 writeln(bgrgbstr,' setrgbcolor');
4707 writeln('CFont');
4708 writeln('newpath X dot Y dot moveto');
4709 writeln('anchor stringwidth pop 2 div ',lblmargin:1:1,' add neg 0 rmoveto');
4710 writeln('0 fs1 2.5 div ',lblmargin:1:1,' add neg rmoveto');
4711 writeln('0 fs1 2.5 div 2 mul ',2*lblmargin:1:1,' add rlineto');
4712 writeln('anchor stringwidth pop ',2*lblmargin:1:1,' add 0 rlineto');
4713 writeln('0 fs1 2.5 div 2 mul ',2*lblmargin:1:1,' add neg rlineto');
4714 writeln('closepath fill');
4715 //writeln('0.0 setgray');
4716 writeln('0 0 0 setrgbcolor');
4717 writeln('X dot Y dot moveto');
4718 writeln('} bind def');
4719 writeln;
4720 end;
4721
4722
4723 procedure printBBXdef;
4724 begin
4725 writeln('/bbx {');
4726 //writeln('1.0 setgray');
4727 writeln(bgrgbstr,' setrgbcolor');
4728 writeln('CFont');
4729 writeln('newpath X dot Y dot moveto');
4730 writeln('anchor stringwidth pop 2 div ',lblmargin:1:1,' add neg 0 rmoveto');
4731 writeln('0 fs1 2.5 div neg rmoveto'); // bottom left
4732 writeln('0 fs1 2.5 div 2 mul rlineto'); // top left
4733 writeln('anchor stringwidth pop ',2*lblmargin:1:1,' add 0 rlineto'); // top right, big box
4734 // extra box for "+" or "-" sign
4735 writeln('0 fs1 6 div rlineto'); // top/top left
4736 writeln('fs1 2 div 0 rlineto'); // top/top right
4737 writeln('0 fs1 2 div neg rlineto'); // top/bottom right
4738 writeln('fs1 2 div neg 0 rlineto'); // compensates for the extra upshift
4739 writeln('0 fs1 2 div neg rlineto'); // back on track
4740 writeln('closepath fill');
4741 //writeln('0.0 setgray');
4742 writeln('0 0 0 setrgbcolor');
4743 writeln('X dot Y dot moveto');
4744 writeln('} bind def');
4745 writeln;
4746 end;
4747
4748
4749 procedure write_PS_init;
4750 begin
4751 bgrgbstr := format('%1.2f %1.2f %1.2f',[(bgcolor.r/255),(bgcolor.g/255),(bgcolor.b/255)],fsettings);
4752 calc_PSboundingbox;
4753 if opt_eps then
4754 begin
4755 writeln('%!PS-Adobe-3.0 EPSF-3.0');
4756 write_PSboundingbox;
4757 end else writeln('%!PS-Adobe-2.0');
4758 writeln('%%Creator: mol2ps ',version,', Norbert Haider, University of Vienna, 2014');
4759 if not opt_stdin then
4760 writeln('%%Title: ',molfilename) else
4761 writeln('%%Title: reading from standard input');
4762 writeln('% the following settings were used:');
4763 writeln('% font: ',fontname,' ',fontsize1,' pt (',fontsize2,' pt for subscripts)');
4764 writeln('% line width: ',linewidth:1:1);
4765 if opt_autorotate or (opt_autorotate3Donly and is_3dfile) then
4766 begin
4767 writeln('% automatic rotation: ');
4768 writeln('% ',radtodeg(xrot):1:2,'� around X axis');
4769 writeln('% ',radtodeg(yrot):1:2,'� around Y axis');
4770 writeln('% ',radtodeg(zrot):1:2,'� around Z axis');
4771 end else
4772 begin
4773 if (xrot <> 0) or (yrot <> 0) or (zrot <> 0) then
4774 begin
4775 writeln('% user-specified rotation: ');
4776 if (xrot <> 0) then writeln('% ',radtodeg(xrot):1:2,'� around X axis');
4777 if (yrot <> 0) then writeln('% ',radtodeg(yrot):1:2,'� around Y axis');
4778 if (zrot <> 0) then writeln('% ',radtodeg(zrot):1:2,'� around Z axis');
4779 end;
4780 end;
4781 write('% automatic scaling: ');
4782 if opt_autoscale then writeln('on') else writeln('off');
4783 if (sf_mol <> 1.0) then writeln('% molecule scaled by ',sf_mol:1:5);
4784 write('% stripping of explicit hydrogens: ');
4785 if opt_stripH then writeln('on') else writeln('off');
4786 write('% hydrogen on hetero atoms: ');
4787 if opt_Honhetero then writeln('on') else writeln('off');
4788 write('% print molecule name above structure: ');
4789 if opt_showmolname then writeln('on') else writeln('off');
4790 if opt_bgcolor then write_PSbg;
4791 writeln;
4792 writeln('% for manual (re-)scaling, please edit the following line:');
4793 writeln(' ',global_scaling:1:2,' ',global_scaling:1:2,' scale');
4794 writeln;
4795 writeln('gsave');
4796 writeln('/dot {.24 mul} def');
4797 writeln('0 0 0 setrgbcolor'); // v0.4a
4798 writeln(linewidth:1:1,' setlinewidth');
4799 writeln('1 setlinecap');
4800 writeln('1 setlinejoin');
4801 writeln('/fs1 ',fontsize1,' def');
4802 writeln('/fs2 ',fontsize2,' def');
4803 writeln('/fs3 ',round((fontsize1+fontsize2)/2),' def');
4804 writeln('/CFont { /',fontname,' findfont fs1 scalefont setfont } def');
4805 writeln('/CFontSub { /',fontname,' findfont fs2 scalefont setfont } def');
4806 writeln('/CFontChg { /Courier-Bold findfont fs3 scalefont setfont } def');
4807 if (opt_atomnum or opt_bondnum or opt_maps) then
4808 begin
4809 writeln('/fs4 ',round(fontsize1 / 2.5),' def');
4810 writeln('/CFontNum { /',fontname,' findfont fs4 scalefont setfont } def');
4811 end;
4812 writeln('/Minus { (-) show } def'); // with Courier we don't need '--'
4813 writeln('/Rad1 { (:) show } def');
4814 //writeln('/Rad2 { (.) show } def');
4815 writeln('/Rad2 { (\267) show } def');
4816 writeln('/Rad3 { /Helvetica-Bold findfont fs3 1.4 div scalefont setfont (^^) show } def');
4817 writeln;
4818 printBBdef;
4819 printBBXdef;
4820 end;
4821
4822 procedure write_SVG_init;
4823 var
4824 ymaxtotal : double;
4825 ymintotal : double;
4826 ydiff : double;
4827 ydiffscaled : double;
4828 xmaxscaled : double;
4829 ymaxscaled : double;
4830 yminscaled : double;
4831 rgbhex : string;
4832 begin
4833 rgbhex := '#' + inttohex(bgcolor.r,2) + inttohex(bgcolor.g,2) + inttohex(bgcolor.b,2);
4834
4835 ymaxtotal := svg_max_y + ymargin + max_ytrans;
4836 ymintotal := svg_min_y - 25 + max_ytrans;
4837 ydiff := (svg_max_y + 25) - (svg_min_y -25);
4838 ydiffscaled := ydiff * global_scaling;
4839 xmaxscaled := (svg_max_x + 20) * global_scaling;
4840 ymaxscaled := ymaxtotal * global_scaling;
4841 yminscaled := ymintotal * global_scaling;
4842 // $svgline[1] = "<svg width=\"$xmaxscaled\" height=\"$ydiffscaled\" viewbox=\"0 $ymintotal $xmaxval $ydiff\" xmlns=\"http://www.w3.org/2000/svg\">";
4843
4844 // the width and height values are placeholders; correct values will be determined during
4845 // plotting and will be appended at the end of the output, so they can be applied to the
4846 // final SVG file by a wrapper script
4847 writeln('<?xml version="1.0" standalone="no" ?>');
4848 writeln('<svg width="',xmaxscaled:1:0,'" height="',ydiffscaled:1:0,'" viewbox="0 ',ymintotal:1:0,' ',(svg_max_x + 20):1:0,' ',ydiff:1:0,'" xmlns="http://www.w3.org/2000/svg">');
4849 writeln('<style type="text/css"><![CDATA[ circle { stroke: ',rgbhex,'; fill: ',rgbhex,'; }');
4850 writeln('text { font-family: ',fontname,'; font-size: ',fontsize1,'px; } line { stroke: #000000; stroke-width: ',linewidth:1:1,'; } ]]> </style>');
4851 writeln('<g>');
4852 writeln;
4853 if opt_bgcolor then
4854 begin
4855 writeln('<rect x="0" y="',ymintotal:1:0,'" width="',(svg_max_x + 20):1:0,'" height="',ydiff:1:0,'" style="fill: ',rgbhex,'; stroke-width:0"/>');
4856 writeln;
4857 end;
4858 if opt_showmolname and (molname <> '') then
4859 begin
4860 writeln(format('<text style="font-size: %dpx" x="5" y="%1.1f">%s</text>',[fontsize2,(ymintotal+fontsize2),molname],fsettings));
4861 end;
4862 end;
4863
4864 procedure chk_svg_max_xy(svg_x, svg_y : single); // v0.2c
4865 // update the global variables svg_max_x, svg_ax_y and svg_min_y by comparison with the actual values
4866 begin
4867 if (svg_x > svg_max_x) then svg_max_x := svg_x;
4868 if (svg_y > svg_max_y) then svg_max_y := svg_y;
4869 if (svg_y < svg_min_y) then svg_min_y := svg_y;
4870 end;
4871
4872
4873 procedure printPSsingle(X1,Y1,X2,Y2 : single);
4874 var
4875 outXint, outYint, outXint2, outYint2 : integer;
4876 begin
4877 outXint := round((X1+xoffset)*blfactor);
4878 outYint := round((Y1+yoffset)*blfactor);
4879 updatebb(outXint, outYint);
4880 outXint2 := round((X2+xoffset)*blfactor);
4881 outYint2 := round((Y2+yoffset)*blfactor);
4882 updatebb(outXint2, outYint2);
4883 writeout('%d dot %d dot moveto %d dot %d dot lineto', [outXint, outYint, outXint2, outYint2]);
4884 end;
4885
4886 procedure printSVGsingle(X1,Y1,X2,Y2 : single);
4887 var
4888 outX, outY : single;
4889 bstr : string; // v0.4
4890 begin
4891 outX := (X1+xoffset)*blfactor*svg_factor;
4892 outY := (Y1+yoffset)*blfactor*-svg_factor + svg_yoffset;
4893 chk_svg_max_xy(outX,outY);
4894 if (svg_mode = 1) then
4895 bstr := format('<line x1="%1.1f" y1="%1.1f" ',[outX,outY],fsettings);
4896 if (svg_mode = 2) then
4897 bstr := format('M %1.1f %1.1f ',[outX,outY],fsettings);
4898 outX := (X2+xoffset)*blfactor*svg_factor;
4899 outY := (Y2+yoffset)*blfactor*-svg_factor + svg_yoffset;
4900 chk_svg_max_xy(outX,outY);
4901 if (svg_mode = 1) then bstr := bstr + format('x2="%1.1f" y2="%1.1f" />',[outX,outY],fsettings);
4902 if (svg_mode = 2) then bstr := bstr + format('L %1.1f %1.1f ',[outX,outY],fsettings);
4903 writeouts(bstr);
4904 end;
4905
4906 procedure printPSdouble(X1,Y1,X2,Y2 : single);
4907 var
4908 origX1, origY1, origX2, origY2 : single;
4909 r, deltaX, deltaY : double;
4910 begin
4911 origX1 := X1;
4912 origY1 := Y1;
4913 origX2 := X2;
4914 origY2 := Y2;
4915 r := sqrt(sqr(origX1-origX2)+sqr(origY1-origY2));
4916 if (r = 0) then // added check in v0.1f
4917 begin
4918 //nothing to draw, atoms are superimposed
4919 {$IFDEF debug}
4920 debugoutput('atoms have identical XY coordinates, skipping bond');
4921 {$ENDIF}
4922 exit;
4923 end;
4924 deltaX := ((PX-1)/2)*(origY2-origY1)/r;
4925 deltaY := ((PX-1)/2)*(origX2-origX1)/r;
4926 X1 := origX1-deltaX;
4927 Y1 := origY1+deltaY;
4928 X2 := origX2-deltaX;
4929 Y2 := origY2+deltaY;
4930 printPSsingle(X1,Y1,X2,Y2);
4931 X1 := origX1+deltaX;
4932 Y1 := origY1-deltaY;
4933 X2 := origX2+deltaX;
4934 Y2 := origY2-deltaY;
4935 printPSsingle(X1,Y1,X2,Y2);
4936 end;
4937
4938 procedure printSVGdouble(X1,Y1,X2,Y2 : single);
4939 var
4940 origX1, origY1, origX2, origY2 : single;
4941 r, deltaX, deltaY : double;
4942 begin
4943 origX1 := X1;
4944 origY1 := Y1;
4945 origX2 := X2;
4946 origY2 := Y2;
4947 r := sqrt(sqr(origX1-origX2)+sqr(origY1-origY2));
4948 if (r = 0) then // added check in v0.1f
4949 begin
4950 //nothing to draw, atoms are superimposed
4951 {$IFDEF debug}
4952 debugoutput('atoms have identical XY coordinates, skipping bond');
4953 {$ENDIF}
4954 exit;
4955 end;
4956 deltaX := ((PX-1)/2)*(origY2-origY1)/r;
4957 deltaY := ((PX-1)/2)*(origX2-origX1)/r;
4958 X1 := origX1-deltaX;
4959 Y1 := origY1+deltaY;
4960 X2 := origX2-deltaX;
4961 Y2 := origY2+deltaY;
4962 printSVGsingle(X1,Y1,X2,Y2);
4963 X1 := origX1+deltaX;
4964 Y1 := origY1-deltaY;
4965 X2 := origX2+deltaX;
4966 Y2 := origY2-deltaY;
4967 printSVGsingle(X1,Y1,X2,Y2);
4968 end;
4969
4970 procedure printPStriple(X1,Y1,X2,Y2 : single);
4971 var
4972 origX1, origY1, origX2, origY2 : single;
4973 r, deltaX, deltaY : double;
4974 begin
4975 origX1 := X1;
4976 origY1 := Y1;
4977 origX2 := X2;
4978 origY2 := Y2;
4979 r := sqrt(sqr(origX1-origX2)+sqr(origY1-origY2));
4980 if (r = 0) then // added check in v0.1f
4981 begin
4982 //nothing to draw, atoms are superimposed
4983 {$IFDEF debug}
4984 debugoutput('atoms have identical XY coordinates, skipping bond');
4985 {$ENDIF}
4986 exit;
4987 end;
4988 deltaX := (PX-2)*(origY2-origY1)/r;
4989 deltaY := (PX-2)*(origX2-origX1)/r;
4990 printPSsingle(X1,Y1,X2,Y2);
4991 X1 := origX1-deltaX;
4992 Y1 := origY1+deltaY;
4993 X2 := origX2-deltaX;
4994 Y2 := origY2+deltaY;
4995 printPSsingle(X1,Y1,X2,Y2);
4996 X1 := origX1+deltaX;
4997 Y1 := origY1-deltaY;
4998 X2 := origX2+deltaX;
4999 Y2 := origY2-deltaY;
5000 printPSsingle(X1,Y1,X2,Y2);
5001 end;
5002
5003
new_p3null5004 function new_p3(fixp,dirp:p_3d; dist:double):p_3d;
5005 var
5006 ini_dist : double;
5007 scalingfactor : double;
5008 diffx, diffy, diffz : double;
5009 resp : p_3d;
5010 begin
5011 ini_dist := dist3d(fixp,dirp);
5012 if (ini_dist = 0) then
5013 begin
5014 new_p3 := fixp;
5015 exit;
5016 end;
5017 scalingfactor := dist/ini_dist;
5018 diffx := dirp.x - fixp.x;
5019 diffy := dirp.y - fixp.y;
5020 diffz := dirp.z - fixp.z;
5021 resp.x := fixp.x + diffx*scalingfactor;
5022 resp.y := fixp.y + diffy*scalingfactor;
5023 resp.z := fixp.z + diffz*scalingfactor;
5024 new_p3 := resp;
5025 end;
5026
5027
5028 procedure printPS2DdoubleN(a1p,a2p:p_3d);
5029 var
5030 tmp1, tmp2, test1, test2, a_dir, diffp, ahp : p_3d;
5031 spacing : double;
5032 diffx, diffy : double;
5033 begin
5034 {$IFDEF debug}
5035 debugoutput('entering printPS2DdoubleN');
5036 {$ENDIF}
5037 tmp1.x := (a1p.x + a2p.x) / 2;
5038 tmp1.y := (a1p.y + a2p.y) / 2;
5039 tmp1.z := (a1p.z + a2p.z) / 2;
5040 diffx := tmp1.x - a1p.x;
5041 diffy := tmp1.y - a1p.y;
5042 ahp.x := tmp1.x - diffy; // fixed in v0.1c
5043 ahp.y := tmp1.y + diffx;
5044 ahp.z := tmp1.z;
5045 tmp1 := cross_prod(a1p,a2p,ahp);
5046 test1 := cross_prod(a1p,a2p,tmp1);
5047 test2 := cross_prod(a1p,tmp1,a2p);
5048 if (dist3d(ahp,test1) < dist3d(ahp,test1)) then
5049 a_dir := test1 else a_dir := test2;
5050 spacing := std_bondlength * db_spacingfactor;
5051 tmp1 := new_p3(a1p,a_dir,0.5*spacing);
5052 diffp := subtract_3d(tmp1,a1p);
5053 tmp2 := add_3d(a2p,diffp);
5054 printPSsingle(tmp1.x,tmp1.y,tmp2.x,tmp2.y);
5055 tmp1 := subtract_3d(a1p,diffp);
5056 tmp2 := subtract_3d(a2p,diffp);
5057 printPSsingle(tmp1.x,tmp1.y,tmp2.x,tmp2.y);
5058 end;
5059
5060 procedure printSVG2DdoubleN(a1p,a2p:p_3d);
5061 var
5062 tmp1, tmp2, test1, test2, a_dir, diffp, ahp : p_3d;
5063 spacing : double;
5064 diffx, diffy : double;
5065 begin
5066 {$IFDEF debug}
5067 debugoutput('entering printSVG2DdoubleN');
5068 {$ENDIF}
5069 tmp1.x := (a1p.x + a2p.x) / 2;
5070 tmp1.y := (a1p.y + a2p.y) / 2;
5071 tmp1.z := (a1p.z + a2p.z) / 2;
5072 diffx := tmp1.x - a1p.x;
5073 diffy := tmp1.y - a1p.y;
5074 ahp.x := tmp1.x - diffy;
5075 ahp.y := tmp1.y + diffx;
5076 ahp.z := tmp1.z;
5077 tmp1 := cross_prod(a1p,a2p,ahp);
5078 test1 := cross_prod(a1p,a2p,tmp1);
5079 test2 := cross_prod(a1p,tmp1,a2p);
5080 if (dist3d(ahp,test1) < dist3d(ahp,test1)) then
5081 a_dir := test1 else a_dir := test2;
5082 spacing := std_bondlength * db_spacingfactor;
5083 tmp1 := new_p3(a1p,a_dir,0.5*spacing);
5084 diffp := subtract_3d(tmp1,a1p);
5085 tmp2 := add_3d(a2p,diffp);
5086 printSVGsingle(tmp1.x,tmp1.y,tmp2.x,tmp2.y);
5087 tmp1 := subtract_3d(a1p,diffp);
5088 tmp2 := subtract_3d(a2p,diffp);
5089 printSVGsingle(tmp1.x,tmp1.y,tmp2.x,tmp2.y);
5090 end;
5091
5092 procedure printPS2Dtriple(a1p,a2p:p_3d);
5093 var
5094 la1p, la2p, tmp1, tmp2, test1, a_dir, diffp, ahp : p_3d;
5095 spacing : double;
5096 begin
5097 {$IFDEF debug}
5098 debugoutput('entering printPS2triple');
5099 {$ENDIF}
5100 la1p := a1p; la2p := a2p;
5101 la1p.z := 0; la2p.z := 0; // make it flat
5102 ahp.x := a1p.x;
5103 ahp.y := a1p.y;
5104 ahp.z := 2;
5105 test1 := cross_prod(la1p,la2p,ahp);
5106 a_dir := test1; // else a_dir := test2;
5107 spacing := std_bondlength * db_spacingfactor;
5108 tmp1 := new_p3(la1p,a_dir,spacing);
5109 diffp := subtract_3d(tmp1,la1p);
5110 tmp2 := add_3d(la2p,diffp);
5111 printPSsingle(tmp1.x,tmp1.y,tmp2.x,tmp2.y);
5112 tmp1 := subtract_3d(la1p,diffp);
5113 tmp2 := subtract_3d(la2p,diffp);
5114 printPSsingle(tmp1.x,tmp1.y,tmp2.x,tmp2.y);
5115 printPSsingle(la1p.x,la1p.y,la2p.x,la2p.y);
5116 end;
5117
5118 procedure printSVG2Dtriple(a1p,a2p:p_3d);
5119 var
5120 la1p, la2p, tmp1, tmp2, test1, a_dir, diffp, ahp : p_3d;
5121 spacing : double;
5122 begin
5123 {$IFDEF debug}
5124 debugoutput('entering printSVG2Dtriple');
5125 {$ENDIF}
5126 la1p := a1p; la2p := a2p;
5127 la1p.z := 0; la2p.z := 0; // make it flat
5128 ahp.x := a1p.x;
5129 ahp.y := a1p.y;
5130 ahp.z := 2;
5131 test1 := cross_prod(la1p,la2p,ahp);
5132 a_dir := test1; // else a_dir := test2;
5133 spacing := std_bondlength * db_spacingfactor;
5134 tmp1 := new_p3(la1p,a_dir,spacing);
5135 diffp := subtract_3d(tmp1,la1p);
5136 tmp2 := add_3d(la2p,diffp);
5137 printSVGsingle(tmp1.x,tmp1.y,tmp2.x,tmp2.y);
5138 tmp1 := subtract_3d(la1p,diffp);
5139 tmp2 := subtract_3d(la2p,diffp);
5140 printSVGsingle(tmp1.x,tmp1.y,tmp2.x,tmp2.y);
5141 printSVGsingle(la1p.x,la1p.y,la2p.x,la2p.y);
5142 end;
5143
5144 procedure printPS3DdoubleN(a1p,a2p,ahp:p_3d);
5145 var
5146 tmp1, tmp2, test1, test2, a_dir, diffp : p_3d;
5147 spacing : double;
5148 angle : double;
5149 angle_deg : double;
5150 begin
5151 {$IFDEF debug}
5152 debugoutput('entering printPS3DdoubleN');
5153 {$ENDIF}
5154 angle := angle_3d(a1p,a2p,ahp);
5155 angle_deg := radtodeg(angle);
5156 if (abs(angle_deg) < 5) or (abs(angle_deg) > 175) then // unusable handle
5157 begin
5158 printPS2DdoubleN(a1p,a2p);
5159 end else
5160 begin
5161 tmp1 := cross_prod(a1p,a2p,ahp);
5162 test1 := cross_prod(a1p,a2p,tmp1);
5163 test2 := cross_prod(a1p,tmp1,a2p);
5164 if (dist3d(ahp,test1) < dist3d(ahp,test1)) then
5165 a_dir := test1 else a_dir := test2;
5166 spacing := std_bondlength * db_spacingfactor;
5167 tmp1 := new_p3(a1p,a_dir,0.5*spacing);
5168 diffp := subtract_3d(tmp1,a1p);
5169 tmp2 := add_3d(a2p,diffp);
5170 printPSsingle(tmp1.x,tmp1.y,tmp2.x,tmp2.y);
5171 tmp1 := subtract_3d(a1p,diffp);
5172 tmp2 := subtract_3d(a2p,diffp);
5173 printPSsingle(tmp1.x,tmp1.y,tmp2.x,tmp2.y);
5174 end;
5175 end;
5176
5177 procedure printSVG3DdoubleN(a1p,a2p,ahp:p_3d);
5178 var
5179 tmp1, tmp2, test1, test2, a_dir, diffp : p_3d;
5180 spacing : double;
5181 angle : double;
5182 angle_deg : double;
5183 begin
5184 {$IFDEF debug}
5185 debugoutput('entering printSVG3DdoubleN');
5186 {$ENDIF}
5187 angle := angle_3d(a1p,a2p,ahp);
5188 angle_deg := radtodeg(angle);
5189 if (abs(angle_deg) < 5) or (abs(angle_deg) > 175) then // unusable handle
5190 begin
5191 printSVG2DdoubleN(a1p,a2p);
5192 end else
5193 begin
5194 tmp1 := cross_prod(a1p,a2p,ahp);
5195 test1 := cross_prod(a1p,a2p,tmp1);
5196 test2 := cross_prod(a1p,tmp1,a2p);
5197 if (dist3d(ahp,test1) < dist3d(ahp,test1)) then
5198 a_dir := test1 else a_dir := test2;
5199 spacing := std_bondlength * db_spacingfactor;
5200 tmp1 := new_p3(a1p,a_dir,0.5*spacing);
5201 diffp := subtract_3d(tmp1,a1p);
5202 tmp2 := add_3d(a2p,diffp);
5203 printSVGsingle(tmp1.x,tmp1.y,tmp2.x,tmp2.y);
5204 tmp1 := subtract_3d(a1p,diffp);
5205 tmp2 := subtract_3d(a2p,diffp);
5206 printSVGsingle(tmp1.x,tmp1.y,tmp2.x,tmp2.y);
5207 end;
5208 end;
5209
5210 procedure printPS3DdoubleA(a1p,a2p,ahp:p_3d);
5211 var
5212 tmp1, tmp2, tmp3, tmp4, test1, test2, a_dir, diffp : p_3d;
5213 spacing : double;
5214 angle : double;
5215 angle_deg : double;
5216 begin
5217 {$IFDEF debug}
5218 debugoutput('entering printPS3DdoubleA');
5219 {$ENDIF}
5220 angle := angle_3d(a1p,a2p,ahp);
5221 angle_deg := radtodeg(angle);
5222 if (abs(angle_deg) < 5) or (abs(angle_deg) > 175) then // unusable handle
5223 begin
5224 printPSdouble(a1p.x,a1p.y,a2p.x,a2p.y);
5225 end else
5226 begin
5227 tmp1 := cross_prod(a1p,a2p,ahp);
5228 test1 := cross_prod(a1p,a2p,tmp1);
5229 test2 := cross_prod(a1p,tmp1,a2p);
5230 if (dist3d(ahp,test1) < dist3d(ahp,test1)) then
5231 a_dir := test1 else a_dir := test2;
5232 spacing := std_bondlength * db_spacingfactor;
5233 tmp1 := new_p3(a1p,a_dir,spacing);
5234 diffp := subtract_3d(tmp1,a1p);
5235 tmp2 := add_3d(a2p,diffp);
5236 tmp3 := new_p3(tmp1,tmp2,0.4*spacing);
5237 tmp4 := new_p3(tmp2,tmp1,0.4*spacing);
5238 printPSsingle(tmp3.x,tmp3.y,tmp4.x,tmp4.y);
5239 printPSsingle(a1p.x,a1p.y,a2p.x,a2p.y);
5240 end;
5241 end;
5242
5243 procedure printSVG3DdoubleA(a1p,a2p,ahp:p_3d);
5244 var
5245 tmp1, tmp2, tmp3, tmp4, test1, test2, a_dir, diffp : p_3d;
5246 spacing : double;
5247 angle : double;
5248 angle_deg : double;
5249 begin
5250 {$IFDEF debug}
5251 debugoutput('entering printPS3DdoubleA');
5252 {$ENDIF}
5253 angle := angle_3d(a1p,a2p,ahp);
5254 angle_deg := radtodeg(angle);
5255 if (abs(angle_deg) < 5) or (abs(angle_deg) > 175) then // unusable handle
5256 begin
5257 printSVGdouble(a1p.x,a1p.y,a2p.x,a2p.y);
5258 end else
5259 begin
5260 tmp1 := cross_prod(a1p,a2p,ahp);
5261 test1 := cross_prod(a1p,a2p,tmp1);
5262 test2 := cross_prod(a1p,tmp1,a2p);
5263 if (dist3d(ahp,test1) < dist3d(ahp,test1)) then
5264 a_dir := test1 else a_dir := test2;
5265 spacing := std_bondlength * db_spacingfactor;
5266 tmp1 := new_p3(a1p,a_dir,spacing);
5267 diffp := subtract_3d(tmp1,a1p);
5268 tmp2 := add_3d(a2p,diffp);
5269 tmp3 := new_p3(tmp1,tmp2,0.4*spacing);
5270 tmp4 := new_p3(tmp2,tmp1,0.4*spacing);
5271 printSVGsingle(tmp3.x,tmp3.y,tmp4.x,tmp4.y);
5272 printSVGsingle(a1p.x,a1p.y,a2p.x,a2p.y);
5273 end;
5274 end;
5275
5276 procedure printPS3Darom(a1p,a2p,ahp:p_3d);
5277 var
5278 tmp1, tmp2, tmp3, tmp4, test1, test2, a_dir, diffp : p_3d;
5279 spacing : double;
5280 angle : double;
5281 angle_deg : double;
5282 begin
5283 {$IFDEF debug}
5284 debugoutput('entering printPS3Darom');
5285 {$ENDIF}
5286 angle := angle_3d(a1p,a2p,ahp);
5287 angle_deg := radtodeg(angle);
5288 if (abs(angle_deg) < 5) or (abs(angle_deg) > 175) then // unusable handle
5289 begin
5290 printPSdouble(a1p.x,a1p.y,a2p.x,a2p.y);
5291 end else
5292 begin
5293 tmp1 := cross_prod(a1p,a2p,ahp);
5294 test1 := cross_prod(a1p,a2p,tmp1);
5295 test2 := cross_prod(a1p,tmp1,a2p);
5296 if (dist3d(ahp,test1) < dist3d(ahp,test1)) then
5297 a_dir := test1 else a_dir := test2;
5298 spacing := std_bondlength * db_spacingfactor;
5299 tmp1 := new_p3(a1p,a_dir,spacing);
5300 diffp := subtract_3d(tmp1,a1p);
5301 tmp2 := add_3d(a2p,diffp);
5302 // shortening of bond
5303 tmp3 := new_p3(tmp1,tmp2,0.7*spacing);
5304 tmp4 := new_p3(tmp2,tmp1,0.7*spacing);
5305 writeouts(' stroke [3 3] 1 setdash 0.3 setgray ');
5306 printPSsingle(tmp3.x,tmp3.y,tmp4.x,tmp4.y);
5307 writeouts(' stroke [] 0 setdash 0.0 setgray ');
5308 printPSsingle(a1p.x,a1p.y,a2p.x,a2p.y);
5309 end;
5310 end;
5311
5312 procedure printSVG3Darom(a1p,a2p,ahp:p_3d);
5313 var
5314 tmp1, tmp2, tmp3, tmp4, test1, test2, a_dir, diffp : p_3d;
5315 spacing : double;
5316 angle : double;
5317 angle_deg : double;
5318 outx,outy : single;
5319 bstr : string;
5320 begin
5321 {$IFDEF debug}
5322 debugoutput('entering printSVG3Darom');
5323 {$ENDIF}
5324 angle := angle_3d(a1p,a2p,ahp);
5325 angle_deg := radtodeg(angle);
5326 if (abs(angle_deg) < 5) or (abs(angle_deg) > 175) then // unusable handle
5327 begin
5328 printSVGdouble(a1p.x,a1p.y,a2p.x,a2p.y);
5329 end else
5330 begin
5331 tmp1 := cross_prod(a1p,a2p,ahp);
5332 test1 := cross_prod(a1p,a2p,tmp1);
5333 test2 := cross_prod(a1p,tmp1,a2p);
5334 if (dist3d(ahp,test1) < dist3d(ahp,test1)) then
5335 a_dir := test1 else a_dir := test2;
5336 spacing := std_bondlength * db_spacingfactor;
5337 tmp1 := new_p3(a1p,a_dir,spacing);
5338 diffp := subtract_3d(tmp1,a1p);
5339 tmp2 := add_3d(a2p,diffp);
5340 // shortening of bond
5341 tmp3 := new_p3(tmp1,tmp2,0.7*spacing);
5342 tmp4 := new_p3(tmp2,tmp1,0.7*spacing);
5343 // the dotted line first
5344 outX := (tmp3.x+xoffset)*blfactor*svg_factor;
5345 outY := (tmp3.y+yoffset)*blfactor*-svg_factor + svg_yoffset;
5346 chk_svg_max_xy(outX,outY);
5347 bstr := format('<line stroke-dasharray="3,3" x1="%1.1f" y1="%1.1f" ',[outx,outy],fsettings);
5348 outX := (tmp4.x+xoffset)*blfactor*svg_factor;
5349 outY := (tmp4.y+yoffset)*blfactor*-svg_factor + svg_yoffset;
5350 chk_svg_max_xy(outX,outY);
5351 bstr := bstr + format('x2="%1.1f" y2="%1.1f" />',[outx,outy],fsettings);
5352 writeouts(bstr);
5353 // the solid line next
5354 outX := (a1p.x+xoffset)*blfactor*svg_factor;
5355 outY := (a1p.y+yoffset)*blfactor*-svg_factor + svg_yoffset;
5356 chk_svg_max_xy(outX,outY);
5357 bstr := format('<line x1="%1.1f" y1="%1.1f" ',[outx,outy],fsettings);
5358 outX := (a2p.x+xoffset)*blfactor*svg_factor;
5359 outY := (a2p.y+yoffset)*blfactor*-svg_factor + svg_yoffset;
5360 chk_svg_max_xy(outX,outY);
5361 bstr := bstr + format('x2="%1.1f" y2="%1.1f" />',[outx,outy],fsettings);
5362 writeouts(bstr);
5363 end;
5364 end;
5365
5366 procedure printPS2Dwedge(a1p,a2p:p_3d);
5367 var
5368 la1p, la2p, tmp1, tmp2, test1, a_dir, diffp, ahp : p_3d;
5369 spacing : double;
5370 outxint, outyint : integer;
5371 begin
5372 {$IFDEF debug}
5373 debugoutput('entering printPS2Dwedge');
5374 {$ENDIF}
5375 la1p := a1p; la2p := a2p;
5376 la1p.z := 0; la2p.z := 0; // make it flat
5377 ahp.x := a1p.x;
5378 ahp.y := a1p.y;
5379 ahp.z := 2;
5380 test1 := cross_prod(la1p,la2p,ahp);
5381 a_dir := test1;
5382 spacing := std_bondlength * db_spacingfactor * 0.6;
5383 tmp1 := new_p3(la1p,a_dir,spacing);
5384 diffp := subtract_3d(tmp1,la1p);
5385 tmp1 := add_3d(la2p,diffp);
5386 tmp2 := subtract_3d(la2p,diffp);
5387 outXint := round((la1p.x+xoffset)*blfactor);
5388 outYint := round((la1p.y+yoffset)*blfactor);
5389 updatebb(outXint, outYint);
5390 writeouts('stroke');
5391 writeouts('0 setlinejoin 10 setmiterlimit');
5392 writeouts('newpath');
5393 writeout('%d dot %d dot moveto', [outxint, outyint]);
5394 outXint := round((tmp1.x+xoffset)*blfactor);
5395 outYint := round((tmp1.y+yoffset)*blfactor);
5396 updatebb(outXint, outYint);
5397 writeout('%d dot %d dot lineto', [outxint, outyint]);
5398 outXint := round((tmp2.x+xoffset)*blfactor);
5399 outYint := round((tmp2.y+yoffset)*blfactor);
5400 updatebb(outXint, outYint);
5401 writeout('%d dot %d dot lineto', [outxint, outyint]);
5402 outXint := round((la1p.x+xoffset)*blfactor);
5403 outYint := round((la1p.y+yoffset)*blfactor);
5404 updatebb(outXint, outYint);
5405 writeout('%d dot %d dot lineto', [outxint, outyint]);
5406 writeouts('closepath fill 1 setlinejoin');
5407 writeouts('stroke');
5408 end;
5409
5410 procedure printSVG2Dwedge(a1p,a2p:p_3d);
5411 var
5412 la1p, la2p, tmp1, tmp2, test1, a_dir, diffp, ahp : p_3d;
5413 spacing : double;
5414 outx, outy : double;
5415 bstr : string;
5416 begin
5417 {$IFDEF debug}
5418 debugoutput('entering printSVG2Dwedge');
5419 {$ENDIF}
5420 la1p := a1p; la2p := a2p;
5421 la1p.z := 0; la2p.z := 0; // make it flat
5422 ahp.x := a1p.x;
5423 ahp.y := a1p.y;
5424 ahp.z := 2;
5425 test1 := cross_prod(la1p,la2p,ahp);
5426 a_dir := test1;
5427 spacing := std_bondlength * db_spacingfactor * 0.6;
5428 tmp1 := new_p3(la1p,a_dir,spacing);
5429 diffp := subtract_3d(tmp1,la1p);
5430 tmp1 := add_3d(la2p,diffp);
5431 tmp2 := subtract_3d(la2p,diffp);
5432 outX := (la1p.x+xoffset)*blfactor*svg_factor;
5433 outY := (la1p.y+yoffset)*blfactor*-svg_factor + svg_yoffset;
5434 chk_svg_max_xy(outX,outY);
5435 bstr := format('<polygon points="%1.1f,%1.1f ',[outx,outy],fsettings);
5436 outX := (tmp1.x+xoffset)*blfactor*svg_factor;
5437 outY := (tmp1.y+yoffset)*blfactor*-svg_factor + svg_yoffset;
5438 chk_svg_max_xy(outX,outY);
5439 bstr := bstr + format('%1.1f,%1.1f ',[outx,outy],fsettings);
5440 outX := (tmp2.x+xoffset)*blfactor*svg_factor;
5441 outY := (tmp2.y+yoffset)*blfactor*-svg_factor + svg_yoffset;
5442 chk_svg_max_xy(outX,outY);
5443 bstr := bstr + format('%1.1f,%1.1f ',[outx,outy],fsettings);
5444 outX := (la1p.x+xoffset)*blfactor*svg_factor;
5445 outY := (la1p.y+yoffset)*blfactor*-svg_factor + svg_yoffset;
5446 chk_svg_max_xy(outX,outY);
5447 bstr := bstr + format('%1.1f,%1.1f"',[outx,outy],fsettings);
5448 writeouts(bstr);
5449 writeouts('style="fill:#000000; stroke:#000000;stroke-width:1; stroke-linejoin:round"/> ');
5450 end;
5451
5452 procedure printPS2Dhatch(a1p,a2p:p_3d);
5453 var
5454 la1p, la2p, tmp1, tmp2, tmp3, tmp4, test1, test2, test3, test4 : p_3d;
5455 diffp, ahp, w1, w2 : p_3d;
5456 spacing : double;
5457 i, nstrips : integer;
5458 dist2d, step : double;
5459 begin
5460 {$IFDEF debug}
5461 debugoutput('entering printPS22Dhatch');
5462 {$ENDIF}
5463 la1p := a1p; la2p := a2p;
5464 la1p.z := 0; la2p.z := 0; // make it flat
5465 ahp.x := a1p.x;
5466 ahp.y := a1p.y;
5467 ahp.z := 2;
5468 test1 := cross_prod(la1p,la2p,ahp);
5469 test2 := cross_prod(la1p,ahp,la2p);
5470 spacing := std_bondlength * db_spacingfactor * 0.6;
5471 tmp1 := new_p3(la1p,test1,spacing*0.3);
5472 tmp2 := new_p3(la1p,test2,spacing*0.3);
5473 diffp := subtract_3d(la2p,la1p);
5474 test3 := add_3d(test1,diffp);
5475 test4 := add_3d(test2,diffp);
5476 tmp3 := new_p3(la2p,test3,spacing*1.1);
5477 tmp4 := new_p3(la2p,test4,spacing*1.1);
5478 dist2d := dist3d(la1p,la2p);
5479 nstrips := 6;
5480 if dist2d < 0.8 * std_blCCsingle then nstrips := 5;
5481 if dist2d < 0.6 * std_blCCsingle then nstrips := 4;
5482 if dist2d < 0.4 * std_blCCsingle then nstrips := 3;
5483 if dist2d < 0.2 * std_blCCsingle then nstrips := 2;
5484 step := dist2d / nstrips;
5485 for i := 1 to nstrips do
5486 begin
5487 w1 := new_p3(tmp1,tmp3,(i*step - step*0.4));
5488 w2 := new_p3(tmp2,tmp4,(i*step - step*0.4));
5489 printPSsingle(w1.x,w1.y,w2.x,w2.y);
5490 end;
5491 end;
5492
5493 procedure printSVG2Dhatch(a1p,a2p:p_3d);
5494 var
5495 la1p, la2p, tmp1, tmp2, tmp3, tmp4, test1, test2, test3, test4 : p_3d;
5496 diffp, ahp, w1, w2 : p_3d;
5497 spacing : double;
5498 i, nstrips : integer;
5499 dist2d, step : double;
5500 begin // must be always processed in svg_mode 1
5501 {$IFDEF debug}
5502 debugoutput('entering printSVG2Dhatch');
5503 {$ENDIF}
5504 la1p := a1p; la2p := a2p;
5505 la1p.z := 0; la2p.z := 0; // make it flat
5506 ahp.x := a1p.x;
5507 ahp.y := a1p.y;
5508 ahp.z := 2;
5509 test1 := cross_prod(la1p,la2p,ahp);
5510 test2 := cross_prod(la1p,ahp,la2p);
5511 spacing := std_bondlength * db_spacingfactor * 0.6;
5512 tmp1 := new_p3(la1p,test1,spacing*0.3);
5513 tmp2 := new_p3(la1p,test2,spacing*0.3);
5514 diffp := subtract_3d(la2p,la1p);
5515 test3 := add_3d(test1,diffp);
5516 test4 := add_3d(test2,diffp);
5517 tmp3 := new_p3(la2p,test3,spacing*1.1);
5518 tmp4 := new_p3(la2p,test4,spacing*1.1);
5519 dist2d := dist3d(la1p,la2p);
5520 nstrips := 6;
5521 if dist2d < 0.8 * std_blCCsingle then nstrips := 5;
5522 if dist2d < 0.6 * std_blCCsingle then nstrips := 4;
5523 if dist2d < 0.4 * std_blCCsingle then nstrips := 3;
5524 if dist2d < 0.2 * std_blCCsingle then nstrips := 2;
5525 step := dist2d / nstrips;
5526 for i := 1 to nstrips do
5527 begin
5528 w1 := new_p3(tmp1,tmp3,(i*step - step*0.4));
5529 w2 := new_p3(tmp2,tmp4,(i*step - step*0.4));
5530 printSVGsingle(w1.x,w1.y,w2.x,w2.y);
5531 end;
5532 end;
5533
5534 procedure printPScomplex(X1,Y1,X2,Y2 : single); // v0.1c
5535 var
5536 outXint, outYint, outXint2, outYint2 : integer;
5537 begin
5538 outXint := round((X1+xoffset)*blfactor);
5539 outYint := round((Y1+yoffset)*blfactor);
5540 updatebb(outXint, outYint);
5541 writeouts(' stroke [3 3] 1 setdash 0.7 setgray ');
5542 outXint2 := round((X2+xoffset)*blfactor);
5543 outYint2 := round((Y2+yoffset)*blfactor);
5544 updatebb(outXint2, outYint2);
5545 writeout('%d dot %d dot moveto %d dot %d dot lineto', [outXint, outYint, outXint2, outYint2]);
5546 writeouts(' stroke [] 0 setdash 0.0 setgray ');
5547 end;
5548
5549 procedure printSVGcomplex(X1,Y1,X2,Y2 : single); // v0.1c
5550 var
5551 outX, outY : single;
5552 bstr : string;
5553 begin
5554 outX := (X1+xoffset)*blfactor*svg_factor;
5555 outY := (Y1+yoffset)*blfactor*-svg_factor + svg_yoffset;
5556 chk_svg_max_xy(outX,outY);
5557 bstr := format('<line stroke="#777777" stroke-width="%1.1f" stroke-dasharray="2,2" x1="%1.1f" y1="%1.1f" ',[linewidth,outx,outy],fsettings);
5558 outX := (X2+xoffset)*blfactor*svg_factor;
5559 outY := (Y2+yoffset)*blfactor*-svg_factor + svg_yoffset;
5560 chk_svg_max_xy(outX,outY);
5561 bstr := bstr + format('x2="%1.1f" y2="%1.1f" />',[outx,outy],fsettings);
5562 writeouts(bstr);
5563 end;
5564
5565 procedure printPSarrow(X1,Y1,X2,Y2 : single); // v0.2
5566 var
5567 origbitX1, origbitY1, origbitX2, origbitY2 : single;
5568 r, topX, topY, coarsedeltaX, coarsedeltaY, finedeltaX, finedeltaY,
5569 deltaX, deltaY, leftX, leftY, rightX, rightY : single;
5570 outXint, outYint : integer;
5571 begin
5572 origbitX1 := X1;
5573 origbitY1 := Y1;
5574 origbitX2 := X2;
5575 origbitY2 := Y2;
5576 writeout('%1.1f setlinewidth',[2*linewidth]);
5577 printPSsingle(X1,Y1,X2,Y2);
5578 writeouts('stroke');
5579 writeout('%1.1f setlinewidth',[linewidth]);
5580 r := sqrt(sqr(origbitX1-origbitX2)+sqr(origbitY1-origbitY2));
5581 coarsedeltaX := 0.4*PX*(origbitY2-origbitY1)/(2*r);
5582 coarsedeltaY := 0.4*PX*(origbitX2-origbitX1)/(2*r);
5583 finedeltaX := 3*coarsedeltaY;
5584 finedeltaY := 3*coarsedeltaX;
5585 deltaX := (coarsedeltaX - finedeltaX);
5586 deltaY := (coarsedeltaY + finedeltaY);
5587 leftX := origbitX2 + deltaX;
5588 leftY := origbitY2 - deltaY;
5589 deltaX := (coarsedeltaX + finedeltaX);
5590 deltaY := (coarsedeltaY - finedeltaY);
5591 rightX := origbitX2 - deltaX;
5592 rightY := origbitY2 + deltaY;
5593 topX := origbitX2 + 0.1*PX*(origbitX2-origbitX1)/r;
5594 topY := origbitY2 + 0.1*PX*(origbitY2-origbitY1)/r;
5595 outXint := round((topX+xoffset)*blfactor);
5596 outYint := round((topY+yoffset)*blfactor);
5597 writeouts('0 setlinejoin 10 setmiterlimit');
5598 writeouts('newpath');
5599 writeout('%d dot %d dot moveto',[outXint,outYint]);
5600 outXint := round((leftX+xoffset)*blfactor);
5601 outYint := round((leftY+yoffset)*blfactor);
5602 writeout('%d dot %d dot lineto',[outXint,outYint]);
5603 outXint := round((rightX+xoffset)*blfactor);
5604 outYint := round((rightY+yoffset)*blfactor);
5605 writeout('%d dot %d dot lineto',[outXint,outYint]);
5606 outXint := round((topX+xoffset)*blfactor);
5607 outYint := round((topY+yoffset)*blfactor);
5608 writeout('%d dot %d dot lineto',[outXint,outYint]);
5609 writeouts('closepath fill 1 setlinejoin');
5610 end;
5611
5612 procedure printSVGarrow(X1,Y1,X2,Y2 : single); // v0.2
5613 var
5614 origbitX1, origbitY1, origbitX2, origbitY2 : single;
5615 r, topX, topY, coarsedeltaX, coarsedeltaY, finedeltaX, finedeltaY,
5616 deltaX, deltaY, leftX, leftY, rightX, rightY : single;
5617 outX, outY : single;
5618 bstr : string;
5619 begin
5620 origbitX1 := X1;
5621 origbitY1 := Y1;
5622 origbitX2 := X2;
5623 origbitY2 := Y2;
5624 outX := (X1+xoffset)*blfactor*svg_factor;
5625 outY := (Y1+yoffset)*blfactor*-svg_factor + svg_yoffset;
5626 chk_svg_max_xy(outX,outY);
5627 bstr := format('<line style="stroke-width: %1.1f;" x1="%1.1f" y1="%1.1f" ',[(2*linewidth),outx,outy],fsettings);
5628 outX := (X2+xoffset)*blfactor*svg_factor;
5629 outY := (Y2+yoffset)*blfactor*-svg_factor + svg_yoffset;
5630 chk_svg_max_xy(outX,outY);
5631 bstr := bstr + format('x2="%1.1f" y2="%1.1f" />',[outx,outy],fsettings);
5632 writeouts(bstr);
5633 r := sqrt(sqr(origbitX1-origbitX2)+sqr(origbitY1-origbitY2));
5634 coarsedeltaX := 0.4*PX*(origbitY2-origbitY1)/(2*r);
5635 coarsedeltaY := 0.4*PX*(origbitX2-origbitX1)/(2*r);
5636 finedeltaX := 3*coarsedeltaY;
5637 finedeltaY := 3*coarsedeltaX;
5638 deltaX := (coarsedeltaX - finedeltaX);
5639 deltaY := (coarsedeltaY + finedeltaY);
5640 leftX := origbitX2 + deltaX;
5641 leftY := origbitY2 - deltaY;
5642 deltaX := (coarsedeltaX + finedeltaX);
5643 deltaY := (coarsedeltaY - finedeltaY);
5644 rightX := origbitX2 - deltaX;
5645 rightY := origbitY2 + deltaY;
5646 topX := origbitX2 + 0.1*PX*(origbitX2-origbitX1)/r;
5647 topY := origbitY2 + 0.1*PX*(origbitY2-origbitY1)/r;
5648 outX := (topX+xoffset)*blfactor*svg_factor;
5649 outY := (topY+yoffset)*blfactor*-svg_factor + svg_yoffset;
5650 chk_svg_max_xy(outX,outY);
5651 bstr := format('<polygon points="%1.1f,%1.1f ',[outx,outy],fsettings);
5652 outX := (leftX+xoffset)*blfactor*svg_factor;
5653 outY := (leftY+yoffset)*blfactor*-svg_factor + svg_yoffset;
5654 chk_svg_max_xy(outX,outY);
5655 bstr := bstr + format('%1.1f,%1.1f ',[outx,outy],fsettings);
5656 outX := (rightX+xoffset)*blfactor*svg_factor;
5657 outY := (rightY+yoffset)*blfactor*-svg_factor + svg_yoffset;
5658 chk_svg_max_xy(outX,outY);
5659 bstr := bstr + format('%1.1f,%1.1f ',[outx,outy],fsettings);
5660 outX := (topX+xoffset)*blfactor*svg_factor;
5661 outY := (topY+yoffset)*blfactor*-svg_factor + svg_yoffset;
5662 chk_svg_max_xy(outX,outY);
5663 bstr := bstr + format('%1.1f,%1.1f" ',[outx,outy],fsettings);
5664 bstr := bstr + 'style="fill:#000000; stroke:#000000;stroke-width:1"/> ';
5665 writeouts(bstr);
5666 end;
5667
5668 procedure print_PS_squarebracket(x1,y1,x2,y2,x3,y3,x4,y4 : single;brlabel:string); // v0.1f
5669 var
5670 xmax, ymin, xtmp : single;
5671 width : single;
5672 outXint, outYint : integer;
5673 begin
5674 width := 0.2;
5675 xmax := -9999;
5676 if x1 > xmax then xmax := x1; if x2 > xmax then xmax := x2;
5677 if x3 > xmax then xmax := x3; if x4 > xmax then xmax := x4;
5678 ymin := 9999;
5679 if y1 < ymin then ymin := y1; if y2 < ymin then ymin := y2;
5680 if y3 < ymin then ymin := y3; if y4 < ymin then ymin := y4;
5681 printPSsingle(x1,y1,x2,y2);
5682 if x3 > x1 then xtmp := x1 + width else xtmp := x1 - width;
5683 printPSsingle(x1,y1,xtmp,y1);
5684 if x4 > x2 then xtmp := x2 + width else xtmp := x2 - width;
5685 printPSsingle(x2,y2,xtmp,y2);
5686 printPSsingle(x3,y3,x4,y4);
5687 if x3 > x1 then xtmp := x3 - width else xtmp := x3 + width;
5688 printPSsingle(x3,y3,xtmp,y3);
5689 if x4 > x2 then xtmp := x4 - width else xtmp := x4 + width;
5690 printPSsingle(x4,y4,xtmp,y4);
5691 outXint := round((xmax+width+xoffset)*blfactor);
5692 outYint := round((ymin+yoffset)*blfactor);
5693 writeout('%d dot %d dot moveto ',[outXint,outYint]);
5694 updatebb(outXint, outYint);
5695 writeouts('CFontSub');
5696 writeouts('('+brlabel+') show');
5697 outXint := outXint + round(2.0*get_stringwidth(fontsize2,brlabel));
5698 updatebb(outXint, outYint);
5699 end;
5700
5701 procedure print_SVG_squarebracket(x1,y1,x2,y2,x3,y3,x4,y4 : single;brlabel:string); // v0.1f
5702 var
5703 xmax, ymin, xtmp : single;
5704 width : single;
5705 outX, outY : single;
5706 bstr : string;
5707 begin // must be always processed in svg_mode = 1
5708 width := 0.2;
5709 xmax := -9999;
5710 if x1 > xmax then xmax := x1; if x2 > xmax then xmax := x2;
5711 if x3 > xmax then xmax := x3; if x4 > xmax then xmax := x4;
5712 ymin := 9999;
5713 if y1 < ymin then ymin := y1; if y2 < ymin then ymin := y2;
5714 if y3 < ymin then ymin := y3; if y4 < ymin then ymin := y4;
5715 printSVGsingle(x1,y1,x2,y2);
5716 if x3 > x1 then xtmp := x1 + width else xtmp := x1 - width;
5717 printSVGsingle(x1,y1,xtmp,y1);
5718 if x4 > x2 then xtmp := x2 + width else xtmp := x2 - width;
5719 printSVGsingle(x2,y2,xtmp,y2);
5720 printSVGsingle(x3,y3,x4,y4);
5721 if x3 > x1 then xtmp := x3 - width else xtmp := x3 + width;
5722 printSVGsingle(x3,y3,xtmp,y3);
5723 if x4 > x2 then xtmp := x4 - width else xtmp := x4 + width;
5724 printSVGsingle(x4,y4,xtmp,y4);
5725 outX := (xmax+width+xoffset)*blfactor*svg_factor;
5726 outY := (ymin+yoffset)*blfactor*-svg_factor + svg_yoffset;
5727 chk_svg_max_xy(outX,outY); //
5728 bstr := format('<text style="font-size: %dpx" text-anchor="start" x="%1.1f" y="%1.1f">%s</text>',[fontsize2,outx,outy,brlabel],fsettings);
5729 writeouts(bstr);
5730 outX := outX + 0.6*get_stringwidth(fontsize2,brlabel);
5731 chk_svg_max_xy(outX,outY);
5732 end;
5733
5734 procedure print_PS_bond(i:integer);
5735 var
5736 a1, a2, ah : integer;
5737 a1x, a1y, a1z, a2x, a2y, a2z, ahx, ahy, ahz : single;
5738 a1p, a2p, ahp : p_3d;
5739 bt, bst : char;
5740 begin
5741 if (n_bonds = 0) or (i > n_bonds) then exit;
5742 a1 := bond^[i].a1;
5743 a2 := bond^[i].a2;
5744 ah := bond^[i].a_handle;
5745 bt := bond^[i].btype;
5746 bst := bond^[i].bsubtype;
5747 a1x := atom^[a1].x;
5748 a1y := atom^[a1].y;
5749 a1z := atom^[a1].z;
5750 a2x := atom^[a2].x;
5751 a2y := atom^[a2].y;
5752 a2z := atom^[a2].z;
5753 a1p.x := a1x; a1p.y := a1y; a1p.z := a1z;
5754 a2p.x := a2x; a2p.y := a2y; a2p.z := a2z;
5755 if (bond^[i].hidden = false) then
5756 begin
5757 {$IFDEF debug}
5758 debugoutput('printing bond '+inttostr(i)+', atom 1: '+inttostr(a1)+', atom 2: '+inttostr(a2));
5759 {$ENDIF}
5760 if (ah = 0) then
5761 begin
5762 if bt = 'S' then
5763 begin
5764 if bst = 'N' then printPSsingle(a1x,a1y,a2x,a2y);
5765 if bst = 'W' then printPS2Dwedge(a1p,a2p);
5766 if bst = 'H' then printPS2Dhatch(a1p,a2p);
5767 end;
5768 if bt = 'D' then printPS2DdoubleN(a1p,a2p);
5769 if bt = 'T' then printPS2Dtriple(a1p,a2p);
5770 if bt = 'A' then printPSsingle(a1x,a1y,a2x,a2y);
5771 if bt = 'C' then printPScomplex(a1x,a1y,a2x,a2y);
5772 if bt = 'a' then printPScomplex(a1x,a1y,a2x,a2y); // v0.2b
5773 end else
5774 begin
5775 ahx := atom^[ah].x;
5776 ahy := atom^[ah].y;
5777 ahz := atom^[ah].z;
5778 ahp.x := ahx; ahp.y := ahy; ahp.z := ahz;
5779 if (bt = 'D') and (bst = 'N') then printPS3DdoubleN(a1p,a2p,ahp);
5780 if (bt = 'D') and (bst = 'A') then printPS3DdoubleA(a1p,a2p,ahp);
5781 if (bt = 'A') then printPS3Darom(a1p,a2p,ahp);
5782 end;
5783 //writeln('stroke');
5784 end;
5785 end;
5786
5787 procedure print_SVG_bond(i:integer);
5788 var
5789 a1, a2, ah : integer;
5790 a1x, a1y, a1z, a2x, a2y, a2z, ahx, ahy, ahz : single;
5791 a1p, a2p, ahp : p_3d;
5792 bt, bst : char;
5793 begin
5794 if (n_bonds = 0) or (i > n_bonds) then exit;
5795 a1 := bond^[i].a1;
5796 a2 := bond^[i].a2;
5797 ah := bond^[i].a_handle;
5798 bt := bond^[i].btype;
5799 bst := bond^[i].bsubtype;
5800 a1x := atom^[a1].x;
5801 a1y := atom^[a1].y;
5802 a1z := atom^[a1].z;
5803 a2x := atom^[a2].x;
5804 a2y := atom^[a2].y;
5805 a2z := atom^[a2].z;
5806 a1p.x := a1x; a1p.y := a1y; a1p.z := a1z;
5807 a2p.x := a2x; a2p.y := a2y; a2p.z := a2z;
5808 if (bond^[i].hidden = false) then
5809 begin
5810 {$IFDEF debug}
5811 debugoutput('printing bond '+inttostr(i)+', atom 1: '+inttostr(a1)+', atom 2: '+inttostr(a2));
5812 {$ENDIF}
5813 if (ah = 0) then
5814 begin
5815 if bt = 'S' then
5816 begin
5817 if bst = 'N' then printSVGsingle(a1x,a1y,a2x,a2y);
5818 if bst = 'W' then printSVG2Dwedge(a1p,a2p);
5819 if bst = 'H' then printSVG2Dhatch(a1p,a2p);
5820 end;
5821 if bt = 'D' then printSVG2DdoubleN(a1p,a2p);
5822 if bt = 'T' then printSVG2Dtriple(a1p,a2p);
5823 if bt = 'A' then printSVGsingle(a1x,a1y,a2x,a2y);
5824 if bt = 'C' then printSVGcomplex(a1x,a1y,a2x,a2y);
5825 if bt = 'a' then printSVGcomplex(a1x,a1y,a2x,a2y); // v0.2b
5826 end else
5827 begin
5828 ahx := atom^[ah].x;
5829 ahy := atom^[ah].y;
5830 ahz := atom^[ah].z;
5831 ahp.x := ahx; ahp.y := ahy; ahp.z := ahz;
5832 if (bt = 'D') and (bst = 'N') then printSVG3DdoubleN(a1p,a2p,ahp);
5833 if (bt = 'D') and (bst = 'A') then printSVG3DdoubleA(a1p,a2p,ahp);
5834 if (bt = 'A') then printSVG3Darom(a1p,a2p,ahp);
5835 end;
5836 end;
5837 end;
5838
5839 procedure print_SVG_bond_special(i:integer);
5840 var
5841 a1, a2, ah : integer;
5842 a1x, a1y, a1z, a2x, a2y, a2z, ahx, ahy, ahz : single;
5843 a1p, a2p, ahp : p_3d;
5844 bt, bst : char;
5845 begin
5846 if (n_bonds = 0) or (i > n_bonds) then exit;
5847 a1 := bond^[i].a1;
5848 a2 := bond^[i].a2;
5849 ah := bond^[i].a_handle;
5850 bt := bond^[i].btype;
5851 bst := bond^[i].bsubtype;
5852 a1x := atom^[a1].x;
5853 a1y := atom^[a1].y;
5854 a1z := atom^[a1].z;
5855 a2x := atom^[a2].x;
5856 a2y := atom^[a2].y;
5857 a2z := atom^[a2].z;
5858 a1p.x := a1x; a1p.y := a1y; a1p.z := a1z;
5859 a2p.x := a2x; a2p.y := a2y; a2p.z := a2z;
5860 if (bond^[i].hidden = false) then
5861 begin
5862 {$IFDEF debug}
5863 debugoutput('printing special bond '+inttostr(i)+', atom 1: '+inttostr(a1)+', atom 2: '+inttostr(a2)+bt+bst);
5864 {$ENDIF}
5865 if (ah = 0) then
5866 begin
5867 if bt = 'S' then
5868 begin
5869 if bst = 'W' then begin printSVG2Dwedge(a1p,a2p); bond^[i].drawn := true; end;
5870 end;
5871 if bt = 'C' then begin printSVGcomplex(a1x,a1y,a2x,a2y); bond^[i].drawn := true; end;
5872 if bt = 'a' then begin printSVGcomplex(a1x,a1y,a2x,a2y); bond^[i].drawn := true; end;
5873 end else
5874 begin
5875 ahx := atom^[ah].x;
5876 ahy := atom^[ah].y;
5877 ahz := atom^[ah].z;
5878 ahp.x := ahx; ahp.y := ahy; ahp.z := ahz;
5879 if (bt = 'A') then begin printSVG3Darom(a1p,a2p,ahp); bond^[i].drawn := true; end;
5880 end;
5881 end;
5882 end;
5883
5884
5885 procedure printBB(x,y : integer; anchor, chgstr : string);
5886 begin
5887 if (anchor = '') then exit;
5888 writeouts('stroke');
5889 writeout('/X {%d} def',[x]);
5890 writeout('/Y {%d} def',[y]);
5891 writeouts('/anchor ('+anchor+') def');
5892 if (chgstr = '') then writeouts('bb') else writeouts ('bbx');
5893 end;
5894
5895
5896 procedure printSVGBB(x,y : single; anchor, chgstr : string);
5897 var
5898 r : single;
5899 begin
5900 r := fontsize1 * 0.45;
5901 if (anchor = '') then exit;
5902
5903 (* example for a rectangle in SVG
5904 <rect x="20" y="20" width="250" height="250"
5905 style="fill:blue;stroke:pink;stroke-width:5;
5906 fill-opacity:0.1;stroke-opacity:0.9"/>
5907 *)
5908
5909 // for now, use a circle
5910 writeout('<circle cx="%1.1f" cy="%1.1f" r="%1.1f" />',[x,y,r]);
5911 chk_svg_max_xy((x+3*r),(y+3*r)); // add a sefety margin
5912 end;
5913
findHposnull5914 function findHpos(a1:integer):integer;
5915 const
5916 HPright = 1;
5917 HPleft = 2;
5918 HPup = 3;
5919 HPdown = 4;
5920 var
5921 i, a2 : integer;
5922 res : integer;
5923 nb : neighbor_rec;
5924 occupied : array[1..8] of boolean;
5925 a1p, a2p, refp : p_3d;
5926 angle, angledeg : double;
5927 n_occ : integer;
5928 begin
5929 res := HPright;
5930 fillchar(occupied,sizeof(occupied),false);
5931 a1p.x := atom^[a1].x;
5932 a1p.y := atom^[a1].y;
5933 a1p.z := atom^[a1].z;
5934 refp.x := a1p.x + 2;
5935 refp.y := a1p.y;
5936 refp.z := a1p.z;
5937 nb := get_neighbors(a1);
5938 for i := 1 to atom^[a1].neighbor_count do
5939 begin
5940 a2 := nb[i];
5941 if is_heavyatom(a2) then
5942 begin
5943 a2p.x := atom^[a2].x;
5944 a2p.y := atom^[a2].y;
5945 a2p.z := atom^[a2].z;
5946 angle := angle_2d_XY(a1p,refp,a2p);
5947 angledeg := radtodeg(angle);
5948 if abs(angledeg) <= 4*dirtolerance then occupied[dir_right] := true else
5949 begin
5950 if abs(angledeg) < (90-4*dirtolerance) then
5951 begin
5952 if a2p.y > a1p.y then occupied[dir_rightup] := true else
5953 occupied[dir_rightdown] := true;
5954 end else
5955 begin
5956 if abs(angledeg) <= (90+4*dirtolerance) then
5957 begin
5958 if a2p.y > a1p.y then occupied[dir_up] := true else
5959 occupied[dir_down] := true;
5960 end else
5961 begin
5962 if abs(angledeg) < (180-4*dirtolerance) then
5963 begin
5964 if a2p.y > a1p.y then occupied[dir_leftup] := true else
5965 occupied[dir_leftdown] := true;
5966 end else
5967 begin
5968 occupied[dir_left] := true;
5969 end;
5970 end;
5971 end;
5972 end;
5973 end;
5974 end;
5975 // and now the assignment....
5976 n_occ := 0;
5977 for i := 1 to 8 do if occupied[i] then inc(n_occ);
5978 if n_occ = 1 then
5979 begin
5980 if occupied[dir_rightup] or
5981 occupied[dir_right] or
5982 occupied[dir_rightdown] then res := HPleft else res := HPright;
5983 end;
5984 if n_occ > 1 then
5985 begin
5986 if (occupied[dir_right] and
5987 (occupied[dir_leftup] or occupied[dir_left] or occupied[dir_leftdown])) then
5988 begin
5989 if (not occupied[dir_up]) and (not occupied[dir_rightup]) and
5990 (not occupied[dir_leftup]) then res := HPup;
5991 if (not occupied[dir_down]) and (not occupied[dir_rightdown]) and
5992 (not occupied[dir_leftdown]) then res := HPdown;
5993 if (n_occ > 2) and (not occupied[dir_left]) then res := HPleft;
5994 end;
5995 if (occupied[dir_left] and
5996 (occupied[dir_rightup] or occupied[dir_right] or occupied[dir_rightdown])) then
5997 begin
5998 if (not occupied[dir_up]) and (not occupied[dir_rightup]) and
5999 (not occupied[dir_leftup]) then res := HPup;
6000 if (not occupied[dir_down]) and (not occupied[dir_rightdown]) and
6001 (not occupied[dir_leftdown]) then res := HPdown;
6002 if (n_occ > 2) and (not occupied[dir_right]) then res := HPright;
6003 end;
6004 if (not occupied[dir_up]) and (occupied[dir_rightdown] or occupied[dir_right] or occupied[dir_down]) and
6005 (occupied[dir_leftdown] or occupied[dir_left] or occupied[dir_down]) then res := HPup;
6006 if (not occupied[dir_down]) and (occupied[dir_rightup] or occupied[dir_right] or occupied[dir_up]) and
6007 (occupied[dir_leftup] or occupied[dir_left] or occupied[dir_up]) then res := HPdown;
6008 if (not occupied[dir_leftup]) and
6009 (not occupied[dir_left]) and
6010 (not occupied[dir_leftdown]) then res := HPleft;
6011 if (not occupied[dir_rightup]) and
6012 (not occupied[dir_right]) and
6013 (not occupied[dir_rightdown]) then res := HPright;
6014 end;
6015 findHpos := res;
6016 end;
6017
6018
lookuprgbnull6019 function lookuprgb(elstr:str2):string;
6020 var
6021 i : integer;
6022 rval, gval, bval : single;
6023 tmpstr : string;
6024 valstr : string;
6025 begin
6026 tmpstr := '0 0 0';
6027 for i := 1 to max_rgbentries do
6028 begin
6029 if (elstr = rgbtable[i].element) then
6030 begin
6031 rval := rgbtable[i].r / 255;
6032 gval := rgbtable[i].g / 255;
6033 bval := rgbtable[i].b / 255;
6034 str(rval:1:2,valstr);
6035 tmpstr := valstr + ' ';
6036 str(gval:1:2,valstr);
6037 tmpstr := tmpstr + valstr + ' ';
6038 str(bval:1:2,valstr);
6039 tmpstr := tmpstr + valstr;
6040 end;
6041 end;
6042 lookuprgb := tmpstr;
6043 end;
6044
6045
lookuprgbhexnull6046 function lookuprgbhex(elstr:str2):string;
6047 var
6048 i : integer;
6049 rval, gval, bval : integer;
6050 tmpstr : string;
6051 begin
6052 tmpstr := '000000';
6053 for i := 1 to max_rgbentries do
6054 begin
6055 if (elstr = rgbtable[i].element) then
6056 begin
6057 rval := rgbtable[i].r;
6058 gval := rgbtable[i].g;
6059 bval := rgbtable[i].b;
6060 tmpstr := inttohex(rval,2) + inttohex(gval,2) + inttohex(bval,2);
6061 end;
6062 end;
6063 lookuprgbhex := tmpstr;
6064 end;
6065
6066 procedure printPSchars;
6067 const
6068 HPright = 1;
6069 HPleft = 2;
6070 HPup = 3;
6071 HPdown = 4;
6072 var
6073 i, j : integer;
6074 instr : string[20];
6075 checkstr1, checkstr2 : string[64];
6076 check1len, check2len : integer;
6077 outXint, outYint : integer;
6078 strlen : integer;
6079 outstr : str4;
6080 outchar, anchor : char;
6081 charX, charY : integer;
6082 el : str2;
6083 tmpstr : string;
6084 Hpos : integer;
6085 Hstr : string;
6086 rstr, lstr : string;
6087 chg : integer;
6088 chgstr : string;
6089 rad : integer;
6090 iso : integer;
6091 isostr : string;
6092 lblstr : string;
6093 extrashift : double;
6094 rgbstr : string;
6095 a1, a2 : integer;
6096 sg : boolean; // v0.2a
6097 alias : string; // v0.2b
6098 begin
6099 writeouts('stroke');
6100 writeouts('CFont');
6101 for i := 1 to n_atoms Do
6102 begin
6103 sg := false;
6104 if opt_sgroups then sg := atom^[i].sg; // v0.2a
6105 alias := atom^[i].alias; // v0.2b
6106 outstr := ' ';
6107 Hstr := '';
6108 rstr := '';
6109 lstr := '';
6110 chg := 0;
6111 chgstr := '';
6112 isostr := '';
6113 el := atom^[i].element;
6114 tmpstr := lowercase(el);
6115 tmpstr[1] := upcase(tmpstr[1]);
6116 instr := tmpstr;
6117 if (instr[2] = ' ') then delete(instr,2,1);
6118 if opt_color then
6119 begin
6120 rgbstr := lookuprgb(instr);
6121 if (el = 'H ') then
6122 begin
6123 if (atom^[i].nucleon_number = 2) then rgbstr := lookuprgb('D');
6124 if (atom^[i].nucleon_number = 3) then rgbstr := lookuprgb('T');
6125 end;
6126 end;
6127 lblstr := instr;
6128 {$IFDEF debug}
6129 debugoutput('atom '+inttostr(i)+': Hexp = '+inttostr(atom^[i].Hexp)+' Htot = '+ inttostr(atom^[i].Htot)); // v0.1f
6130 {$ENDIF}
6131 charX := round((atom^[i].x+xoffset)*blfactor);
6132 charY := round((atom^[i].y+yoffset)*blfactor);
6133 outXint := charX;
6134 outYint := charY - round(fontsize1*1.5); // was: 20
6135 updatebb(outXint, outYint);
6136 strlen := length(instr);
6137 Hpos := HPright; // default
6138 if (opt_Honhetero and is_electroneg(uppercase(el))) or
6139 (opt_Honhetero and is_metal(i)) or // v0.2b
6140 (opt_Honmethyl and is_methylC(i)) then
6141 begin
6142 if (atom^[i].Hexp > 0) and (opt_stripH = false) then Hstr := '' else
6143 begin
6144 if (atom^[i].Htot > 0) then Hstr := 'H';
6145 if (atom^[i].Htot > 1) then Hstr := Hstr + inttostr (atom^[i].Htot);
6146 if (atom^[i].tag and (atom^[i].Hexp = atom^[i].Htot)) then Hstr := ''; // v0.1f; avoids duplicate H labels for D and T
6147 end;
6148 end;
6149 Hpos := findHpos(i);
6150 if (atom^[i].neighbor_count = 0) and (Hstr <> '') then
6151 begin
6152 if is_electroneg(uppercase(el)) and (el <> 'N ') and (el <> 'P ') then Hpos := HPleft;
6153 end;
6154 if Hpos = HPright then rstr := Hstr else lstr := Hstr;
6155 chg := atom^[i].formal_charge;
6156 rad := atom^[i].radical_type;
6157 iso := atom^[i].nucleon_number;
6158 if (chg <> 0) then
6159 begin
6160 if (abs(chg) > 1) then chgstr := inttostr(chg);
6161 if (chg < 0) then chgstr := chgstr + '-' else chgstr := chgstr + '+';
6162 end else chgstr := '';
6163 if (rad = 1) then chgstr := chgstr + ':';
6164 if (rad = 2) then chgstr := chgstr + '.';
6165 if (rad = 3) then chgstr := chgstr + '=';
6166 extrashift := 1;
6167 if ((chgstr = '+') and (Hpos = HPup) and (atom^[i].Htot > 1)) then extrashift := 1.4;
6168 //if ((chgstr = '-') and (Hpos = HPup) and (atom^[i].Htot > 1)) then extrashift := 1.2;
6169 if ((chgstr = '-') and (Hpos = HPup) and (atom^[i].Htot > 1)) then extrashift := 1.4;
6170 if (iso > 0) then isostr := inttostr(iso);
6171
6172 // check for eclipsed atoms; v0.1f
6173 for j := 1 to n_atoms do
6174 begin
6175 if (j <> i) and (atom^[i].x = atom^[j].x) and (atom^[i].y = atom^[j].y) then
6176 begin
6177 atom^[j].hidden := true;
6178 end;
6179 end;
6180
6181 if (alias <> '') then // v0.2b
6182 begin
6183 instr := ' ';
6184 Hstr := '';
6185 chgstr := '';
6186 isostr := '';
6187 end;
6188
6189 if (atom^[i].hidden = false) and (sg = false) and (alias = '') then
6190 begin
6191 anchor := instr[1]; // what about selenophene?
6192 outstr := instr;
6193 writeout('%d dot %d dot moveto',[outXint,outYint]);
6194 writeouts('('+outstr+') stringwidth pop');
6195 writeouts('2 div neg 0 rmoveto');
6196 updatebb(outXint, outYint);
6197 writeouts('CFont');
6198 if opt_color then writeouts(rgbstr+' setrgbcolor');
6199 // place isotope label here
6200 if (isostr <> '') then
6201 begin
6202 writeout('%d dot %d dot moveto',[outXint,(charY+(charY-outYint))]);
6203 writeouts('('+outstr+') stringwidth pop');
6204 writeouts('2 div neg 0 rmoveto');
6205 writeouts('CFontSub');
6206 writeouts('('+isostr+') stringwidth pop neg 0 rmoveto');
6207 writeouts('('+isostr+') show');
6208 writeouts('CFont');
6209 end;
6210 //return to initial position
6211 writeout('%d dot %d dot moveto',[outXint,outYint]);
6212 writeouts('('+outstr+') stringwidth pop');
6213 writeouts('2 div neg 0 rmoveto');
6214 updatebb(outXint, outYint);
6215 for j := 1 to strlen do
6216 begin
6217 outchar := instr[(j)];
6218 if (pos(outchar,'0123456789') > 0) then
6219 begin
6220 writeouts('0 fs1 1.4 div neg dot rmoveto CFontSub');
6221 writeouts('('+outchar+') show');
6222 writeouts('0 fs1 1.4 div dot rmoveto CFont');
6223 end else
6224 begin
6225 outstr := outchar;
6226 writeouts('('+outstr+') show');
6227 end;
6228 end;
6229 strlen := length(rstr);
6230 if strlen > 0 then
6231 begin
6232 for j := 1 to strlen do
6233 begin
6234 outchar := rstr[(j)];
6235 if pos(outchar,'0123456789+-') > 0 then
6236 begin
6237 if pos(outchar,'0123456789') > 0 then
6238 begin
6239 writeouts('0 fs2 neg dot rmoveto CFontSub');
6240 writeouts('('+outchar+') show');
6241 writeouts('0 fs2 dot rmoveto CFont');
6242 end;
6243 end else
6244 begin
6245 outstr := outchar;
6246 writeouts('('+outstr+') show');
6247 end;
6248 end;
6249 end;
6250 // and now the charges
6251 strlen := length(chgstr);
6252 if strlen > 0 then
6253 begin
6254 for j := 1 to strlen do
6255 begin
6256 outchar := chgstr[(j)];
6257 if pos(outchar,'0123456789+-:.=') > 0 then
6258 begin
6259 if pos(outchar,'0123456789+') > 0 then
6260 begin
6261 writeouts('CFont 0 fs1 1.8 mul dot rmoveto');
6262 if outchar <> '+' then writeouts('CFontSub') else
6263 writeouts('CFontChg');
6264 writeouts('('+outchar+') show');
6265 writeouts('CFont');
6266 writeouts('0 fs1 1.8 mul neg dot rmoveto');
6267 end;
6268 if (outchar='-') then
6269 begin
6270 writeouts('CFont 0 fs1 1.8 mul dot rmoveto');
6271 writeouts('CFontChg Minus');
6272 writeouts('CFont');
6273 writeouts('0 fs1 1.8 mul neg dot rmoveto');
6274 end;
6275 if (outchar=':') then
6276 begin
6277 writeouts('CFont 0 fs1 1.8 mul dot rmoveto');
6278 writeouts('CFontChg Rad1');
6279 writeouts('CFont');
6280 writeouts('0 fs1 1.8 mul neg dot rmoveto');
6281 end;
6282 if (outchar='.') then
6283 begin
6284 writeouts('CFont 0 fs1 1.8 mul dot rmoveto');
6285 writeouts('CFontChg Rad2');
6286 writeouts('CFont');
6287 writeouts('0 fs1 1.8 mul neg dot rmoveto');
6288 end;
6289 if (outchar='=') then
6290 begin
6291 writeouts('CFont 0 fs1 1.8 mul dot rmoveto');
6292 writeouts('CFontChg Rad3');
6293 writeouts('CFont');
6294 writeouts('0 fs1 1.8 mul neg dot rmoveto');
6295 end;
6296 end;
6297 end;
6298 end;
6299 end;
6300 if (atom^[i].hidden and (atom^[i].element <> 'H ')) or (alias <> '') then // v0.1f, v0.2b
6301 begin
6302 lstr := '';
6303 rstr := '';
6304 end;
6305 if ((lstr <> '') and (Hpos = HPleft)) and (sg = false) then // right-justified
6306 begin
6307 instr := lstr;
6308 strlen := length(lstr);
6309 anchor := instr[(strlen)];
6310 outstr := anchor;
6311 writeout('%d dot %d dot moveto',[outXint,outYint]);
6312 writeouts('('+lblstr+') stringwidth pop');
6313 writeouts('2 div neg 0 rmoveto');
6314 updatebb(outXint, outYint);
6315 checkstr1 := '';
6316 checkstr2 := '';
6317 check1len := 0;
6318 check2len := 0;
6319 for j := 1 to strlen Do
6320 begin
6321 outchar := instr[(j)];
6322 if pos(outchar,'0123456789') > 0 then
6323 begin
6324 checkstr2 := checkstr2 + outchar;
6325 inc(check2len);
6326 end else
6327 begin
6328 outstr := outchar;
6329 checkstr1 := checkstr1 + outstr;
6330 inc(check1len);
6331 end;
6332 end;
6333 if (check2len > 0) then
6334 begin
6335 writeouts('CFontSub');
6336 writeouts('('+checkstr2+') stringwidth pop');
6337 writeouts('neg 0 rmoveto');
6338 end;
6339 if (check1len > 0) then
6340 begin
6341 writeouts('CFont');
6342 writeouts('('+checkstr1+') stringwidth pop');
6343 writeouts('neg 0 rmoveto');
6344 end;
6345 if (isostr <> '') then
6346 begin
6347 writeouts('CFontSub');
6348 writeouts('('+isostr+') stringwidth pop');
6349 writeouts('2 div neg 0 rmoveto');
6350 writeouts('CFont');
6351 end;
6352 for j := 1 to strlen do
6353 begin
6354 outchar := instr[(j)];
6355 if (pos(outchar,'0123456789') > 0) then
6356 begin
6357 writeouts('0 fs2 neg dot rmoveto CFontSub');
6358 writeouts('('+outchar+') show');
6359 writeouts('0 fs2 dot rmoveto CFontSub');
6360 end else
6361 begin
6362 outstr := outchar;
6363 writeouts('('+outstr+') show');
6364 end;
6365 end;
6366 end;
6367 if ((lstr <> '') and (Hpos = HPup)) and (sg = false) then
6368 begin
6369 anchor := el[1];
6370 outstr := anchor;
6371 writeout('%d dot %d dot moveto',[outXint,outYint]);
6372 writeouts('('+outstr+') stringwidth pop');
6373 writeout('2 div neg %d rmoveto',[round(fontsize1*0.8*extrashift)]);
6374 updatebb(outXint, outYint);
6375 instr := lstr;
6376 strlen := length(lstr);
6377 if (strlen > 0) then
6378 begin
6379 for j := 1 to strlen do
6380 begin
6381 outchar := lstr[(j)];
6382 if (pos(outchar,'0123456789') > 0) then
6383 begin
6384 if (pos(outchar,'0123456789') > 0) then
6385 begin
6386 writeouts('0 fs2 neg dot rmoveto CFontSub');
6387 writeouts('('+outchar+') show');
6388 writeouts('0 fs2 dot rmoveto CFontSub');
6389 end;
6390 end else
6391 begin
6392 outstr := outchar;
6393 writeouts('('+outstr+') show');
6394 end;
6395 end;
6396 end;
6397 end;
6398 if ((lstr <> '') and (Hpos = HPdown)) and (sg = false) then
6399 begin
6400 anchor := el[1];
6401 outstr := anchor;
6402 writeout('%d dot %d dot moveto',[outXint,outYint]);
6403 writeouts('('+outstr+') stringwidth pop');
6404 writeout('2 div neg %d neg rmoveto',[round(fontsize1*0.85)]);
6405 updatebb(outXint, outYint);
6406 instr := lstr;
6407 strlen := length(lstr);
6408 if (strlen > 0) then
6409 begin
6410 for j := 1 to strlen Do
6411 begin
6412 outchar := lstr[(j)];
6413 if (pos(outchar,'0123456789') > 0) then
6414 begin
6415 if (pos(outchar,'0123456789') > 0) then
6416 begin
6417 writeouts('0 fs2 neg dot rmoveto CFontSub');
6418 writeouts('('+outchar+') show');
6419 writeouts('0 fs2 dot rmoveto CFontSub');
6420 end;
6421 end else
6422 begin
6423 outstr := outchar;
6424 writeouts('('+outstr+') show');
6425 end;
6426 end;
6427 end;
6428 end;
6429 end;
6430 if opt_atomnum then
6431 begin
6432 writeouts('CFontNum');
6433 writeouts('0.7 setgray');
6434 for i := 1 to n_atoms do
6435 begin
6436 sg := false;
6437 if opt_sgroups then sg := atom^[i].sg; // v0.2a
6438 el := atom^[i].element;
6439 if ((not ((el = 'H ') and opt_stripH)) or (atom^[i].hidden = false)) and (sg = false) then
6440 begin
6441 charX := round((atom^[i].x+xoffset)*blfactor);
6442 charY := round((atom^[i].y+yoffset)*blfactor);
6443 outXint := charX;
6444 //outYint := charY - round(fontsize1*0.5); // was: 20
6445 outYint := charY;
6446 updatebb(outXint, outYint);
6447 outstr := inttostr(i);
6448 writeout('%d dot %d dot moveto',[outXint,outYint]);
6449 writeouts('('+outstr+') show');
6450 end;
6451 end;
6452 //writeln('0.0 setgray');
6453 writeouts('0.0 setgray');
6454 end;
6455 if (opt_bondnum and (n_bonds > 0)) then
6456 begin
6457 writeouts('CFontNum');
6458 writeouts('0.7 setgray');
6459 for i := 1 to n_bonds do
6460 begin
6461 sg := false;
6462 if opt_sgroups then sg := bond^[i].sg; // v0.2a
6463 if (not bond^[i].hidden) and (sg = false) then
6464 begin
6465 a1 := bond^[i].a1;
6466 a2 := bond^[i].a2;
6467 charX := round(((atom^[a1].x + atom^[a2].x)/2 +xoffset)*blfactor);
6468 charY := round(((atom^[a1].y + atom^[a2].y)/2 +yoffset)*blfactor);
6469 outXint := charX;
6470 outYint := charY - round(fontsize1*0.5); // was: 20
6471 updatebb(outXint, outYint);
6472 outstr := inttostr(i);
6473 writeout('%d dot %d dot moveto',[outXint,outYint]);
6474 writeouts('('+outstr+') stringwidth pop');
6475 writeouts('2 div neg 0 rmoveto');
6476 writeouts('('+outstr+') show');
6477 end;
6478 end;
6479 writeouts('0.0 setgray');
6480 end;
6481 if opt_maps then // v0.3a
6482 begin
6483 writeouts('CFontSub');
6484 writeouts('1.0 0 0.2 setrgbcolor');
6485 for i := 1 to n_atoms do
6486 begin
6487 if (atom^[i].map_id <> 0) then
6488 begin
6489 charX := round((atom^[i].x+xoffset)*blfactor + 1.5*fontsize1);
6490 charY := round((atom^[i].y+yoffset)*blfactor);
6491 outXint := charX;
6492 //outYint := charY - round(fontsize1*0.5); // was: 20
6493 outYint := charY;
6494 updatebb(outXint, outYint);
6495 outstr := '.' + inttostr(atom^[i].map_id) + '.';
6496 writeout('%d dot %d dot moveto',[outXint,outYint]);
6497 writeouts('('+outstr+') show');
6498 end;
6499 end;
6500 writeouts('0 0 0 setrgbcolor');
6501 end;
6502 end;
6503
6504 procedure printSVGchars;
6505 const
6506 HPright = 1;
6507 HPleft = 2;
6508 HPup = 3;
6509 HPdown = 4;
6510 kerning1 : string = ' dx="-5"';
6511 var
6512 i, j, k : integer;
6513 instr : string[20];
6514 checkstr1, checkstr2 : string[64];
6515 check1len, check2len : integer;
6516 outX, outY : single;
6517 strlen : integer;
6518 outstr : str4;
6519 outchar, anchor : char;
6520 charX, charY : single;
6521 el : str2;
6522 tmpstr : string;
6523 Hpos : integer;
6524 Hstr : string;
6525 rstr, lstr : string;
6526 chg : integer;
6527 chgstr : string;
6528 rad : integer;
6529 iso : integer;
6530 isostr : string;
6531 lblstr : string;
6532 extrashift : double;
6533 rgbstr : string;
6534 a1, a2 : integer;
6535 dysub : single;
6536 dysuper : single;
6537 sg : boolean;
6538 ylevel, prev_ylevel, delta_y : single;
6539 fs4 : integer;
6540 colstr : string;
6541 alias : string; // v0.2b
6542 strwidth : single; // v0.2c
6543 bstr : string;
6544 kernstr : string;
6545 begin
6546 dysub := (fontsize2*0.5);
6547 dysuper := -(fontsize2*0.7);
6548 for i := 1 to n_atoms Do
6549 begin
6550 ylevel := 0;
6551 sg := false;
6552 if opt_sgroups then sg := atom^[i].sg;
6553 alias := atom^[i].alias; // v0.2b
6554 outstr := ' ';
6555 Hstr := '';
6556 rstr := '';
6557 lstr := '';
6558 chg := 0;
6559 chgstr := '';
6560 isostr := '';
6561 el := atom^[i].element;
6562 tmpstr := lowercase(el);
6563 tmpstr[1] := upcase(tmpstr[1]);
6564 instr := tmpstr;
6565 if (instr[2] = ' ') then delete(instr,2,1);
6566 colstr := '';
6567 if opt_color then
6568 begin
6569 rgbstr := lookuprgbhex(instr);
6570 if (el = 'H ') then
6571 begin
6572 if (atom^[i].nucleon_number = 2) then rgbstr := lookuprgbhex('D');
6573 if (atom^[i].nucleon_number = 3) then rgbstr := lookuprgbhex('T');
6574 end;
6575 colstr := ' fill="#'+rgbstr+'"';
6576 end;
6577 lblstr := instr;
6578 {$IFDEF debug}
6579 debugoutput('atom '+inttostr(i)+': Hexp = '+inttostr(atom^[i].Hexp)+' Htot = '+ inttostr(atom^[i].Htot)); // v0.1f
6580 {$ENDIF}
6581 charX := (atom^[i].x+xoffset)*blfactor*svg_factor;
6582 charY := (atom^[i].y+yoffset)*blfactor*-svg_factor + svg_yoffset;
6583 outX := charX - (fontsize1*0.35);
6584 outY := charY + (fontsize1*0.4);
6585 strlen := length(instr);
6586 Hpos := HPright; // default
6587 if (opt_Honhetero and is_electroneg(uppercase(el))) or
6588 (opt_Honhetero and is_metal(i)) or // v0.2b
6589 (opt_Honmethyl and is_methylC(i)) then
6590 begin
6591 if (atom^[i].Hexp > 0) and (opt_stripH = false) then Hstr := '' else
6592 begin
6593 if (atom^[i].Htot > 0) then Hstr := 'H';
6594 if (atom^[i].Htot > 1) then Hstr := Hstr + inttostr (atom^[i].Htot);
6595 if (atom^[i].tag and (atom^[i].Hexp = atom^[i].Htot)) then Hstr := ''; // v0.1f; avoids duplicate H labels for D and T
6596 end;
6597 end;
6598 Hpos := findHpos(i);
6599 if (atom^[i].neighbor_count = 0) and (Hstr <> '') then
6600 begin
6601 if is_electroneg(uppercase(el)) and (el <> 'N ') and (el <> 'P ') then Hpos := HPleft;
6602 end;
6603 if Hpos = HPright then rstr := Hstr else lstr := Hstr;
6604 chg := atom^[i].formal_charge;
6605 rad := atom^[i].radical_type;
6606 iso := atom^[i].nucleon_number;
6607 if (chg <> 0) then
6608 begin
6609 if (abs(chg) > 1) then chgstr := inttostr(chg);
6610 if (chg < 0) then chgstr := chgstr + '-' else chgstr := chgstr + '+';
6611 end else chgstr := '';
6612 if (rad = 1) then chgstr := chgstr + ':';
6613 if (rad = 2) then chgstr := chgstr + '.';
6614 if (rad = 3) then chgstr := chgstr + '=';
6615 extrashift := 1;
6616 if ((chgstr = '+') and (Hpos = HPup) and (atom^[i].Htot > 1)) then extrashift := 1.4;
6617 if ((chgstr = '-') and (Hpos = HPup) and (atom^[i].Htot > 1)) then extrashift := 1.4;
6618 if (iso > 0) then isostr := inttostr(iso) else isostr := '';
6619
6620 // check for eclipsed atoms; v0.1f
6621 for j := 1 to n_atoms do
6622 begin
6623 if (j <> i) and (atom^[i].x = atom^[j].x) and (atom^[i].y = atom^[j].y) then
6624 begin
6625 atom^[j].hidden := true;
6626 end;
6627 end;
6628
6629 if (alias <> '') then // v0.2b
6630 begin
6631 instr := ' ';
6632 Hstr := '';
6633 chgstr := '';
6634 isostr := '';
6635 end;
6636
6637 if (atom^[i].hidden = false) and (sg = false) and (alias = '') then
6638 begin
6639 bstr := '';
6640 anchor := instr[1]; // what about selenophene?
6641 outstr := instr;
6642 strwidth := length(rstr)*fontsize1*1.1;
6643 //chk_svg_max_xy((outX+0.1*get_stringwidth(fontsize1,rstr)),outY);
6644 chk_svg_max_xy((outX+strwidth),outY);
6645 bstr := format('<text x="%1.1f" y="%1.1f">',[outx,outy],fsettings);
6646
6647 for j := 1 to strlen do
6648 begin
6649 prev_ylevel := ylevel;
6650 outchar := instr[(j)];
6651 if (pos(outchar,'0123456789') > 0) then
6652 begin
6653 ylevel := dysub;
6654 delta_y := ylevel - prev_ylevel;
6655 if (abs(delta_y) > 0.1) then
6656 bstr := bstr + format('<tspan font-size="%d" dy="%1.1f">%s</tspan>',[fontsize2,delta_y,outchar],fsettings)
6657 else
6658 bstr := bstr + format('<tspan font-size="%d">%s</tspan>',[fontsize2,outchar],fsettings);
6659 end else
6660 begin
6661 outstr := outchar;
6662 ylevel := 0;
6663 delta_y := ylevel - prev_ylevel;
6664 if (abs(delta_y) > 0.1) then
6665 bstr := bstr + format('<tspan%s dy="%1.1f">%s</tspan>',[colstr,delta_y,outchar],fsettings)
6666 else
6667 bstr := bstr + format('<tspan%s>%s</tspan>',[colstr,outstr],fsettings);
6668 end;
6669 end;
6670 strlen := length(rstr);
6671 if strlen > 0 then
6672 begin
6673 for j := 1 to strlen do
6674 begin
6675 prev_ylevel := ylevel;
6676 outchar := rstr[(j)];
6677 if pos(outchar,'0123456789+-') > 0 then
6678 begin
6679 if pos(outchar,'0123456789') > 0 then
6680 begin
6681 ylevel := dysub;
6682 delta_y := ylevel - prev_ylevel;
6683 if (abs(delta_y) > 0.1) then
6684 bstr := bstr + format('<tspan font-size="%d" dy="%1.1f">%s</tspan>',[fontsize2,delta_y,outchar],fsettings)
6685 else
6686 bstr := bstr + format('<tspan font-size="%d">%s</tspan>',[fontsize2,outchar],fsettings);
6687 end;
6688 end else
6689 begin
6690 outstr := outchar;
6691 ylevel := 0;
6692 delta_y := ylevel - prev_ylevel;
6693 if (abs(delta_y) > 0.1) then
6694 bstr := bstr + format('<tspan dy="%1.1f">%s</tspan>',[delta_y,outstr],fsettings)
6695 else
6696 bstr := bstr + format('<tspan>%s</tspan>',[outstr],fsettings)
6697 end;
6698 end;
6699 end;
6700 // and now the charges
6701 strlen := length(chgstr);
6702 prev_ylevel := ylevel;
6703 if strlen > 0 then
6704 begin
6705 for j := 1 to strlen do
6706 begin
6707 outchar := chgstr[(j)];
6708 prev_ylevel := ylevel;
6709 if pos(outchar,'0123456789+-:.=') > 0 then
6710 begin
6711 if pos(outchar,'0123456789+') > 0 then
6712 begin
6713 ylevel := dysuper;
6714 delta_y := ylevel - prev_ylevel;
6715 if (abs(delta_y) > 0.1) then
6716 bstr := bstr + format('<tspan font-size="%d" dy="%1.1f">%s</tspan>',[fontsize2,delta_y,outchar],fsettings)
6717 else
6718 bstr := bstr + format('<tspan font-size="%d">%s</tspan>',[fontsize2,outchar],fsettings)
6719 end;
6720 if (outchar='-') then
6721 begin
6722 ylevel := dysuper;
6723 delta_y := ylevel - prev_ylevel;
6724 if (abs(delta_y) > 0.1) then
6725 bstr := bstr + format('<tspan dy="%1.1f">%s</tspan>',[delta_y,outchar],fsettings)
6726 else
6727 bstr := bstr + format('<tspan>%s</tspan>',[outchar],fsettings);
6728 end;
6729 if (outchar=':') then
6730 begin
6731 ylevel := -1;
6732 delta_y := ylevel - prev_ylevel;
6733 if (abs(delta_y) > 0.1) then
6734 bstr := bstr + format('<tspan font-weight="bold" dy="%1.1f">%s</tspan>',[delta_y,outchar],fsettings)
6735 else
6736 bstr := bstr + format('<tspan font-weight="bold">%s</tspan>',[outchar],fsettings);
6737 end;
6738 if (outchar='.') then
6739 begin
6740 ylevel := dysuper;
6741 delta_y := ylevel - prev_ylevel;
6742 if (abs(delta_y) > 0.1) then
6743 bstr := bstr + format('<tspan dy="%1.1f">•</tspan>',[delta_y],fsettings)
6744 else
6745 bstr := bstr + '<tspan>•</tspan>';
6746 end;
6747 if (outchar='=') then
6748 begin
6749 ylevel := dysuper;
6750 delta_y := ylevel - prev_ylevel;
6751 if (abs(delta_y) > 0.1) then
6752 bstr := bstr + format('<tspan dy="%1.1f">^^</tspan>',[delta_y],fsettings)
6753 else
6754 bstr := bstr + '<tspan>^^</tspan>';
6755 end;
6756 end;
6757 end;
6758 end;
6759 writeouts(bstr); bstr := '';
6760 writeouts('</text>');
6761 end;
6762 if (atom^[i].hidden and (atom^[i].element <> 'H ')) or (alias <> '') then // v0.1f, v0.2b
6763 begin
6764 lstr := '';
6765 rstr := '';
6766 end;
6767
6768 if (((lstr <> '') and (Hpos = HPleft)) or (isostr <> '')) and (sg = false) then // right-justified
6769 begin
6770 bstr := '';
6771 ylevel := 0;
6772 instr := lstr;
6773 strlen := length(lstr);
6774 anchor := instr[(strlen)];
6775 outstr := anchor;
6776 bstr := format('<text text-anchor="end" x="%1.1f" y="%1.1f">',[outx,outy],fsettings);
6777
6778 if ((lstr <> '') and (Hpos = HPleft)) then
6779 begin
6780 checkstr1 := '';
6781 checkstr2 := '';
6782 check1len := 0;
6783 check2len := 0;
6784 for j := 1 to strlen do
6785 begin
6786 prev_ylevel := ylevel;
6787 outchar := instr[(j)];
6788 if (pos(outchar,'0123456789') > 0) then
6789 begin
6790 ylevel := dysub;
6791 delta_y := ylevel - prev_ylevel;
6792 if (abs(delta_y) > 0.1) then
6793 bstr := bstr + format('<tspan font-size="%d" dy="%1.1f">%s</tspan>',[fontsize2,delta_y,outchar],fsettings)
6794 else
6795 bstr := bstr + format('<tspan font-size="%d">%s</tspan>',[fontsize2,outchar],fsettings);
6796 end else
6797 begin
6798 ylevel := 0;
6799 delta_y := ylevel - prev_ylevel;
6800 if (abs(delta_y) > 0.1) then
6801 bstr := bstr + format('<tspan dy="%1.1f">%s</tspan>',[delta_y,outchar],fsettings)
6802 else
6803 bstr := bstr + format('<tspan>%s</tspan>',[outchar],fsettings);
6804 end;
6805 end;
6806 end; // lstr <> ''
6807 if (isostr <> '') then
6808 begin
6809 prev_ylevel := ylevel;
6810 ylevel := dysuper;
6811 delta_y := ylevel - prev_ylevel;
6812 if (abs(delta_y) > abs(dysuper)) then kernstr := format(' dx="-%d"',[(fontsize2 div 2)],fsettings) else kernstr := '';
6813 //bstr := bstr + format('<text text-anchor="end" x="%1.1f" y="%1.1f">',[outx,outy],fsettings);
6814 bstr := bstr + format('<tspan font-size="%d" dy="%1.1f"%s>%s</tspan>',[fontsize2,delta_y,kernstr,isostr],fsettings);
6815 ylevel := dysuper;
6816 end;
6817 bstr := bstr + '</text>';
6818 writeouts(bstr); bstr := '';
6819 end;
6820
6821 if ((lstr <> '') and (Hpos = HPup)) and (sg = false) then
6822 begin
6823 anchor := el[1];
6824 outstr := anchor;
6825 writeout('<text x="%1.1f" y="%1.1f">',[outx,(outy-fontsize1*0.85*extrashift)]);
6826 instr := lstr;
6827 strlen := length(lstr);
6828 bstr := '';
6829 if (strlen > 0) then
6830 begin
6831 for j := 1 to strlen do
6832 begin
6833 outchar := lstr[(j)];
6834 if (pos(outchar,'0123456789') > 0) then
6835 begin
6836 if (pos(outchar,'0123456789') > 0) then
6837 begin
6838 bstr := bstr + format('<tspan font-size="%d" dy="%1.1f">%s</tspan>',[fontsize2,dysub,outchar],fsettings);
6839 end;
6840 end else
6841 begin
6842 outstr := outchar;
6843 bstr := bstr + format('<tspan>%s</tspan>',[outchar],fsettings);
6844 end;
6845 end;
6846 end;
6847 bstr := bstr + '</text>';
6848 writeouts(bstr); bstr := '';
6849 end;
6850
6851 if ((lstr <> '') and (Hpos = HPdown)) and (sg = false) then
6852 begin
6853 anchor := el[1];
6854 outstr := anchor;
6855 writeout('<text x="%1.1f" y="%1.1f">',[outx,(outY+fontsize1*0.85)]);
6856 instr := lstr;
6857 strlen := length(lstr);
6858 bstr := '';
6859 if (strlen > 0) then
6860 begin
6861 for j := 1 to strlen do
6862 begin
6863 outchar := lstr[(j)];
6864 if (pos(outchar,'0123456789') > 0) then
6865 begin
6866 if (pos(outchar,'0123456789') > 0) then
6867 begin
6868 bstr := bstr + format('<tspan font-size="%d" dy="%1.1f">%s</tspan>',[fontsize2,dysub,outchar],fsettings);
6869 end;
6870 end else
6871 begin
6872 outstr := outchar;
6873 bstr := bstr + format('<tspan>%s</tspan>',[outchar],fsettings);
6874 end;
6875 end;
6876 end;
6877 bstr := bstr + '</text>';
6878 writeouts(bstr); bstr := '';
6879 end;
6880 end;
6881 if opt_atomnum then
6882 begin
6883 fs4 := round(fontsize1 / 2.5);
6884 for i := 1 to n_atoms do
6885 begin
6886 el := atom^[i].element;
6887 if (not ((el = 'H ') and opt_stripH)) or (atom^[i].hidden = false) then
6888 begin
6889 charX := (atom^[i].x+xoffset)*blfactor*svg_factor;
6890 charY := (atom^[i].y+yoffset)*blfactor*-svg_factor + svg_yoffset;
6891 outX := charX;
6892 outY := charY;
6893 outstr := inttostr(i);
6894 strwidth := length(outstr)*fs4*1.1;
6895 chk_svg_max_xy((outX+strwidth),outY);
6896 writeout('<text style="fill:#999999; font-size:%d;" x="%1.1f" y="%1.1f">%s</text>',[fs4,outx,outy,outstr]);
6897 end;
6898 end;
6899 end;
6900 if (opt_bondnum and (n_bonds > 0)) then
6901 begin
6902 fs4 := round(fontsize1 / 2.5);
6903 for i := 1 to n_bonds do
6904 begin
6905 if (not bond^[i].hidden) then
6906 begin
6907 a1 := bond^[i].a1;
6908 a2 := bond^[i].a2;
6909 charX := ((atom^[a1].x + atom^[a2].x)/2 +xoffset)*blfactor*svg_factor;
6910 charY := ((atom^[a1].y + atom^[a2].y)/2 +yoffset)*blfactor*-svg_factor + svg_yoffset;
6911 outX := charX;
6912 outY := charY + fs4*0.4; // was: 20
6913 outstr := inttostr(i);
6914 writeout('<text style="fill:#999999; font-size:%d;" text-anchor="middle" x="%1.1f" y="%1.1f">%s</text>',[fs4,outx,outy,outstr]);
6915 end;
6916 end;
6917 end;
6918 if opt_maps then // v0.3a
6919 begin
6920 fs4 := round(fontsize1 / 1.25);
6921 for i := 1 to n_atoms do
6922 begin
6923 if (atom^[i].map_id <> 0) then
6924 begin
6925 charX := (atom^[i].x+xoffset)*blfactor*svg_factor + 0.125*fontsize1;
6926 charY := (atom^[i].y+yoffset)*blfactor*-svg_factor + svg_yoffset;
6927 outX := charX;
6928 outY := charY;
6929 outstr := '.' + inttostr(atom^[i].map_id) + '.';
6930 strwidth := length(outstr)*fs4*1.1;
6931 chk_svg_max_xy((outX+strwidth),outY);
6932 writeout('<text fill="#ff0033" style="font-size:%dpx" font-weight="bold" x="%1.1f" y="%1.1f">%s</text>',[fs4,outx,outy,outstr]);
6933 end;
6934 end;
6935 end;
6936 end;
6937
popchar1null6938 function popchar1(var instr:string):string; // v0.2b
6939 var
6940 i : integer;
6941 outstr : string;
6942 codechar : char;
6943 begin
6944 outstr := '';
6945 if (length(instr) > 0) then
6946 begin
6947 codechar := ' ';
6948 if (instr[1] = '\') then
6949 begin
6950 delete(instr,1,1);
6951 if (length(instr) > 0) then
6952 begin
6953 if (instr[1] = 'n') then
6954 begin
6955 codechar := '=';
6956 delete(instr,1,1);
6957 end;
6958 if (instr[1] = 'S') then
6959 begin
6960 codechar := '+';
6961 delete(instr,1,1);
6962 end;
6963 if (instr[1] = 's') then
6964 begin
6965 codechar := '-';
6966 delete(instr,1,1);
6967 end;
6968 end;
6969 end;
6970 outstr := codechar + instr[1];
6971 delete(instr,1,1);
6972 end;
6973 popchar1 := outstr;
6974 end;
6975
6976 procedure printPSlabel_autosub(x:single;y:single;outstr:string;just:char);
6977 var
6978 i,j,p : integer;
6979 charX,charY : integer;
6980 outXint,outYint : integer;
6981 instr : string;
6982 strlen : integer;
6983 nstr, tstr : string;
6984 outchar : char;
6985 smode : smallint; // v0.2b 1 = superscript, 0 = normal, -1 = autosub (digits only) -2 = sub
6986 tmpstr, tmpstr_out, tmpstr_n, tmpstr_s : string; // v0.2b
6987 attr : attr_arr;
6988 trimstr_n, trimstr_s, anchorstr_n, anchorstr_s, purestr : string;
6989 anchorpos : integer;
6990 n_mode : boolean;
6991 sub_mode : boolean;
6992 sup_mode : boolean;
6993 b : byte;
6994 trstr : string;
6995 begin
6996 if (outstr = '') then exit;
6997 smode := -1;
6998 tmpstr := outstr; // v0.2b
6999 tmpstr_out := '';
7000 tmpstr_n := '';
7001 tmpstr_s := '';
7002 charX := round((x+xoffset)*blfactor);
7003 charY := round((y+yoffset)*blfactor);
7004 outXint := charX;
7005 outYint := charY - round(fontsize1*1.5); // was: 20 / 0.8
7006 writeout('%d dot %d dot moveto',[outXint,outYint]);
7007 updatebb(outXint, outYint);
7008 // new label processing
7009 fillchar(attr,sizeof(attr),0);
7010 anchorpos := 0;
7011 purestr := '';
7012 trimstr_n := '';
7013 trimstr_s := '';
7014 tmpstr := outstr;
7015 n_mode := false;
7016 sub_mode := false;
7017 sup_mode := false;
7018 while (length(tmpstr) > 0) do
7019 begin
7020 p := length(purestr);
7021 if (tmpstr[1] = '^') then
7022 begin
7023 delete(tmpstr,1,1);
7024 if (anchorpos = 0) then anchorpos := p + 1; // accept only the first ^
7025 end;
7026 if (tmpstr[1] = '\') then
7027 begin
7028 delete(tmpstr,1,1);
7029 if (tmpstr[1] = 'n') then
7030 begin
7031 delete(tmpstr,1,1);
7032 n_mode := (not n_mode);
7033 end;
7034 if (tmpstr[1] = 's') then
7035 begin
7036 delete(tmpstr,1,1);
7037 sub_mode := (not sub_mode);
7038 end;
7039 if (tmpstr[1] = 'S') then
7040 begin
7041 delete(tmpstr,1,1);
7042 sup_mode := (not sup_mode);
7043 end;
7044 end;
7045 purestr := purestr + tmpstr[1];
7046 delete(tmpstr,1,1);
7047 p := length(purestr);
7048 if n_mode then
7049 attr[p] := 0
7050 else
7051 begin
7052 if sup_mode then
7053 attr[p] := 3
7054 else
7055 begin
7056 if sub_mode then
7057 attr[p] := 1
7058 else
7059 begin
7060 outchar := purestr[p];
7061 if (pos(outchar,'0123456789') > 0) then attr[p] := 1 else attr[p] := 0;
7062 end;
7063 end;
7064 end;
7065 end;
7066 // now we have the pure string together with the attributes in attr[]
7067 if (anchorpos > length(purestr)) then purestr := purestr + ' '; // like ISIS/Draw
7068 if (anchorpos = 0) then
7069 begin
7070 if (just = 'L') then anchorpos := 1;
7071 if (just = 'R') then anchorpos := length(purestr);
7072 if (just = 'C') then anchorpos := length(purestr) + 1; // sic!
7073 end;
7074 // now assemble the two trim strings for normal and small font
7075 if (anchorpos > 1) then
7076 begin
7077 trimstr_n := '';
7078 trimstr_s := '';
7079 for i := 1 to (anchorpos - 1) do
7080 begin
7081 if odd(attr[i]) then trimstr_s := trimstr_s + purestr[i] else
7082 trimstr_n := trimstr_n + purestr[i];
7083 end;
7084 end;
7085 if (purestr = '') then exit; // just to be sure
7086
7087 {$IFDEF debug}
7088 debugoutput('anchor position: '+inttostr(anchorpos)); // v0.2b
7089 debugoutput('trim string (n): '+trimstr_n); // v0.2b
7090 debugoutput('trim string (s): '+trimstr_s); // v0.2b
7091 {$ENDIF}
7092
7093 // and now the (relative) positioning
7094 if (just = 'C') then
7095 begin
7096 if (length(trimstr_n) > 0) then
7097 begin
7098 (*
7099 writeln('CFont');
7100 writeln('(',trimstr_n,') stringwidth pop');
7101 writeln('2 div neg 0 rmoveto');
7102 *)
7103 writeouts('CFont');
7104 writeouts('('+trimstr_n+') stringwidth pop');
7105 writeouts('2 div neg 0 rmoveto');
7106 updateBB(outXint+round(1.0*get_stringwidth(fontsize1,trimstr_n)),outYint);
7107 end;
7108 if (length(trimstr_s) > 0) then
7109 begin
7110 (*
7111 writeln('CFontSub');
7112 writeln('(',trimstr_s,') stringwidth pop');
7113 writeln('2 div neg 0 rmoveto');
7114 *)
7115 writeouts('CFontSub');
7116 writeouts('('+trimstr_s+') stringwidth pop');
7117 writeouts('2 div neg 0 rmoveto');
7118 updateBB(outXint+round(1.0*get_stringwidth(fontsize2,trimstr_s)),outYint);
7119 end;
7120 end else
7121 begin
7122 // first, handle the anchor character
7123 p := anchorpos;
7124 outchar := purestr[p];
7125 if (odd(attr[p])) then
7126 begin // small font
7127 (*
7128 writeln('CFontSub');
7129 writeln('(',outchar,') stringwidth pop');
7130 writeln('2 div neg 0 rmoveto');
7131 *)
7132 writeouts('CFontSub');
7133 writeouts('('+outchar+') stringwidth pop');
7134 writeouts('2 div neg 0 rmoveto');
7135 end else
7136 begin // normal font
7137 (*
7138 writeln('CFont');
7139 writeln('(',outchar,') stringwidth pop');
7140 writeln('2 div neg 0 rmoveto');
7141 *)
7142 writeouts('CFont');
7143 writeouts('('+outchar+') stringwidth pop');
7144 writeouts('2 div neg 0 rmoveto');
7145 end;
7146 if (length(trimstr_n) > 0) then
7147 begin
7148 (*
7149 writeln('CFont');
7150 writeln('(',trimstr_n,') stringwidth pop neg 0 rmoveto');
7151 *)
7152 writeouts('CFont');
7153 writeouts('('+trimstr_n+') stringwidth pop neg 0 rmoveto');
7154 updateBB(outXint-round(2.0*get_stringwidth(fontsize1,trimstr_n)),outYint);
7155 end;
7156 if (length(trimstr_s) > 0) then
7157 begin
7158 (*
7159 writeln('CFontSub');
7160 writeln('(',trimstr_s,') stringwidth pop neg 0 rmoveto');
7161 *)
7162 writeouts('CFontSub');
7163 writeouts('('+trimstr_s+') stringwidth pop neg 0 rmoveto');
7164 updateBB(outXint-round(2.0*get_stringwidth(fontsize2,trimstr_s)),outYint);
7165 end;
7166 end;
7167 updateBB(outXint+round(2.0*get_stringwidth(fontsize1,purestr)),outYint);
7168 // now positioning is finished and we can print the string character by character
7169 for i := 1 to length(purestr) do
7170 begin
7171 outchar := purestr[i];
7172 trstr := outchar; // if necessary, do some translations here
7173 b := attr[i];
7174 if odd(b) then
7175 begin
7176 if (b = 1) then // subscript
7177 begin
7178 (*
7179 writeln('0 fs1 1.4 div neg dot rmoveto CFontSub');
7180 writeln('(',trstr,') show');
7181 writeln('0 fs1 1.4 div dot rmoveto CFont');
7182 *)
7183 writeouts('0 fs1 1.4 div neg dot rmoveto CFontSub');
7184 writeouts('('+trstr+') show');
7185 writeouts('0 fs1 1.4 div dot rmoveto CFont');
7186 end;
7187 if (b = 3) then // subscript
7188 begin
7189 (*
7190 writeln('0 fs1 0.6 div dot rmoveto CFontSub');
7191 writeln('(',trstr,') show');
7192 writeln('0 fs1 0.6 div neg dot rmoveto CFont');
7193 *)
7194 writeouts('0 fs1 0.6 div dot rmoveto CFontSub');
7195 writeouts('('+trstr+') show');
7196 writeouts('0 fs1 0.6 div neg dot rmoveto CFont');
7197 end;
7198 end else
7199 begin
7200 writeouts('CFont ('+trstr+') show');
7201 end;
7202 end; // for i
7203 //if opt_color then writeln('0 0 0 setrgbcolor');
7204 end;
7205
7206 procedure printSVGlabel_autosub(x:single;y:single;outstr:string;just:char);
7207 var
7208 i, j, p : integer;
7209 charX,charY : single;
7210 outX,outY : single;
7211 outchar : char;
7212 dysub : single;
7213 ylevel, prev_ylevel, delta_y : single;
7214 smode : smallint; // v0.2b 1 = superscript, 0 = normal, -1 = autosub (digits only) -2 = sub
7215 tmpstr, tmpstr_out, tmpstr_n, tmpstr_s : string; // v0.2b
7216 attr : attr_arr;
7217 trimstr_n, trimstr_s, anchorstr_n, anchorstr_s, purestr : string;
7218 anchorpos : integer;
7219 n_mode : boolean;
7220 sub_mode : boolean;
7221 sup_mode : boolean;
7222 b, prev_b : byte;
7223 trstr : string;
7224 cwf : single; // character width factor
7225 strwidth : single; // v0.2c
7226 bstr : string; // v0.4
7227 begin
7228 if (outstr = '') then exit;
7229 smode := -1;
7230 tmpstr := outstr; // v0.2b
7231 tmpstr_out := '';
7232 tmpstr_n := '';
7233 tmpstr_s := '';
7234 dysub := (fontsize2*0.7);
7235 charX := (x+xoffset)*blfactor*svg_factor;
7236 charY := (y+yoffset)*blfactor*-svg_factor + svg_yoffset;
7237 cwf := 0.35; // default character width
7238
7239 // new label processing, v0.2b
7240 fillchar(attr,sizeof(attr),0);
7241 anchorpos := 0;
7242 purestr := '';
7243 trimstr_n := '';
7244 trimstr_s := '';
7245 tmpstr := outstr;
7246 n_mode := false;
7247 sub_mode := false;
7248 sup_mode := false;
7249 while (length(tmpstr) > 0) do
7250 begin
7251 p := length(purestr);
7252 if (tmpstr[1] = '^') then
7253 begin
7254 delete(tmpstr,1,1);
7255 if (anchorpos = 0) then anchorpos := p + 1; // accept only the first ^
7256 end;
7257 if (tmpstr[1] = '\') then
7258 begin
7259 delete(tmpstr,1,1);
7260 if (tmpstr[1] = 'n') then
7261 begin
7262 delete(tmpstr,1,1);
7263 n_mode := (not n_mode);
7264 end;
7265 if (tmpstr[1] = 's') then
7266 begin
7267 delete(tmpstr,1,1);
7268 sub_mode := (not sub_mode);
7269 end;
7270 if (tmpstr[1] = 'S') then
7271 begin
7272 delete(tmpstr,1,1);
7273 sup_mode := (not sup_mode);
7274 end;
7275 end;
7276 purestr := purestr + tmpstr[1];
7277 delete(tmpstr,1,1);
7278 p := length(purestr);
7279 if n_mode then
7280 attr[p] := 0
7281 else
7282 begin
7283 if sup_mode then
7284 attr[p] := 3
7285 else
7286 begin
7287 if sub_mode then
7288 attr[p] := 1
7289 else
7290 begin
7291 outchar := purestr[p];
7292 if (pos(outchar,'0123456789') > 0) then attr[p] := 1 else attr[p] := 0;
7293 end;
7294 end;
7295 end;
7296 end;
7297 // now we have the pure string together with the attributes in attr[]
7298 if (anchorpos > length(purestr)) then purestr := purestr + ' '; // like ISIS/Draw
7299 if (anchorpos = 0) then
7300 begin
7301 if (just = 'L') then anchorpos := 1;
7302 if (just = 'R') then anchorpos := length(purestr);
7303 if (just = 'C') then anchorpos := 1; // sic!
7304 end;
7305 if (purestr = '') then exit; // just to be sure
7306 {$IFDEF debug}
7307 debugoutput('anchor position: '+inttostr(anchorpos));
7308 {$ENDIF}
7309
7310 // and now the (relative) positioning
7311 tmpstr := '';
7312 if (anchorpos > 1) then tmpstr := ' text-anchor="end" ';
7313 if (just = 'C') then
7314 begin
7315 outX := charX;
7316 outY := charY + (fontsize1*0.38);
7317 strwidth := length(purestr)*0.5*fontsize1*1.1;
7318 //chk_svg_max_xy((outX+strwidth),outY);
7319 chk_svg_max_xy((outX+0.6*0.5*get_stringwidth(fontsize1,purestr)),outY);
7320 writeout('<text text-anchor="middle" x="%1.1f" y="%1.1f">',[outx,outy]);
7321 end else
7322 begin
7323 // first, handle the anchor character
7324 p := anchorpos;
7325 outchar := purestr[p];
7326 if (pos(outchar,'MW') > 0) then cwf := 0.45;
7327 if (outchar = '1') then cwf := 0.25;
7328 if (pos(outchar,'iIl.:,;!') > 0) then cwf := 0.15;
7329 if (odd(attr[p])) then
7330 begin // small font
7331 outX := charX - (fontsize2*cwf);
7332 outY := charY + (fontsize1*0.38); // sic! (fontsize1)
7333 writeout('<text font-size="%d" %s x="%1.1f" y="%1.1f">',[fontsize2,tmpstr,outx,outy]);
7334 end else
7335 begin // normal font
7336 outX := charX - (fontsize1*cwf);
7337 outY := charY + (fontsize1*0.38);
7338 writeout('<text %s x="%1.1f" y="%1.1f">',[tmpstr,outx,outy]);
7339 end;
7340 if (just = 'L') then
7341 begin
7342 strwidth := length(purestr)*fontsize1*1.1;
7343 //chk_svg_max_xy((outX+strwidth),outY);
7344 chk_svg_max_xy((outX+0.6*get_stringwidth(fontsize1,copy(purestr,anchorpos,(length(purestr)-anchorpos)))),outY);
7345 end;
7346 end;
7347
7348 // now positioning is finished and we can print the string character by character;
7349 ylevel := 0;
7350 // first, print any character left of the anchor (if any)
7351 if (anchorpos > 1) then
7352 begin
7353 bstr := '';
7354 prev_b := 255;
7355 for i := 1 to (anchorpos - 1) do
7356 begin
7357 prev_ylevel := ylevel;
7358 outchar := purestr[i];
7359 trstr := outchar; // if necessary, do some translations here
7360 b := attr[i];
7361 if (b <> prev_b) and (prev_b <> 255) then
7362 bstr := bstr + '</tspan>';
7363 if odd(b) then
7364 begin
7365 if (b = 1) then // subscript
7366 begin
7367 ylevel := dysub;
7368 delta_y := ylevel - prev_ylevel;
7369 if (b = prev_b) then
7370 bstr := bstr + trstr
7371 else
7372 begin
7373 if (abs(delta_y) > 0.1) then
7374 bstr := bstr + format('<tspan font-size="%d" dy="%1.1f">%s',[fontsize2,delta_y,trstr],fsettings)
7375 else
7376 bstr := bstr + format('<tspan font-size="%d">%s',[fontsize2,trstr],fsettings);
7377 end;
7378 end;
7379 if (b = 3) then // superscript
7380 begin
7381 ylevel := -1.0*dysub; // may need adjustment!
7382 delta_y := ylevel - prev_ylevel;
7383 if (b = prev_b) then write(trstr) else
7384 begin
7385 if (abs(delta_y) > 0.1) then
7386 bstr := bstr + format('<tspan font-size="%d" dy="%1.1f">%s',[fontsize2,delta_y,trstr],fsettings)
7387 else
7388 bstr := bstr + format('<tspan font-size="%d">%s',[fontsize2,trstr],fsettings);
7389 end;
7390 end;
7391 end else
7392 begin
7393 ylevel := 0;
7394 delta_y := ylevel - prev_ylevel;
7395 if (b = prev_b) then
7396 bstr := bstr + trstr
7397 else
7398 begin
7399 if (abs(delta_y) > 0.1) then
7400 bstr := bstr + format('<tspan dy="%1.1f">%s',[delta_y,trstr],fsettings)
7401 else
7402 bstr := bstr + format('<tspan font-size="%d">%s',[fontsize1,trstr],fsettings);
7403 end;
7404 end;
7405 prev_b := b;
7406 end; // for
7407 // now, re-establish the original anchor position with left-justified alignment
7408 outchar := purestr[p];
7409 if (pos(outchar,'MW') > 0) then cwf := 0.45;
7410 if (outchar = '1') then cwf := 0.25;
7411 if (pos(outchar,'iIl.:,;!') > 0) then cwf := 0.15;
7412 tmpstr := ' text-anchor="start" ';
7413 writeouts(bstr+'</tspan></text>'); bstr := ''; // finish the <text> tag of the left part of the label
7414 if (odd(attr[p])) then
7415 begin // small font
7416 outX := charX - (fontsize2*cwf);
7417 outY := charY + (fontsize1*0.38); // sic! (fontsize1)
7418 writeout('<text font-size="%d" %s x="%1.1f" y="%1.1f">',[fontsize2,tmpstr,outx,outy]);
7419 end else
7420 begin // normal font
7421 outX := charX - (fontsize1*cwf);
7422 outY := charY + (fontsize1*0.38);
7423 writeout('<text %s x="%1.1f" y="%1.1f">',[tmpstr,outx,outy]);
7424 end;
7425 end;
7426 // now print anything starting from the anchor to the right
7427 prev_b := 255;
7428 ylevel := 0;
7429 bstr := '';
7430 for i := anchorpos to length(purestr) do
7431 begin
7432 prev_ylevel := ylevel;
7433 outchar := purestr[i];
7434 trstr := outchar; // if necessary, do some translations here
7435 b := attr[i];
7436 if (b <> prev_b) and (prev_b <> 255) then
7437 bstr := bstr + '</tspan>';
7438 if odd(b) then
7439 begin
7440 if (b = 1) then // subscript
7441 begin
7442 ylevel := dysub;
7443 delta_y := ylevel - prev_ylevel;
7444 if (b = prev_b) then
7445 bstr := bstr + trstr
7446 else
7447 begin
7448 if (abs(delta_y) > 0.1) then
7449 bstr := bstr + format('<tspan font-size="%d" dy="%1.1f">%s',[fontsize2,delta_y,trstr],fsettings)
7450 else
7451 bstr := bstr + format('<tspan font-size="%d">%s',[fontsize2,trstr],fsettings);
7452 end;
7453 end;
7454 if (b = 3) then // superscript
7455 begin
7456 ylevel := -1.0*dysub; // may need adjustment!
7457 delta_y := ylevel - prev_ylevel;
7458 if (b = prev_b) then
7459 bstr := bstr + trstr
7460 else
7461 begin
7462 if (abs(delta_y) > 0.1) then
7463 bstr := bstr + format('<tspan font-size="%d" dy="%1.1f">%s',[fontsize2,delta_y,trstr],fsettings)
7464 else
7465 bstr := bstr + format('<tspan font-size="%d">%s',[fontsize2,trstr],fsettings);
7466 end;
7467 end;
7468 end else
7469 begin
7470 ylevel := 0;
7471 delta_y := ylevel - prev_ylevel;
7472 if (b = prev_b) then
7473 bstr := bstr + trstr
7474 else
7475 begin
7476 if (abs(delta_y) > 0.1) then
7477 bstr := bstr + format('<tspan dy="%1.1f">%s',[delta_y,outchar],fsettings)
7478 else
7479 bstr := bstr + format('<tspan font-size="%d">%s',[fontsize1,outchar],fsettings);
7480 end;
7481 end;
7482 prev_b := b;
7483 end; // for
7484 writeouts(bstr+'</tspan></text>'); bstr := '';
7485 end;
7486
7487 procedure printPSlabel_small(x:single;y:single;outstr:string;just:char);
7488 var
7489 j : integer;
7490 charX,charY : integer;
7491 outXint,outYint : integer;
7492 instr : string;
7493 strlen : integer;
7494 outchar : char;
7495 begin
7496 charX := round((x+xoffset)*blfactor);
7497 charY := round((y+yoffset)*blfactor);
7498 outXint := charX;
7499 outYint := charY - round(fontsize2*1.5); // was: 20 / 0.8
7500 (*
7501 writeln((outXint),' dot ',(outYint),' dot moveto');
7502 writeln('CFontSub 0.6 0.6 0.6 setrgbcolor');
7503 *)
7504 updatebb(outXint, outYint);
7505 writeout('%d dot %d dot moveto',[outXint,outYint]);
7506 writeouts('CFontSub 0.6 0.6 0.6 setrgbcolor');
7507 if (just = 'L') then
7508 begin
7509 outchar := outstr[1];
7510 (*
7511 writeln('(',outchar,') stringwidth pop');
7512 writeln('2 div neg 0 rmoveto');
7513 *)
7514 writeouts('('+outchar+') stringwidth pop');
7515 writeouts('2 div neg 0 rmoveto');
7516 end;
7517 if (just = 'R') then
7518 begin
7519 outchar := outstr[length(outstr)];
7520 (*
7521 writeln('(',outchar,') stringwidth pop');
7522 writeln('2 div 0 rmoveto');
7523 writeln('CFontSub (',outstr,') stringwidth pop neg 0 rmoveto');
7524 *)
7525 writeouts('('+outchar+') stringwidth pop');
7526 writeouts('2 div 0 rmoveto');
7527 writeouts('CFontSub ('+outstr+') stringwidth pop neg 0 rmoveto');
7528 end;
7529 if (just = 'C') then
7530 begin
7531 outchar := outstr[length(outstr)];
7532 (*
7533 writeln('(',outchar,') stringwidth pop');
7534 writeln('2 div 0 rmoveto');
7535 writeln('CFontSub (',outstr,') stringwidth pop 2 div neg 0 rmoveto');
7536 *)
7537 writeouts('('+outchar+') stringwidth pop');
7538 writeouts('2 div 0 rmoveto');
7539 writeouts('CFontSub ('+outstr+') stringwidth pop 2 div neg 0 rmoveto');
7540 end;
7541 instr := outstr;
7542 strlen := length(instr);
7543 for j := 1 to strlen do
7544 begin
7545 outchar := instr[(j)];
7546 outstr := outchar;
7547 writeouts('('+outstr+') show');
7548 end;
7549 writeouts('0 0 0 setrgbcolor');
7550 end;
7551
7552 procedure printSVGlabel_small(x:single;y:single;outstr:string;just:char);
7553 var
7554 charX,charY : single;
7555 outX,outY : single;
7556 dysub : single;
7557 strwidth : single; // v0.2c
7558 begin
7559 dysub := (fontsize2*0.7);
7560 charX := (x+xoffset)*blfactor*svg_factor;
7561 charY := round((y+yoffset)*blfactor*-svg_factor + svg_yoffset);
7562 if (just = 'L') then
7563 begin
7564 outX := charX - (fontsize1*0.35);
7565 outY := charY + (fontsize1*0.38);
7566 strwidth := length(outstr)*fontsize2*1.1;
7567 chk_svg_max_xy((outX+strwidth),outY);
7568 writeout('<text fill="#999999" font-size="%d" x="%1.1f" y="%1.1f">',[fontsize2,outx,outy]);
7569 end;
7570 if (just = 'R') then
7571 begin
7572 outX := charX + (fontsize1*0.35);
7573 outY := charY + (fontsize1*0.38);
7574 writeout('<text fill="#999999" font-size="%d" text-anchor="end" x="%1.1f" y="%1.1f">',[fontsize2,outx,outy]);
7575 end;
7576 if (just = 'C') then
7577 begin
7578 outX := charX;
7579 outY := charY + (fontsize1*0.38);
7580 strwidth := length(outstr)*0.5*fontsize2*1.1;
7581 chk_svg_max_xy((outX+strwidth),outY);
7582 writeout('<text fill="#999999" font-size="%d" text-anchor="middle" x="%1.1f" y="%1.1f">',[fontsize2,outx,outy]);
7583 end;
7584 writeout('<tspan>%s</tspan>',[outstr]);
7585 writeouts('</text>');
7586 end;
7587
7588 procedure printPSsgroups;
7589 var
7590 i,a : integer;
7591 px,py : single;
7592 begin
7593 if (n_sgroups > 0) then
7594 begin
7595 for i := 1 to n_sgroups do
7596 begin
7597 with sgroup^[i] do
7598 begin
7599 if (sgtype = 'SUP') and (length(sglabel) > 0) then
7600 begin
7601 a := anchor;
7602 px := atom^[a].x;
7603 py := atom^[a].y;
7604 printPSlabel_autosub(px,py,sglabel,justification);
7605 end;
7606 if (sgtype = 'DAT') and (length(sglabel) > 0) then
7607 begin
7608 px := x;
7609 py := y;
7610 printPSlabel_small(px,py,sglabel,'C');
7611 end;
7612 end;
7613 end;
7614 end;
7615 end;
7616
7617 procedure printSVGsgroups;
7618 var
7619 i,a : integer;
7620 px,py : single;
7621 begin
7622 if (n_sgroups > 0) then
7623 begin
7624 for i := 1 to n_sgroups do
7625 begin
7626 with sgroup^[i] do
7627 begin
7628 if (sgtype = 'SUP') and (length(sglabel) > 0) then
7629 begin
7630 a := anchor;
7631 px := atom^[a].x;
7632 py := atom^[a].y;
7633 printSVGlabel_autosub(px,py,sglabel,justification);
7634 end;
7635 if (sgtype = 'DAT') and (length(sglabel) > 0) then
7636 begin
7637 px := x;
7638 py := y;
7639 //printSVGlabel_autosub(px,py,sglabel,justification);
7640 printSVGlabel_small(px,py,sglabel,'C');
7641 end;
7642 end;
7643 end;
7644 end;
7645 end;
7646
7647 procedure printPSaliases;
7648 var
7649 i,a : integer;
7650 px,py : single;
7651 alias : string;
7652 just : char;
7653 begin
7654 if (n_atoms > 0) then
7655 begin
7656 for i := 1 to n_atoms do
7657 begin
7658 alias := atom^[i].alias;
7659 just := 'L';
7660 if (atom^[i].a_just = 1) then just := 'R';
7661 if (atom^[i].a_just = 2) then just := 'C';
7662 if (alias <> '') then
7663 begin
7664 px := atom^[i].x;
7665 py := atom^[i].y;
7666 printPSlabel_autosub(px,py,alias,just);
7667 end;
7668 end;
7669 end;
7670 end;
7671
7672 procedure printSVGaliases;
7673 var
7674 i,a : integer;
7675 px,py : single;
7676 alias : string;
7677 just : char;
7678 begin
7679 if (n_atoms > 0) then
7680 begin
7681 for i := 1 to n_atoms do
7682 begin
7683 alias := atom^[i].alias;
7684 just := 'L';
7685 if (atom^[i].a_just = 1) then just := 'R';
7686 if (atom^[i].a_just = 2) then just := 'C';
7687 if (alias <> '') then
7688 begin
7689 px := atom^[i].x;
7690 py := atom^[i].y;
7691 printSVGlabel_autosub(px,py,alias,just);
7692 end;
7693 end;
7694 end;
7695 end;
7696
7697 procedure write_PS_atomlabels;
7698 begin
7699 printPSchars;
7700 printPSaliases; // v0.2b
7701 if opt_sgroups then printPSsgroups;
7702 end;
7703
7704 procedure write_SVG_atomlabels;
7705 begin
7706 printSVGchars; // example: <text fill="#FF0000" font-size="',fontsize2,'" font-weight="bold" text-anchor="middle" x="214.20763486057" y="214.97172994938">O</text>
7707 printSVGaliases; // v0.2b
7708 if opt_sgroups then printSVGsgroups;
7709 end;
7710
7711 procedure findzorder;
7712 var
7713 i, j, m, n : integer;
7714 az, minaz : double;
7715 begin
7716 for i := 1 to n_atoms do
7717 begin
7718 zorder[i] := 0;
7719 atom^[i].tag := false;
7720 end;
7721 n := 0;
7722 for j := 1 to n_atoms do
7723 begin
7724 minaz := 10000;
7725 for i := 1 to n_atoms do
7726 begin
7727 az := atom^[i].z;
7728 if (az <= minaz) and (atom^[i].tag = false) then
7729 begin
7730 minaz := az;
7731 m := i;
7732 end;
7733 end; // now we have the minimal Z
7734 inc(n);
7735 zorder[n] := m;
7736 atom^[m].tag := true;
7737 end;
7738 end;
7739
7740 procedure printchargedcarbons;
7741 const
7742 cpright = 1;
7743 cpleft = 2;
7744 cpup = 3;
7745 cpdown = 4;
7746 var
7747 i, j : integer;
7748 chg : integer;
7749 rad : integer;
7750 chgstr, outstr : string;
7751 outchar : char;
7752 cpos : integer;
7753 charx, chary : integer;
7754 outXint, outYint : integer;
7755 sg : boolean; // v0.2a
7756 begin
7757 if opt_color then writeln('1 0 0 setrgbcolor');
7758 for i := 1 to n_atoms do
7759 begin
7760 chg := 0;
7761 chgstr := '';
7762 sg := false;
7763 if opt_sgroups then sg := atom^[i].sg; // v0.2a
7764 if (sg = false) and (atom^[i].element = 'C ') and
7765 (atom^[i].hidden = true) and
7766 ((atom^[i].formal_charge <> 0) or (atom^[i].radical_type > 0)) then
7767 begin
7768 chg := atom^[i].formal_charge;
7769 rad := atom^[i].radical_type;
7770 if (abs(chg) > 1) then chgstr := inttostr(abs(chg));
7771 if (chg < 0) then chgstr := chgstr + '_';
7772 if (chg > 0) then chgstr := chgstr + '+';
7773 if (rad = 1) then chgstr := chgstr + ':';
7774 if (rad = 2) then chgstr := chgstr + '.';
7775 if (rad = 3) then chgstr := chgstr + '=';
7776 cpos := findHpos(i);
7777 writeouts('CFontChg');
7778 charX := round((atom^[i].x+xoffset)*blfactor);
7779 charY := round((atom^[i].y+yoffset)*blfactor);
7780 outXint := charX;
7781 outYint := charY - round(fontsize1*0.8); // was: 20
7782 updatebb(outXint, outYint);
7783 outstr := chgstr;
7784 writeout('%d dot %d dot moveto',[outXint,outYint]);
7785 writeouts('CFontChg ('+outstr+') stringwidth pop');
7786 writeouts('2 div neg 0 rmoveto');
7787 case cpos of
7788 cpright : begin
7789 writeouts('('+outstr+') stringwidth pop 1.1 div 0 rmoveto');
7790 end;
7791 cpleft : begin
7792 writeouts('('+outstr+') stringwidth pop 1.1 div neg 0 rmoveto');
7793 end;
7794 cpup : begin
7795 writeout(' 0 %d rmoveto',[round(fontsize1*0.4)]);
7796 end;
7797 cpdown : begin
7798 writeout(' 0 %d neg rmoveto',[round(fontsize1*0.4)]);
7799 end;
7800 end; // case
7801 for j := 1 to length(outstr) do
7802 begin
7803 outchar := outstr[j];
7804 if (pos(outchar,'+_:.=') > 0) then writeouts('CFontChg') else writeouts('CFontSub');
7805 if outchar = '_' then writeouts('Minus') else
7806 if outchar = ':' then writeouts('Rad1') else
7807 if outchar = '.' then writeouts('Rad2') else
7808 if outchar = '=' then writeouts('Rad3') else writeouts('('+outchar+') show');
7809 end;
7810 end;
7811 end;
7812 if opt_color then writeouts('0 0 0 setrgbcolor');
7813 end;
7814
7815 procedure printchargedcarbons_SVG;
7816 const
7817 cpright = 1;
7818 cpleft = 2;
7819 cpup = 3;
7820 cpdown = 4;
7821 var
7822 i, j : integer;
7823 chg : integer;
7824 rad : integer;
7825 chgstr, outstr : string;
7826 outchar : char;
7827 cpos : integer;
7828 charx, chary : single;
7829 outX, outY : single;
7830 bstr : string;
7831 chgfs : single;
7832 begin
7833 chgfs := (fontsize1+fontsize2)/2;
7834 for i := 1 to n_atoms do
7835 begin
7836 chg := 0;
7837 chgstr := '';
7838 if (atom^[i].element = 'C ') and
7839 (atom^[i].hidden = true) and
7840 ((atom^[i].formal_charge <> 0) or (atom^[i].radical_type > 0)) then
7841 begin
7842 chg := atom^[i].formal_charge;
7843 rad := atom^[i].radical_type;
7844 if (abs(chg) > 1) then chgstr := inttostr(abs(chg));
7845 if (chg < 0) then chgstr := chgstr + '_';
7846 if (chg > 0) then chgstr := chgstr + '+';
7847 if (rad = 1) then chgstr := chgstr + ':';
7848 if (rad = 2) then chgstr := chgstr + '.';
7849 if (rad = 3) then chgstr := chgstr + '=';
7850 cpos := findHpos(i);
7851 charX := (atom^[i].x+xoffset)*blfactor*svg_factor;
7852 charY := (atom^[i].y+yoffset)*blfactor*-svg_factor + svg_yoffset;
7853 outX := charX;
7854 outY := charY + fontsize1*0.2; // was: 20
7855 outstr := chgstr;
7856 case cpos of
7857 cpright : begin
7858 bstr := '';
7859 writeout('<text style="font-size: %1.1fpx" x="%1.1f" y="%1.1f">',[chgfs,(outx+3),outy]);
7860 for j := 1 to length(outstr) do
7861 begin
7862 outchar := outstr[j];
7863 if (outchar = '_') then
7864 bstr := bstr + format('<tspan dy="-5">%s</tspan>',[outchar],fsettings)
7865 else
7866 if (outchar = '.') then
7867 bstr := bstr + '<tspan dy="0">•</tspan>' else
7868 if (outchar = '=') then
7869 bstr := bstr + '<tspan dy="0">^^</tspan>' else
7870 if (outchar = ':') then
7871 bstr := bstr + '<tspan font-weight="bold" dy="0">:</tspan>' else
7872 bstr := bstr + format('<tspan dy="0">%s</tspan>',[outchar],fsettings);
7873 end;
7874 writeouts(bstr);
7875 bstr := '';
7876 end;
7877 cpleft : begin
7878 bstr := '';
7879 writeout('<text style="font-size: %1.1fpx" text-anchor="end" x="%1.1f" y="%1.1f">',[chgfs,(outx-3),outy]);
7880 for j := 1 to length(outstr) do
7881 begin
7882 outchar := outstr[j];
7883 if (outchar = '_') then
7884 bstr := bstr + format('<tspan dy="-5">%s</tspan>',[outchar],fsettings)
7885 else
7886 if (outchar = '.') then
7887 bstr := bstr + '<tspan dy="0">•</tspan>' else
7888 if (outchar = '=') then
7889 bstr := bstr + '<tspan dy="0">^^</tspan>' else
7890 if (outchar = ':') then
7891 bstr := bstr + '<tspan font-weight="bold" dy="0">:</tspan>' else
7892 bstr := bstr + format('<tspan dy="0">%s</tspan>',[outchar],fsettings);
7893 end;
7894 writeouts(bstr);
7895 bstr := '';
7896 end;
7897 cpup : begin
7898 bstr := '';
7899 writeout('<text style="font-size: %1.1fpx" text-anchor="middle" x="%1.1f" y="%1.1f">',[chgfs,outx,(outy-5)]);
7900 for j := 1 to length(outstr) do
7901 begin
7902 outchar := outstr[j];
7903 if (outchar = '_') then
7904 bstr := bstr + format('<tspan dy="-5">%s</tspan>',[outchar],fsettings)
7905 else
7906 if (outchar = '.') then
7907 bstr := bstr + '<tspan dy="0">•</tspan>' else
7908 if (outchar = '=') then
7909 bstr := bstr + '<tspan dy="0">^^</tspan>' else
7910 if (outchar = ':') then
7911 bstr := bstr + '<tspan font-weight="bold" dy="0">:</tspan>' else
7912 bstr := bstr + format('<tspan dy="0">%s</tspan>',[outchar],fsettings);
7913 end;
7914 writeouts(bstr);
7915 bstr := '';
7916 end;
7917 cpdown : begin
7918 bstr := '';
7919 writeout('<text style="font-size: %1.1fpx" text-anchor="middle" x="%1.1f" y="%1.1f">',[chgfs,outx,(outy+5)]);
7920 for j := 1 to length(outstr) do
7921 begin
7922 outchar := outstr[j];
7923 if (outchar = '_') then
7924 bstr := bstr + format('<tspan dy="-5">%s</tspan>',[outchar],fsettings)
7925 else
7926 if (outchar = '.') then
7927 bstr := bstr + '<tspan dy="0">•</tspan>' else
7928 if (outchar = '=') then
7929 bstr := bstr + '<tspan dy="0">^^</tspan>' else
7930 if (outchar = ':') then
7931 bstr := bstr + '<tspan font-weight="bold" dy="0">:</tspan>' else
7932 bstr := bstr + format('<tspan dy="0">%s</tspan>',[outchar],fsettings);
7933 end;
7934 writeouts(bstr);
7935 bstr := '';
7936 end;
7937 end; // case
7938 writeouts('</text>');
7939 end;
7940 end; // for
7941 end;
7942
7943 procedure write_PS_bonds_and_boxes;
7944 var
7945 i, j, a, b : integer;
7946 nb : neighbor_rec;
7947 nnb : integer;
7948 el : str2;
7949 anchor, chgstr : string;
7950 bbx, bby : integer;
7951 tmpstr : string;
7952 sga, sgb : boolean; // v0.2a
7953 begin
7954 chk_hidden;
7955 if (n_bonds > 0) then
7956 begin
7957 for i := 1 to n_bonds do bond^[i].drawn := false;
7958 end;
7959 for i := 1 to n_atoms do
7960 begin
7961 a := zorder[i];
7962 if (opt_stripH = true) then // v0.1f
7963 begin
7964 nb := get_neighbors(a);
7965 nnb := atom^[a].neighbor_count;
7966 end else
7967 begin
7968 nb := get_allneighbors(a);
7969 nnb := atom^[a].neighbor_count + atom^[a].Hexp;
7970 end;
7971 el := atom^[a].element;
7972 sga := false;
7973 if opt_sgroups then sga := atom^[a].sg;
7974 anchor := el;
7975 if anchor[2] = ' ' then delete(anchor,2,1) else // v0.1f
7976 begin
7977 tmpstr := anchor;
7978 tmpstr := lowercase(tmpstr);
7979 tmpstr[1] := upcase(tmpstr[1]);
7980 anchor := copy(tmpstr,1,2);
7981 end;
7982 if (atom^[a].formal_charge) <> 0 then chgstr := '+' else chgstr := '';
7983 if (nnb > 0) then
7984 begin
7985 for j := 1 to nnb do
7986 begin
7987 b := get_bond(a,nb[j]);
7988 sgb := false;
7989 if opt_sgroups then sgb := bond^[b].sg;
7990 if (bond^[b].drawn = false) and (sgb = false) then
7991 begin
7992 print_PS_bond(b);
7993 bond^[b].drawn := true;
7994 end;
7995 end;
7996 end;
7997 if (atom^[a].hidden = false) and ((atom^[a].sg = false) or (opt_sgroups = false)) or (atom^[a].alias <> '') then // v0.2b
7998 begin
7999 bbX := round((atom^[a].x+xoffset)*blfactor);
8000 bbY := round((atom^[a].y+yoffset)*blfactor);
8001 if (atom^[a].alias <> '') then
8002 begin
8003 anchor := 'M'; chgstr := '';
8004 end;
8005 printBB(bbX, bbY, anchor, chgstr);
8006 end;
8007 if opt_sgroups and (n_sgroups > 0) then
8008 begin
8009 for j := 1 to n_sgroups do
8010 begin
8011 if (sgroup^[j].anchor = a) then
8012 begin
8013 bbX := round((atom^[a].x+xoffset)*blfactor);
8014 bbY := round((atom^[a].y+yoffset)*blfactor);
8015 printBB(bbX, bbY, anchor, chgstr);
8016 end;
8017 end;
8018 end;
8019 end;
8020 printchargedcarbons;
8021 end;
8022
8023 procedure write_SVG_bonds_and_boxes;
8024 var
8025 i, j, a, b : integer;
8026 nb : neighbor_rec;
8027 nnb : integer;
8028 el : str2;
8029 anchor, chgstr : string;
8030 bbx, bby : single;
8031 tmpstr : string;
8032 sga, sgb : boolean;
8033 begin
8034 chk_hidden;
8035 if (n_bonds > 0) then
8036 begin
8037 for i := 1 to n_bonds do bond^[i].drawn := false;
8038 end;
8039 for i := 1 to n_atoms do
8040 begin
8041 a := zorder[i];
8042 if (opt_stripH = true) then // v0.1f
8043 begin
8044 nb := get_neighbors(a);
8045 nnb := atom^[a].neighbor_count;
8046 end else
8047 begin
8048 nb := get_allneighbors(a);
8049 nnb := atom^[a].neighbor_count + atom^[a].Hexp;
8050 end;
8051 el := atom^[a].element;
8052 sga := false;
8053 if opt_sgroups then sga := atom^[a].sg;
8054 anchor := el;
8055 if anchor[2] = ' ' then delete(anchor,2,1) else // v0.1f
8056 begin
8057 tmpstr := anchor;
8058 tmpstr := lowercase(tmpstr);
8059 tmpstr[1] := upcase(tmpstr[1]);
8060 anchor := copy(tmpstr,1,2);
8061 end;
8062 if (atom^[a].formal_charge) <> 0 then chgstr := '+' else chgstr := '';
8063 if (nnb > 0) then
8064 begin
8065 for j := 1 to nnb do
8066 begin
8067 b := get_bond(a,nb[j]);
8068 sgb := false;
8069 if opt_sgroups then sgb := bond^[b].sg;
8070 if (bond^[b].drawn = false) and (sgb = false) then
8071 begin
8072 print_SVG_bond(b);
8073 bond^[b].drawn := true;
8074 end;
8075 end;
8076 end;
8077 if (atom^[a].hidden = false) and ((atom^[a].sg = false) or (opt_sgroups = false)) then
8078 begin
8079 bbX := ((atom^[a].x+xoffset)*blfactor*svg_factor);
8080 bbY := ((atom^[a].y+yoffset)*blfactor*-svg_factor + svg_yoffset);
8081 printSVGBB(bbX, bbY, anchor, chgstr);
8082 end;
8083 if opt_sgroups and (n_sgroups > 0) then
8084 begin
8085 for j := 1 to n_sgroups do
8086 begin
8087 if (sgroup^[j].anchor = a) then
8088 begin
8089 bbX := ((atom^[a].x+xoffset)*blfactor*svg_factor);
8090 bbY := ((atom^[a].y+yoffset)*blfactor*-svg_factor + svg_yoffset);
8091 printSVGBB(bbX, bbY, anchor, chgstr);
8092 end;
8093 end;
8094 end;
8095 end;
8096 printchargedcarbons_SVG;
8097 end;
8098
8099 procedure write_SVG_bonds_and_boxes_compact;
8100 var
8101 i, j, a, b : integer;
8102 nb : neighbor_rec;
8103 nnb : integer;
8104 el : str2;
8105 anchor, chgstr : string;
8106 bbx, bby : single;
8107 tmpstr : string;
8108 sga, sgb : boolean;
8109 n_drawn : integer;
8110 begin
8111 {$IFDEF debug}
8112 debugoutput('entering compact mode');
8113 {$ENDIF}
8114 chk_hidden;
8115 if (n_bonds > 0) then
8116 begin
8117 for i := 1 to n_bonds do
8118 begin
8119 bond^[i].drawn := false;
8120 // draw all bonds with non-path-compatible bond type (wedge etc.)
8121 print_SVG_bond_special(i);
8122 end;
8123 end;
8124 n_drawn := 0;
8125 // write <path> opening tag
8126 writeout('<path stroke="#000000" stroke-width="%1.1f" d="',[linewidth]);
8127 for i := 1 to n_atoms do // first round: bonds only
8128 begin
8129 a := zorder[i];
8130 if (opt_stripH = true) then // v0.1f
8131 begin
8132 nb := get_neighbors(a);
8133 nnb := atom^[a].neighbor_count;
8134 end else
8135 begin
8136 nb := get_allneighbors(a);
8137 nnb := atom^[a].neighbor_count + atom^[a].Hexp;
8138 end;
8139 el := atom^[a].element;
8140 sga := false;
8141 if opt_sgroups then sga := atom^[a].sg;
8142 anchor := el;
8143 if anchor[2] = ' ' then delete(anchor,2,1) else // v0.1f
8144 begin
8145 tmpstr := anchor;
8146 tmpstr := lowercase(tmpstr);
8147 tmpstr[1] := upcase(tmpstr[1]);
8148 anchor := copy(tmpstr,1,2);
8149 end;
8150 if (atom^[a].formal_charge) <> 0 then chgstr := '+' else chgstr := '';
8151 if (nnb > 0) then
8152 begin
8153 for j := 1 to nnb do
8154 begin
8155 b := get_bond(a,nb[j]);
8156 sgb := false;
8157 if opt_sgroups then sgb := bond^[b].sg;
8158 if (bond^[b].drawn = false) and (sgb = false) then
8159 begin
8160 print_SVG_bond(b);
8161 bond^[b].drawn := true;
8162 inc(n_drawn);
8163 if (n_drawn > 3) then
8164 begin
8165 n_drawn := 0;
8166 end;
8167 end;
8168 end;
8169 end;
8170 if (atom^[a].hidden = false) and ((atom^[a].sg = false) or (opt_sgroups = false)) then
8171 begin
8172 bbX := ((atom^[a].x+xoffset)*blfactor*svg_factor);
8173 bbY := ((atom^[a].y+yoffset)*blfactor*-svg_factor + svg_yoffset);
8174 //printSVGBB(bbX, bbY, anchor, chgstr);
8175 end;
8176 if opt_sgroups and (n_sgroups > 0) then
8177 begin
8178 for j := 1 to n_sgroups do
8179 begin
8180 if (sgroup^[j].anchor = a) then
8181 begin
8182 bbX := ((atom^[a].x+xoffset)*blfactor*svg_factor);
8183 bbY := ((atom^[a].y+yoffset)*blfactor*-svg_factor + svg_yoffset);
8184 //printSVGBB(bbX, bbY, anchor, chgstr);
8185 end;
8186 end;
8187 end;
8188 end; // end first round
8189 // write <path> closing tag
8190 writeouts('" />');
8191 for i := 1 to n_atoms do // sexcond round: atom boxes
8192 begin
8193 a := zorder[i];
8194 if (opt_stripH = true) then // v0.1f
8195 begin
8196 nb := get_neighbors(a);
8197 nnb := atom^[a].neighbor_count;
8198 end else
8199 begin
8200 nb := get_allneighbors(a);
8201 nnb := atom^[a].neighbor_count + atom^[a].Hexp;
8202 end;
8203 el := atom^[a].element;
8204 sga := false;
8205 if opt_sgroups then sga := atom^[a].sg;
8206 anchor := el;
8207 if anchor[2] = ' ' then delete(anchor,2,1) else // v0.1f
8208 begin
8209 tmpstr := anchor;
8210 tmpstr := lowercase(tmpstr);
8211 tmpstr[1] := upcase(tmpstr[1]);
8212 anchor := copy(tmpstr,1,2);
8213 end;
8214 if (atom^[a].formal_charge) <> 0 then chgstr := '+' else chgstr := '';
8215 if (nnb > 0) then
8216 begin
8217 for j := 1 to nnb do
8218 begin
8219 b := get_bond(a,nb[j]);
8220 sgb := false;
8221 if opt_sgroups then sgb := bond^[b].sg;
8222 if (bond^[b].drawn = false) and (sgb = false) then
8223 begin
8224 //print_SVG_bond(b);
8225 bond^[b].drawn := true;
8226 end;
8227 end;
8228 end;
8229 if (atom^[a].hidden = false) and ((atom^[a].sg = false) or (opt_sgroups = false)) then
8230 begin
8231 bbX := round((atom^[a].x+xoffset)*blfactor*svg_factor);
8232 bbY := round((atom^[a].y+yoffset)*blfactor*-svg_factor + svg_yoffset);
8233 printSVGBB(bbX, bbY, anchor, chgstr);
8234 end;
8235 if opt_sgroups and (n_sgroups > 0) then
8236 begin
8237 for j := 1 to n_sgroups do
8238 begin
8239 if (sgroup^[j].anchor = a) then
8240 begin
8241 bbX := round((atom^[a].x+xoffset)*blfactor*svg_factor);
8242 bbY := round((atom^[a].y+yoffset)*blfactor*-svg_factor + svg_yoffset);
8243 printSVGBB(bbX, bbY, anchor, chgstr);
8244 end;
8245 end;
8246 end;
8247 end; // end second round
8248 printchargedcarbons_SVG;
8249 end;
8250
8251 procedure write_PS_brackets; // v0.1f
8252 var
8253 i : integer;
8254 x1, y1, x2, y2, x3, y3, x4, y4 : single;
8255 xmax, ymin : single;
8256 brtype : integer;
8257 brlabel : string;
8258 begin
8259 if (bracket = nil) or (n_brackets < 1) then exit;
8260 for i := 1 to n_brackets do
8261 begin
8262 brtype := bracket^[i].brtype;
8263 brlabel := bracket^[i].brlabel;
8264 x1 := bracket^[i].x1; y1 := bracket^[i].y1;
8265 x2 := bracket^[i].x2; y2 := bracket^[i].y2;
8266 x3 := bracket^[i].x3; y3 := bracket^[i].y3;
8267 x4 := bracket^[i].x4; y4 := bracket^[i].y4;
8268 xmax := -9999;
8269 if x1 > xmax then xmax := x1; if x2 > xmax then xmax := x2;
8270 if x3 > xmax then xmax := x3; if x4 > xmax then xmax := x4;
8271 ymin := 9999;
8272 if y1 < ymin then ymin := y1; if y2 < ymin then ymin := y2;
8273 if y3 < ymin then ymin := y3; if y4 < ymin then ymin := y4;
8274 print_PS_squarebracket(x1,y1,x2,y2,x3,y3,x4,y4,brlabel);
8275 end;
8276 writeouts('stroke');
8277 end;
8278
8279 procedure write_SVG_brackets; // v0.1f
8280 var
8281 i : integer;
8282 x1, y1, x2, y2, x3, y3, x4, y4 : single;
8283 xmax, ymin : single;
8284 brtype : integer;
8285 brlabel : string;
8286 begin
8287 if (bracket = nil) or (n_brackets < 1) then exit;
8288 for i := 1 to n_brackets do
8289 begin
8290 brtype := bracket^[i].brtype;
8291 brlabel := bracket^[i].brlabel;
8292 x1 := bracket^[i].x1; y1 := bracket^[i].y1;
8293 x2 := bracket^[i].x2; y2 := bracket^[i].y2;
8294 x3 := bracket^[i].x3; y3 := bracket^[i].y3;
8295 x4 := bracket^[i].x4; y4 := bracket^[i].y4;
8296 xmax := -9999;
8297 if x1 > xmax then xmax := x1; if x2 > xmax then xmax := x2;
8298 if x3 > xmax then xmax := x3; if x4 > xmax then xmax := x4;
8299 ymin := 9999;
8300 if y1 < ymin then ymin := y1; if y2 < ymin then ymin := y2;
8301 if y3 < ymin then ymin := y3; if y4 < ymin then ymin := y4;
8302 print_SVG_squarebracket(x1,y1,x2,y2,x3,y3,x4,y4,brlabel);
8303 end;
8304 end;
8305
8306 procedure write_XY_comment;
8307 var
8308 i : integer;
8309 molX, molY : integer;
8310 //molZ : integer;
8311 auxstr : string;
8312 el : str2;
8313 tmpstr : string;
8314 visible : boolean;
8315 begin
8316 if n_atoms < 1 then exit;
8317 writeln('% appendix: actual & original XY coordinates ("dots", Angstroms)');
8318 for i := 1 to n_atoms do
8319 begin
8320 el := atom^[i].element;
8321 visible := false;
8322 if (not ((el = 'H ') and opt_stripH)) or (atom^[i].hidden = false) then visible := true;
8323 molX := round((atom^[i].x+xoffset)*blfactor);
8324 molY := round((atom^[i].y+yoffset)*blfactor);
8325 //molZ := round((atom^[i].z)*blfactor);
8326 write('% atom ');
8327 auxstr := '';
8328 str(i,auxstr);
8329 while (length(auxstr)<3) do auxstr := ' ' + auxstr;
8330 write(auxstr,': ');
8331 str(molX,auxstr);
8332 while (length(auxstr)<4) do auxstr := ' ' + auxstr;
8333 write(auxstr,' ');
8334 str(molY,auxstr);
8335 while (length(auxstr)<4) do auxstr := ' ' + auxstr;
8336 write(auxstr,' ');
8337 if (length(el)=1) then el := el + ' ';
8338 tmpstr := el;
8339 tmpstr := lowercase(el);
8340 tmpstr[1] := upcase(tmpstr[1]);
8341 el := tmpstr;
8342 write(el);
8343 if visible then write(' ') else write('/ ');
8344 str(atom^[i].x_orig:1:4,auxstr);
8345 while (length(auxstr)<8) do auxstr := ' ' + auxstr;
8346 write(auxstr,' ');
8347 str(atom^[i].y_orig:1:4,auxstr);
8348 while (length(auxstr)<8) do auxstr := ' ' + auxstr;
8349 write(auxstr,' ');
8350 writeln;
8351 end;
8352 end;
8353
8354
8355 procedure write_PS;
8356 var
8357 i : integer;
8358 ha_el : str2;
8359 begin
8360 if (n_heavyatoms = 1) then
8361 begin
8362 ha_el := ' ';
8363 for i := 1 to n_atoms do
8364 begin
8365 if is_heavyatom(i) then ha_el := atom^[i].element;
8366 end;
8367 if (ha_el = 'C ') then opt_stripH := false; // methane
8368 end;
8369 if (n_heavyatoms = 0) then opt_stripH := false;
8370 findzorder;
8371 write_PS_bonds_and_boxes;
8372 write_PS_atomlabels;
8373 if opt_color then writeouts('0 0 0 setrgbcolor');
8374 if n_brackets > 0 then write_PS_brackets;
8375 if opt_showmolname and (molname <> '') then
8376 begin
8377 //writeout('100 dot %d dot moveto (%s) show',[round(maxY*blfactor),molname]);
8378 writeout('CFont 0 fs1 %d dot %d dot moveto (%s) show', [bboxleft-round(bboxmargin*fontsize1),bboxtop+blfactor,molname]);
8379 updatebb(bboxleft, bboxtop+blfactor);
8380 end;
8381 if not rxn_mode then
8382 begin
8383 //here comes the entire PS output when not in reaction mode
8384 write_PS_init; // new position, including the BB definition
8385 writeln(outbuffer.text);
8386 outbuffer.clear;
8387 if not opt_eps then writeln('showpage');
8388 writeln;
8389 {$IFDEF csearch_extensions}
8390 if progmode = pmMol2PS then write_XY_comment;
8391 {$ENDIF}
8392 {$IFDEF debug}
8393 debugoutput('number of brackets: '+inttostr(n_brackets)+' number of Sgroups: '+inttostr(n_sgroups));
8394 {$ENDIF}
8395 writeln('% ----------------------end of image------------------------');
8396 end;
8397 end;
8398
get_yminnull8399 function get_ymin:single;
8400 var
8401 i : integer;
8402 r, ytmp : single;
8403 begin
8404 r := 10000;
8405 if (n_atoms > 0) then
8406 begin
8407 for i := 1 to n_atoms do
8408 begin
8409 ytmp := (atom^[i].y+yoffset)*blfactor*-svg_factor + svg_yoffset;
8410 if ytmp < r then r := ytmp;
8411 end;
8412 end;
8413 get_ymin := r;
8414 end;
8415
8416 procedure write_SVG_dimensions;
8417 begin
8418 writeln('<!-- found XY values for adjusting width, height and viewbox: -->');
8419 writeln('<!-- max_X: ',round(svg_max_x)+20,' -->'); // add a little safety margin of 20
8420 writeln('<!-- max_Y: ',round(svg_max_y)+25,' -->'); // add a little safety margin of 20
8421 writeln('<!-- min_Y: ',round(svg_min_y)-25,' -->'); // add a little safety margin of 20
8422 writeln('<!-- yshift: ',max_ytrans,' -->');
8423 end;
8424
8425
8426 procedure write_SVG;
8427 var
8428 i : integer;
8429 ha_el : str2;
8430 ymin, outY : single;
8431 //ytrans : integer; // moved to the global variables, v0.2c
8432 //ymargin : integer;
8433 is_flat : boolean;
8434 begin
8435 ytrans := 0; // v0.2c
8436 if opt_showmolname then ymargin := 100 else ymargin := 30;
8437 if (n_heavyatoms = 1) then
8438 begin
8439 ha_el := ' ';
8440 for i := 1 to n_atoms do
8441 begin
8442 if is_heavyatom(i) then ha_el := atom^[i].element;
8443 end;
8444 if (ha_el = 'C ') then opt_stripH := false; // methane
8445 end;
8446 if (n_heavyatoms = 0) then opt_stripH := false;
8447 findzorder;
8448 ymin := get_ymin;
8449 if (ymin < 0) then
8450 begin
8451 ytrans := round(abs(ymin)+ymargin);
8452 writeout('<g transform="translate(0,%d)">',[ytrans]);
8453 end else
8454 begin
8455 if (rxn_mode = false) and (ymin > ymargin) then
8456 begin
8457 ytrans := -round(ymin-ymargin);
8458 writeout('<g transform="translate(0,%d)">',[ytrans]);
8459 end else writeouts('<g>');
8460 end;
8461 if (abs(ytrans) > abs(max_ytrans)) then max_ytrans := ytrans; // v0.2c
8462 // check if we can use "compact" mode for really flat molecules; v0.2c
8463 if (n_atoms > 0) then
8464 begin
8465 is_flat := true;
8466 for i := 1 to n_atoms do
8467 begin
8468 if (atom^[i].z <> 0) then is_flat := false;
8469 end;
8470 if (n_bonds > 0) then
8471 begin
8472 for i := 1 to n_bonds do
8473 begin
8474 // we have to worry only about "down" bonds, as their atom labels could be crossed
8475 // by a bond at a higher X level
8476 if (bond^[i].stereo = bstereo_down) then is_flat := false;
8477 end;
8478 end;
8479 if is_flat then svg_mode := 2;
8480 end;
8481 {$IFDEF debug}
8482 debugoutput('svg mode = '+inttostr(svg_mode));
8483 {$ENDIF}
8484 if (svg_mode = 1) then write_SVG_bonds_and_boxes;
8485 if (svg_mode = 2) then write_SVG_bonds_and_boxes_compact;
8486 svg_mode := 1; // rest mode for brackets
8487 write_SVG_atomlabels;
8488 if n_brackets > 0 then write_SVG_brackets;
8489 writeouts('</g>');
8490 if not rxn_mode then
8491 begin
8492 writeouts('</g>');
8493 writeouts('</svg>');
8494 // here comes the SVG header with the corrected dimensions
8495 write_SVG_init;
8496 // here comes the content of the output buffer
8497 writeln(outbuffer.text);
8498 outbuffer.clear;
8499 // here comes the list of original dimensions (for post-processing)
8500 write_SVG_dimensions;
8501 end;
8502 end;
8503
8504 procedure loadrgbtable(rgbfilename:string);
8505 var
8506 i, pp : integer;
8507 rline : string;
8508 elstr : string;
8509 rval, gval, bval : integer;
8510 begin
8511 assign(rgbfile,rgbfilename);
8512 reset(rgbfile);
8513 i := 0;
8514 while not eof(rgbfile) do
8515 begin
8516 readln(rgbfile,rline);
8517 trimleft(rline); trimright(rline);
8518 pp := pos('#',rline);
8519 if (pp > 0) then rline := copy(rline,1,(pp-1));
8520 if (rline <> '') and (i < max_rgbentries) then
8521 begin
8522 inc(i);
8523 elstr := '';
8524 while (length(rline)>0) and (rline[1] <> ' ') and (rline[1] <> TAB) do
8525 begin
8526 elstr := elstr + rline[1];
8527 delete(rline,1,1);
8528 end;
8529 if (length(elstr) > 2) then elstr := copy(elstr,1,2);
8530 rgbtable[i].element := elstr;
8531 rval := left_int(rline);
8532 gval := left_int(rline);
8533 bval := left_int(rline);
8534 if (rval < 0) or (gval < 0) or (bval < 0) or
8535 (rval > 255) or (gval > 255) or (bval > 255) then
8536 begin
8537 rval := 0; gval := 0; bval := 0;
8538 end;
8539 rgbtable[i].r := rval;
8540 rgbtable[i].g := gval;
8541 rgbtable[i].b := bval;
8542 end;
8543 end;
8544 close(rgbfile);
8545 end;
8546
8547
8548 procedure chk_sgbonds;
8549 var
8550 i : integer;
8551 a1, a2 : integer;
8552 begin
8553 if (n_bonds > 0) then
8554 begin
8555 for i := 1 to n_bonds do
8556 begin
8557 a1 := bond^[i].a1;
8558 a2 := bond^[i].a2;
8559 if (atom^[a1].sg = true) and (atom^[a2].sg = true) then bond^[i].sg := true else bond^[i].sg := false;
8560 end;
8561 end;
8562 end;
8563
8564
8565 procedure process_mol;
8566 begin
8567 chk_ringbonds;
8568 if ringsearch_mode = rs_ssr then remove_redundant_rings;
8569 if n_rings = max_rings then
8570 begin
8571 ringsearch_mode := rs_ssr;
8572 clear_rings;
8573 max_vringsize := 10;
8574 chk_ringbonds;
8575 remove_redundant_rings;
8576 end;
8577 update_ringcount;
8578 update_atypes;
8579 update_Htotal;
8580 chk_arom;
8581 if (ringsearch_mode = rs_ssr) then
8582 begin
8583 repeat
8584 prev_n_ar := count_aromatic_rings;
8585 chk_arom;
8586 n_ar := count_aromatic_rings;
8587 until ((prev_n_ar - n_ar) = 0);
8588 end;
8589 if not rxn_mode then adjust_mol; // v0.2
8590 refine_bonds;
8591 if opt_sgroups then chk_sgbonds; // v0.2a
8592 if (progmode = pmMol2PS) then write_PS;
8593 if (progmode = pmMol2SVG) then write_SVG;
8594 zap_molecule;
8595 molbufindex := 0;
8596 end;
8597
8598
8599 procedure get_xminmax(var xmin,xmax:single);
8600 var
8601 i : integer;
8602 tmin, tmax, xcurr : single;
8603 al : string;
8604 lstr, rstr : string;
8605 just : char;
8606 ap : integer;
8607 lw,rw : double;
8608 begin
8609 tmin := 1000;
8610 tmax := -1000;
8611 if n_atoms > 0 then
8612 begin
8613 for i := 1 to n_atoms do
8614 begin
8615 if atom^[i].x < tmin then tmin := atom^[i].x;
8616 if atom^[i].x > tmax then tmax := atom^[i].x;
8617 // check also for left parts of alias labels (the right parts
8618 // will be checked elsewhere) v0.4
8619 if atom^[i].alias <> '' then
8620 begin
8621 xcurr := atom^[i].x;
8622 al := atom^[i].alias;
8623 case atom^[i].a_just of
8624 0 : just := 'L';
8625 1 : just := 'R';
8626 2 : just := 'C';
8627 end;
8628 while (pos('\S',al)>0) do delete(al,pos('\S',al),2);
8629 while (pos('\s',al)>0) do delete(al,pos('\s',al),2);
8630 while (pos('\n',al)>0) do delete(al,pos('\n',al),2);
8631 ap := pos('^',al);
8632 if (ap = 0) then
8633 begin
8634 if (just = 'L') then ap := 1;
8635 if (just = 'R') then ap := length(al)-1;
8636 if (just = 'C') then ap := length(al) div 2;
8637 end;
8638 if (ap > 1) then
8639 begin
8640 lstr := copy(al,1,(ap-1));
8641 lw := 0.375*get_stringwidth(fontsize1,lstr);
8642 if (xcurr - lw) < tmin then tmin := (xcurr - lw);
8643 end;
8644 if (ap < (length(al)-1)) then
8645 begin
8646 rstr := copy(al,(ap+1),(length(al)-ap));
8647 rw := 0.375*get_stringwidth(fontsize1,rstr);
8648 if (xcurr + rw) > tmax then tmax := (xcurr + rw);
8649 end;
8650 end;
8651 end;
8652 end;
8653 xmin := tmin;
8654 xmax := tmax;
8655 end;
8656
8657
8658 procedure shift_x(xshift:single);
8659 var
8660 i : integer;
8661 begin
8662 if n_atoms > 0 then
8663 begin
8664 for i := 1 to n_atoms do atom^[i].x := atom^[i].x + xshift;
8665 end;
8666 end;
8667
8668 begin // main routine
8669 //prevent unwanted re-setting of DefaultFormatsettings
8670 //Application.UpdateFormatSettings := False;
8671 //Now it is safe to set this for the lifetime of this program
8672 //DefaultFormatSetttings.DecimalSeparator := '.';
8673 progname := extractfilename(paramstr(0));
8674 progmode := pmMol2PS;
8675 if (pos('MOL2PS',upcase(progname))>0) or (pos('MOL2EPS',upcase(progname))>0) then
8676 begin
8677 progmode := pmMol2PS;
8678 if (pos('MOL2PS',upcase(progname))>0) then opt_eps := false else opt_eps := true;
8679 end else
8680 begin
8681 if pos('MOL2SVG',upcase(progname))>0 then progmode := pmMol2SVG else
8682 begin
8683 writeln('THOU SHALLST NOT RENAME ME!');
8684 halt(9);
8685 end;
8686 end;
8687 if (paramcount = 0) then
8688 begin
8689 show_usage;
8690 halt(1);
8691 end;
8692 init_globals;
8693 outbuffer := tstringlist.create; // v0.4
8694 parse_args;
8695 if ringsearch_mode = rs_sar then max_vringsize := max_ringsize else
8696 max_vringsize := 10;
8697 left_trim(molfilename);
8698 if ((molfilename = '') and (not opt_stdin)) then
8699 begin
8700 show_usage;
8701 halt(2);
8702 end;
8703 if ((not fileexists(molfilename)) and (not opt_stdin)) then
8704 begin
8705 if ((length(molfilename) > 1) and (molfilename[1] = '-')) then
8706 begin
8707 show_usage;
8708 end else writeln('file ',molfilename,' not found!');
8709 halt(2);
8710 end;
8711 if opt_color then
8712 begin
8713 if (fileexists(rgbfilename)) then loadrgbtable(rgbfilename)
8714 else opt_color := false;
8715 end;
8716 mol_count := 0;
8717 rxn_count := 0;
8718 li := 1;
8719
8720 if (rxn_mode = false) then
8721 begin
8722 repeat
8723 begin
8724 ringsearch_mode := opt_rs;
8725 if ringsearch_mode = rs_sar then max_vringsize := max_ringsize else
8726 max_vringsize := 10;
8727 readinputfile(molfilename);
8728 li := 1;
8729 filetype := get_filetype(molfilename);
8730 if (filetype <> 'unknown') then
8731 begin
8732 mol_OK := true;
8733 if filetype = 'alchemy' then read_molfile(molfilename);
8734 if filetype = 'sybyl' then read_mol2file(molfilename);
8735 if filetype = 'mdl' then read_MDLmolfile(molfilename);
8736 inc(mol_count);
8737 count_neighbors;
8738 if (not mol_OK) or (n_atoms < 1) then
8739 if (progmode = pmMol2PS) then
8740 writeout('%% %d:no valid structure found',[mol_count])
8741 else
8742 writeout('<!-- %d:no valid structure found -->',[mol_count])
8743 else
8744 process_mol;
8745 end
8746 else
8747 if (progmode = pmMol2PS) then
8748 writeout('%% %d:unknown file format',[mol_count])
8749 else
8750 writeout('<!-- %d:unknown file format -->',[mol_count]);
8751 outbuffer.clear;
8752 end;
8753 until (mol_in_queue = false);
8754 end else // reaction mode starts here
8755 begin
8756 open_rfile(molfilename);
8757 filetype := 'mdl';
8758 opt_showmolname := false;
8759 while not eof(rfile) do
8760 begin
8761 n_reactants := 0;
8762 n_products := 0;
8763 if read_rxnheader = true then
8764 begin
8765 inc(rxn_count);
8766 x_shift := 0;
8767 xoffset := 1.5; // may require some adjustment
8768 yoffset := 4.0; // may require some adjustment
8769 maxY := 2 * yoffset;
8770 if (n_reactants > 0) then
8771 begin
8772 for i := 1 to n_reactants do
8773 begin
8774 zap_molecule;
8775 read_rxnmol;
8776 inc(mol_count);
8777 count_neighbors;
8778 ringsearch_mode := opt_rs;
8779 if ringsearch_mode = rs_sar then max_vringsize := max_ringsize else
8780 max_vringsize := 10;
8781 if opt_autoscale then scale_mol;
8782 center_mol;
8783 get_xminmax(x_min,x_max);
8784 if (i > 0) then shift_x((x_shift - x_min + x_padding)); // v0.4b (was > 1)
8785 get_xminmax(x_dummy,x_shift);
8786 if (progmode = pmMol2PS) then
8787 begin
8788 (*
8789 writeln;
8790 writeln('% reaction ',rxn_count,' reactant ',i);
8791 *)
8792 writeouts('');
8793 writeout('%% reaction %d reactant %d',[rxn_count,i]);
8794 end
8795 else
8796 writeout('<!-- reaction %d reactant %d -->',[rxn_count,i]);
8797 process_mol;
8798 end;
8799 end;
8800 if (progmode = pmMol2PS) then
8801 begin
8802 writeout('%% reaction %d arrow',[rxn_count]);
8803 printPSarrow((x_shift + x_padding),0,(x_shift + x_padding + arrow_length),0)
8804 end
8805 else
8806 begin
8807 writeout('<!-- reaction %d arrow -->',[rxn_count]);
8808 printSVGarrow((x_shift + x_padding),0,(x_shift + x_padding + arrow_length),0)
8809 end;
8810 x_shift := x_shift + x_padding + arrow_length;
8811 if (n_products > 0) then
8812 begin
8813 for i := 1 to n_products do
8814 begin
8815 zap_molecule;
8816 read_rxnmol;
8817 inc(mol_count);
8818 count_neighbors;
8819 ringsearch_mode := opt_rs;
8820 if ringsearch_mode = rs_sar then max_vringsize := max_ringsize else
8821 max_vringsize := 10;
8822 if opt_autoscale then scale_mol;
8823 center_mol;
8824 get_xminmax(x_min,x_max);
8825 shift_x((x_shift - x_min + x_padding));
8826 get_xminmax(x_dummy,x_shift);
8827 if (progmode = pmMol2PS) then
8828 begin
8829 (*
8830 writeln;
8831 writeln('% reaction ',rxn_count,' product ',i);
8832 *)
8833 writeouts('');
8834 writeout('%% reaction %d product %d',[rxn_count,i]);
8835 end
8836 else
8837 writeout('<!-- reaction %d product %d -->',[rxn_count,i]);
8838 process_mol;
8839 end;
8840 end;
8841 if (progmode = pmMol2PS) then
8842 begin
8843 write_PS_init;
8844 writeln(outbuffer.text);
8845 outbuffer.clear;
8846 if not opt_eps then writeln('showpage');
8847 writeln('% ----------------------end of image------------------------');
8848 end;
8849 if (progmode = pmMol2SVG) then
8850 begin
8851 writeouts('</g>');
8852 writeouts('</svg>');
8853 // here comes the SVG header with the corrected dimensions
8854 write_SVG_init;
8855 // here comes the content of the output buffer
8856 writeln(outbuffer.text);
8857 outbuffer.clear;
8858 // here comes the list of original dimensions (for post-processing)
8859 write_SVG_dimensions;
8860 end;
8861 {$IFDEF debug}
8862 debugoutput('number of brackets: '+inttostr(n_brackets)+' number of Sgroups: '+inttostr(n_sgroups));
8863 {$ENDIF}
8864 skip_data;
8865 outbuffer.clear; // v0.4
8866 end; // if rxn_header = true
8867 end; // while ...
8868 end;
8869 if rfile_is_open then close(rfile);
8870 end.
8871