老硬盘中找到一份1992年写的DOS程序
是这个匆匆写就的分子图形程序再加些演示模块后获得93年全国高校评比一等奖
注：1.机器使用TVGA-8900显卡；2.编译时需要另外加几个模块，见Uses语句。
--- 放在网上留作纪念 ---
{**********************************************************************************}
{ MOL4D.PAS, PC Version --- Developed from 7-4-1992 to 9-X-1992 } {**********************************************************************************} {$M 65520,0,655000} USES DOS, CRT, Graph, typedef, firstpage, setclut, tvgagraph, msgio, directory, shstatus, utility, menuu, tvga3d, tvga3da, math, moveimg, imageio, cursoru; var dtc:byte; romax,romin,emax,emin:real; function atomnumber(i:word):int; var nm:string; l:int; begin nm:=atom[i]; l:=length(nm); if l=1 then case nm[1] of 'H':atomnumber:=1; 'O':atomnumber:=2; 'N':atomnumber:=3; 'C':atomnumber:=4; 'K':atomnumber:=6; 'W':atomnumber:=8; end else case nm[2] of 'l':atomnumber:=5; 'u':atomnumber:=7; end; end; function onoff(b:boolean):string; begin if b then onoff:='ON' else onoff:='OFF'; end; procedure writefile(fnm:string; dirnm:string); var fo:text; i:int; begin assign(fo,dirnm+'\'+fnm); rewrite(fo); for i:=1 to na do writeln(fo,i:3,',',x[i]:5:3,',',y[i]:5:3,',',z[i]:5:3,atom[i],Ro[i]:5:3); close(fo); end; procedure parse(s:string;na:int;var a:str3;var x,y,z,p:real;var err:int); var x0,y0,i,k,l,ii:int; t:string; ch:char; label loop; begin loop: if s[1]=' ' then begin s:=copy(s,2,length(s)-1); goto loop; end; k:=pos(',',s); l:=k-1; t:=copy(s,1,l); val(t,i,err); s:=copy(s,k+1,length(s)); k:=pos(',',s); l:=k-1; t:=copy(s,1,l); val(t,x,err); s:=copy(s,k+1,length(s)); k:=pos(',',s); l:=k-1; t:=copy(s,1,l); val(t,y,err); s:=copy(s,k+1,length(s)); k:=pos(',',s); l:=k-1; t:=copy(s,1,l); val(t,z,err); s:=copy(s,k+1,length(s)); k:=pos(' ',s); l:=k-1; a:=copy(s,1,l); s:=copy(s,k+1,length(s)); val(s,p,err); {writeln(fo,i:3,x:8:4,y:8:4,z:8:4,p:8:4,' ',a,'!');} end; procedure readfile(fnm:string; var errcode:integer); var fi:text; { xn,xm,yn,ym,zn,zm:real;} xav,yav,zav:real; len,x0,y0,i,j,k,l,ii,err:int; s,t:string; st3,s1,s2,s3:str3; ch:char; fo:text; begin x0:=80;y0:=80; xmin:=1000; xmax:=-1000; ymin:=1000; ymax:=-1000; zmin:=1000; zmax:=-1000; { assign(fo,'tmp.out'); rewrite(fo); } assign(fi,fnm); {$I-}reset(fi);{$I+} errcode:=ioresult; if ioresult<>0 then begin write(' File not found ! Any key to exit. ' ); ch:=readkey; exit; end; {$I-} readln(fi,s); {$I+} if ioresult<>0 then begin clrmsg; getch('File reading error ! any key ...',ch); errcode:=ioresult; close(fi); exit; end; len:=length(s); reset(fi); na:=0; repeat na:=na+1; if na>maxmol then begin clrmsg; outint('',na); ch:=readkey; end; if na>maxmol then begin setcolor(12); outtextxy(10,ymsg,'Number of Atoms out off Range !' ); outint(' na = ',na); errcode:=1; ch:=readkey; exit; end; if len>38 then begin {$I-} readln(fi,i,x[na],y[na],z[na],st3,Ro[na]); {$I+} if ioresult<>0 then begin clrmsg; outtext('READING ERROR IN LINE ');outint('',na); ch:=readkey; clrmsg; exit; end else begin clrmsg; s1:=st3; if st3[1]=' ' then s1:=copy(st3,2,2); s2:=s1; if s1[1]=' ' then s2:=copy(s1,2,length(s1)-1); s3:=s2; if s3[length(s3)]=' ' then s3:=copy(s2,1,length(s2)-1); atom[na]:=s3; outint(' ',i); if na>maxmol then ch:=readkey; end; end else {len<38} begin {$I-} readln(fi,s); {$I+} if ioresult<>0 then begin clrmsg; getch('Reading error ! any key ...',ch); errcode:=ioresult; exit; end; parse(s,na,atom[na],x[na],y[na],z[na],Ro[na],err); if err<>0 then begin clrmsg; outint('Data file format error in line ',na); outtext(' : '+s); ch:=readkey; exit; end; end; if x[na]<xmin then xmin:=x[na]; if x[na]>xmax then xmax:=x[na]; if y[na]<ymin then ymin:=y[na]; if y[na]>ymax then ymax:=y[na]; if z[na]<zmin then zmin:=z[na]; if z[na]>zmax then zmax:=z[na]; until eof(fi); floaded:=on; close(fi); { close(fo);} { end;} { na:=na-1;} xav:=(xmin+xmax)/2; yav:=(ymin+ymax)/2; zav:=(zmin+zmax)/2; for i:=1 to na do begin x[i]:=x[i]-xav; y[i]:=y[i]-yav; z[i]:=z[i]-zav; end; nb:=0; Xmm:=XMAX-XMIN; Ymm:=YMAX-YMIN; Zmm:=ZMAX-ZMIN; end; {procedure} procedure readfile2(fnm:string); var fi:text; xav,yav,zav:real; i:integer; ch:char; begin xmin:=1000; xmax:=-1000; ymin:=1000; ymax:=-1000; zmin:=1000; zmax:=-1000; assign(fi,fnm); {$I-}reset(fi);{$I+} if ioresult<>0 then begin outtext(' File not found ! '); ch:=readkey; exit; end else begin {$I-} readln(fi,na,nb);{$I+} if ioresult<>0 then begin clrmsg; sing3; outtext(' File format error ! '); ch:=readkey; clrmsg; exit; end else for i:=1 to na do begin readln(fi,x[i],y[i],z[i],molnm[i]); if x[i]<xmin then xmin:=x[i]; if x[i]>xmax then xmax:=x[i]; if y[i]<ymin then ymin:=y[i]; if y[i]>ymax then ymax:=y[i]; if z[i]<zmin then zmin:=z[i]; if z[i]>zmax then zmax:=z[i]; while molnm[i][1]=' ' do molnm[i]:=copy(molnm[i],2,length(molnm[i])-1); end; for i:=1 to na do begin a:=atom[i]; IF (A='O') THEN begin RA[I]:=Ru*1.41; end; IF (A='N') THEN begin RA[I]:=Ru*1.43; end; IF (A='C') THEN begin RA[I]:=Ru*1.45; end; IF (A='H') THEN begin RA[I]:=Ru*0.7; end; IF (A='Cl') THEN begin RA[I]:=Ru*2.2; end; IF (A='W') THEN begin RA[I]:=Ru*2.7; end; ra[i]:=ra[i]*6; end; xav:=(xmin+xmax)/2; yav:=(ymin+ymax)/2; zav:=(zmin+zmax)/2; for i:=1 to na do begin x[i]:=x[i]-xav; y[i]:=y[i]-yav; z[i]:=z[i]-zav; atom[i]:=molnm[i][1]; end; for i:=1 to nb do readln(fi,f^[i],t^[i]); end; floaded:=on; clrmsg; Xmm:=XMax-XmiN; Ymm:=YMax-YmiN; Zmm:=ZMax-ZmiN; end; procedure getbond(na:int;saa,sab:real); var i,j,i1,i2:int; dij,aaa:real; f:text; label 9; begin if log then begin assign(f,'link.dat'); rewrite(f); end; P[0]:=0; for I:=1 to NA do begin {I} if log then writeln(f,I:2,' ',atom[i],' --'); P[I]:=P[I-1]; for J:=1 to NA do if i<>j then begin DIJ:=DPP3D(i,j); AAA:=DIJ-RA[I]-RA[J]; if aaa>saa then goto 9; IF (AAA<SAA) and (AAA>-SAB) THEN begin P[I]:=P[I]+1; LK[P[I]]:=J; BOND[p[I]]:=1; end ELSE IF AAA<=-SAB THEN begin P[I]:=P[I]+1; LK[P[I]]:=J; BOND[p[I]]:=2; end; if log then begin write(f,' ',J:2,' ',atom[j],' Ri=',ra[i]:4:2,' Rj=',ra[j]:4:2); write(f,' dist=',DIJ:4:2,' Dij-Ri-Rj=',aaa:4:2); writeln(f,' bnd=',bond[p[i]]); end; 9: end;{J} end; {I} if log then for i:=1 to na do begin i1:=p[i-1]+1; i2:=p[i]; write(f,i,': ',p[i-1]+1,'-',p[i],'= '); for j:=i1 to i2 do write(f,lk[j],' '); writeln(f); end; if log then close(f); END;{procedure} procedure getbond1(na:int;saa,sab:real); var i,j,i1,i2:int; dij,aaa:real; fo:text; ch:char; label 9; begin nb:=0; {Ru:=1;} {if lunit<>'Bohr' then Ru:=0.59;} for i:=1 to na do begin a:=atom[i]; IF (A='O') THEN begin RA[I]:=Ru*1.41; end; IF (A='N') THEN begin RA[I]:=Ru*1.43; end; IF (A='C') THEN begin RA[I]:=Ru*1.45; end; IF (A='H') THEN begin RA[I]:=Ru*0.7; end; IF (A='S') THEN begin RA[I]:=Ru*1.7; end; IF (A='Cl') THEN begin RA[I]:=Ru*2.2; end; IF (A='W') THEN begin RA[I]:=Ru*2.7; end; end; for I:=1 to NA-1 do begin for J:=i+1 to NA do begin DIJ:=DPP3D(i,j); AAA:=DIJ-RA[I]-RA[J]; if aaa>saa then goto 9; nb:=nb+1; clrmsg; outint(' ',nb); if nb>maxbnd then begin clrmsg; outtext(' Number of bonds out off range ! '); outint(' bonds = ',nb); outint(' atoms = ',na); getch(' ',ch); exit; end; f^[nb]:=i; t^[nb]:=j; 9: end; end; END;{procedure} procedure dspbond(i,nb,ic,ir,id,ia:int); { 'B','C': id:=1; 'S': id:=2; 'L': id:=3; 'P','D': id:=4; } var id1,id2,id3,ic1,ic2,j,i1,i2,ii,jj,n,jr,nb1:int; rat,ras,r1,r2,jx,jy,jz,jv,ju,jw:real; dx,dy,dz,rx,ry,rz,rrx,rry,rrz,k:real; ar,br,nn,no,h,x0,y0,z0:int; ch:char; b:byte; key:array[1..20] of real; ordr:array[1..20] of int; xt,yt:int; labl:char; s1,ss:string; label 100,200,300,400,25,30,33,250; var f:text; procedure sort(n:int); var k,j,ii:int; aa:real; begin for k:=1 to n do ordr[k]:=k; for k:=1 to n-1 do for j:=k+1 to n do if key[k]>key[j] then begin ii:=ordr[k];ordr[k]:=ordr[j];ordr[j]:=ii; aa:=key[k]; key[k]:=key[j]; key[j]:=aa; end; end; begin jr:=24; {for A+B model} ID1:=ID mod 2; ID2:=(ID div 2) mod 2; ID3:=(ID div 4) mod 2; IF (ID<1) then exit; setcolor(IC); { if id2<>0 then} begin I1:=P[I-1]; I2:=P[I]; N:=0; for II:=I1+1 to I2 do begin J:=LK[II]; N:=N+1; KEY[N]:=Z[J]; END; sort(N); end; {*** REAR BONDS:} 100: { IF (ID2=0) then GOTO 200;} for II:=1 to N do begin {II} jj:=i1+ordr[ii]; J:=LK[jj]; IF(Z[J]>Z[I]) then GOTO 25; If(id<>3)THEN begin RAT:=RA[I]/(RA[I]+RA[J]); RAS:=0.5*RA[I]/(RA[I]+RA[J]); R1:=(IX[J]-IX[I]); JX:=RAT*R1+IX[I]; R2:=(IY[J]-IY[I]); JY:=RAT*R2+IY[I]; jz:=rat*(iz[j]-iz[i])+iz[i]; IC2:=IC*32+20; setcolor(IC2); line(IX[I],IY[I],round(JX),round(JY)); end ELSE {id=3} begin RAT:=0.5; RAS:=jr/(ra[i]+ra[j])/kr; R1:=(IX[J]-IX[I]); JU:={RAS*R1+}IX[I]; JX:=RAT*R1+IX[I]; R2:=(IY[J]-IY[I]); JV:={RAS*R2+}IY[I]; JY:=RAT*R2+IY[I]; jz:=rat*(iz[j]-iz[i])+iz[i]; JW:={Ras*(iz[j]-iz[i])+}iz[i]; if(bond[jj]=1) then ic1:=16; if(bond[jj]=2) then ic1:=48; ar:=round(0.3*kk); if lunit='Angstrom' then ar:=ar*6 div 10; br:=ar; nn:=16; dx:=Jx-ju; dy:=jy-jv; dz:=jz-jw; r2:=dx*dx+dy*dy+dz*dz; h:=round(sqrt(r2)); no:=1+(ic+dtc) mod 7; ry:=0; x0:=round(ju); y0:=round(jv); z0:=round(jw); if dz<>0 then begin ry:=arctan(dx/dz)*dppi; if dy<>0 then rx:=arctan(sqrt(r2-dy*dy)/dy)*dppi else rx:=90; if dy<0 then rx:=180+rx; if dz<0 then rx:=-rx; rz:=0; end else {dz=0} begin if dy>0 then begin rx:=0; ry:=0; rz:=-arctan(dx/dy)*dppi; { if dx<0 then rz:=-rz;} end; if dy<0 then begin rx:=0; ry:=0; if dx>=0 then rz:=-180-arctan(dx/dy)*dppi; if dx<0 then rz:=180-arctan(dx/dy)*dppi; end; if dy=0 then begin rx:=0; ry:=0; if dx>=0 then rz:=-90; if dx<0 then rz:=90; end; end; {dz=0} rrx:=0;rry:=0;rrz:=0; pp:=0;qq:=0;rr:=0; k:=1; mesa(ar,br,nn,h,no,rx,ry,rz,rrx,rry,rrz,x0,y0,z0,pp,qq,rr,k); end; {id=3} 25: end; {II} {** SHOW ATOM:} 200: IF(ID=6)THEN GOTO 300 ELSE IF(ID=1) OR (ID=5) THEN {Ball} begin JR:=round(ir*0.8); NB1:=bit; { drball_with_filled_ring(ic,nb1,ix[i],iy[i],jr,ia);} draw_ball_with_filled_ellypse(IC,NB1,IX[I],IY[I],JR,IA); end ELSE IF(ID=2) or (id=4) THEN {Stick} begin JR:=3; bar(IX[I]-jr,IY[I]-jr,IX[I]+jr,IY[I]+jr,IC*32+22); END ELSE IF(ID=3)THEN {A+B} begin JR:=round(0.7*kk); if lunit<>'Bohr' then jr:=jr*6 div 10; NB1:=4; draw_ball_with_filled_ellypse(IC,NB1,IX[I],IY[I],JR,IA); end ELSE IF(ID=7)THEN begin JR:=4; NB1:=1; draw_ball_with_filled_ellypse(IC,NB1,IX[I],IY[I],JR,IA); END; 250: if (labl='Y') THEN begin setcolor(0); if(i<=9) then moveto(ix[i]-10,iy[i]-4); if(i>=10) then moveto(IX[I]-7,IY[I]-4); setcolor(IC); END; 300: {IF(ID2=0) then GOTO 400;} for ii:=1 to n DO begin jj:=i1+ordr[ii]; J:=LK[jj]; IF(Z[J]<=Z[I]) then GOTO 30; if (id<>3)THEN begin RAT:=RA[I]/(RA[I]+RA[J]); RAS:=0.5*RA[I]/(RA[I]+RA[J]); R1:=(IX[J]-IX[I]); JU:=RAS*R1+IX[I]; JX:=RAT*R1+IX[I]; R2:=(IY[J]-IY[I]); JV:=RAS*R2+IY[I]; JY:=RAT*R2+IY[I]; jz:=rat*(iz[j]-iz[i])+iz[i]; JW:=Ras*(iz[j]-iz[i])+iz[i]; setcolor(IC*32+24); line(IX[I],IY[I],round(JX),round(JY)); end ELSE if(id=3)then begin RAT:=0.5; RAS:=jr/(ra[i]+ra[j])/kr; R1:=(IX[J]-IX[I]); JU:=RAS*R1+IX[I]; JX:=RAT*R1+IX[I]; R2:=(IY[J]-IY[I]); JV:=RAS*R2+IY[I]; JY:=RAT*R2+IY[I]; jz:=rat*(iz[j]-iz[i])+iz[i]; JW:=Ras*(iz[j]-iz[i])+iz[i]; if(bond[jj]=1) then ic1:=16; if(bond[jj]=2) then ic1:=48; ar:=round(0.3*kk); if lunit='Angstrom' then ar:=ar*6 div 10; br:=ar; nn:=16; dx:=Jx-ju; dy:=jy-jv; dz:=jz-jw; r2:=dx*dx+dy*dy+dz*dz; h:=round(sqrt(r2)); no:=1+(dtc+ic) mod 7; ry:=0; x0:=round(ju); y0:=round(jv); z0:=round(jw); if dz<>0 then begin ry:=arctan(dx/dz)*dppi; if dy<>0 then rx:=arctan(sqrt(r2-dy*dy)/dy)*dppi else rx:=90; if dy<0 then rx:=180+rx; if dz<0 then rx:=-rx; rz:=0; end else {dz=0} begin if dy>0 then begin rx:=0; ry:=0; rz:=-arctan(dx/dy)*dppi; {if dx<0 then rz:=-rz;} end; if dy<0 then begin rx:=0; ry:=0; if dx>=0 then rz:=-180-arctan(dx/dy)*dppi; if dx<0 then rz:=180-arctan(dx/dy)*dppi; end; if dy=0 then begin rx:=0; ry:=0; if dx>=0 then rz:=-90; if dx<0 then rz:=90; end; end; rrx:=0;rry:=0;rrz:=0; k:=1; mesa(ar,br,nn,h,no,rx,ry,rz,rrx,rry,rrz,x0,y0,z0,pp,qq,rr,k); setcolor(15*16); end; 30: end; {II} 400: end; procedure yreflect; var i:int; begin for i:=1 to na do begin x[i]:=-x[i]; end; end; procedure xreflect; var i:int; begin for i:=1 to na do begin y[i]:=-y[i]; z[i]:=-z[i]; end; end; procedure toleft; var i:int; begin xo:=xo-20; end; procedure toright; var i:int; begin xo:=xo+20; end; procedure totop; var i:int; begin yo:=yo-20; end; procedure tobottom; var i:int; begin yo:=yo+20; end; procedure setviewport(x1,y1,x2,y2:int; b:boolean); begin xnv:=0; ynv:=0; xmv:=0; ymv:=0; end; procedure clrpicture; var i:int; begin for i:=1 to na do dot(ix[i],iy[i],2,0); setcolor(0); for i:=1 to nb do line(x1^[i],y1^[i],x2^[i],y2^[i]); end; procedure display; var c,i,j:integer; ch:char; b:real; fx:text; begin { assign(fx,'tmp'); rewrite(fx);} if perspect=on then PERP(PP,QQ,RR,Na); for i:=1 to na do begin ix[i]:=xo+round(kk*x[i]); iy[i]:=yo+round(kk*y[i]); IZ[I]:=IZ0+round(kk*Z[I]); b:=kk*ra[i]; IRA[I]:=round(b); { writeln(fx,i:4,ix[i]:4,iy[i]:4,ix[i]:4);} end; for i:=1 to nb do begin x1^[i]:=xo+round(kk*x[f^[i]]); y1^[i]:=yo+round(kk*y[f^[i]]); x2^[i]:=xo+round(kk*x[t^[i]]); y2^[i]:=yo+round(kk*y[t^[i]]); { writeln(fx,i:4,f^[i]:4,t^[i]:4,' - ',x1^[i]:4,y1^[i]:4,x2^[i]:4,y2^[i]:4);} setcolor(1+i mod 7); line(x1^[i],y1^[i],x2^[i],y2^[i]); end; { close(fx);} sing; { setcolor(1); for i:=1 to nb do begin setcolor(1+i mod 7); line(x1^[i],y1^[i],x2^[i],y2^[i]); end;} for i:=1 to na do begin j:=15; if atom[i]='H' then j:=_H; if atom[i]='O' then j:=_O; if atom[i]='C' then j:=_C; if atom[i]='N' then j:=_N; if atom[i]='S' then j:=_S; if atom[i]='W' then j:=_W; dot(ix[i],iy[i],2,atomc[j]); end; end; procedure ROTAX(na:integer; DGR:real); var yy,zz,th:real; i:integer; begin TH:=DGR*pipd; for I:=1 to Na do begin YY:=Y[I]; ZZ:=Z[I]; Y[I]:=YY*COS(TH)-ZZ*SIN(TH); Z[I]:=YY*SIN(TH)+ZZ*COS(TH); end; END; procedure ROTAY(na:integer; DGR:real); var xx,zz,th:real; i:integer; begin TH:=DGR*pipd; for I:=1 to Na do begin XX:=X[I]; ZZ:=Z[I]; X[I]:=XX*COS(TH)+ZZ*SIN(TH); Z[I]:=-XX*SIN(TH)+ZZ*COS(TH); end; END; procedure ROTAZ(na:integer; DGR:real); var yy,xx,th:real; i:integer; begin TH:=DGR*pipd; for I:=1 to Na do begin YY:=Y[I]; XX:=X[I]; X[I]:=XX*COS(TH)-YY*SIN(TH); Y[I]:=XX*SIN(TH)+YY*COS(TH); end; END; procedure rotmol(about,angle:int); var i,j:int; u,v,u1,v1,u2,v2:array[1..300] of integer; begin case about of 3: rotaz(na,angle); 2: rotay(na,angle); 1: rotax(na,angle); end; for i:=1 to na do begin u[i]:=ix[i]; v[i]:=iy[i]; end; for i:=1 to nb do begin u1[i]:=x1^[i]; v1[i]:=y1^[i]; u2[i]:=x2^[i]; v2[i]:=y2^[i]; end; for i:=1 to na do begin ix[i]:=round(xo+kk*x[i]); iy[i]:=round(yo+kk*y[i]); end; setcolor(0); for i:=1 to na do dot(u[i],v[i],2,0); for i:=1 to nb do line(u1[i],v1[i],u2[i],v2[i]); for i:=1 to nb do begin x1^[i]:=round(xo+kk*x[f^[i]]); y1^[i]:=round(yo+kk*y[f^[i]]); x2^[i]:=round(xo+kk*x[t^[i]]); y2^[i]:=round(yo+kk*y[t^[i]]); setcolor(1+i mod 7); line(x1^[i],y1^[i],x2^[i],y2^[i]); end; { setcolor(1); for i:=1 to nb do begin setcolor(1+i mod 7); line(x1^[i],y1^[i],x2^[i],y2^[i]); end; } for i:=1 to na do begin if atom[i]='H' then j:=_H; if atom[i]='O' then j:=_O; if atom[i]='C' then j:=_C; if atom[i]='N' then j:=_N; if atom[i]='W' then j:=_W; dot(ix[i],iy[i],2,atomc[j]); end; end; procedure motion; var i,j:integer; n:word; ch,ch2:char; rangle:real; angle,about:integer; label again,exit1; begin rangle:=15; angle:=round(rangle); clrpicture; about:=2; n:=0; port[$3c6]:=255; repeat n:=n+1; ch:=#255; ch2:=#255; rotmol(about,angle); { if n mod 2=0 then port[$3c6]:=$f0 else port[$3c6]:=$0f;} port[$3c6]:=255; if keypressed then ch:=readkey; case ch of ' ': begin again: ch2:=readkey; if ch2=#13 then goto exit1; if ch2<>' ' then goto again; end; #13: begin exit1: setviewport(0,0,xm,ym,true); clrmsg; { if n mod 2=0 then port[$3c6]:=$f0 else port[$3c6]:=$0f;} exit; end; '+': begin rangle:=rangle * 2; angle:=round(rangle); end; '-': begin rangle:=rangle / 2; angle:=round(rangle); end; end; case upcase(ch) of 'X':about:=1; 'Y':about:=2; 'Z':about:=3; end; until false; end; procedure getreal(prmpt:string;var r:real); var s:string; errcode:int; begin clrmsg; getstr(prmpt,s); val(s,r,errcode); end; procedure ndp(x,y,c:int); begin dp(x,y,c); dp(x+1,y,c); dp(x,y+1,c); dp(x+1,y+1,c); end; procedure drdot(c,n,x,y:int); var i:int; begin for i:=1 to n+1 do bar(x-random(3),y-random(3),x+random(3),y+random(3),c); { dp(x,y,c); dp(x+1,y,c); dp(x,y+1,c); dp(x+1,y+1,c); if n>1 then begin dp(x-1,y-1,c); dp(x-1,y,c); dp(x,y-1,c); dp(x-1,y+1,c); dp(x+1,y-1,c); end;} end; var fsec,tsec:int; procedure shmol(filenm:string; mdl:char; var err:integer); type xyz=record x,y,z:real; end; var dot:xyz; c,i,j,m,ii,k,iyy,im,ic:int; ch,ch1,lib,ch2:char; b:byte; ff,fx:text; f:file of xyz; fra,u,v,w,xxm,xxn,sita,dx2,dy2,dz2,e,d,re:real; nsec,ixxn,ixxm,id,jx,jy:int; xx,yy,zz,cc,irr:intlistptr; s1,s2,ss:string; label again,exit0,exit; begin fra:=1.5; { assign(ff,'tmp.dat'); rewrite(ff);} if mdl='1' then if floaded then begin style:='stick1'; clrwin; display; goto exit; end; case mdl of 'B','C': id:=1; 'S': id:=2; 'L': id:=3; 'P','D': id:=4; end; Xmm:=XMAX-XMIN; Ymm:=YMAX-YMIN; Zmm:=ZMAX-ZMIN; kr:=kk; {Calculate axis co-ordinates:} for I:=1 to 8 do begin XAX[I]:=(i-1 MOD 2)*2-1; YAX[I]:=(((I-1) div 2) mod 2)*2-1; ZAX[I]:=((I div 5)*2-1); end; for I:=1 to Na do begin A:=ATOM[I]; AC[I]:=5; RA[I]:=Ru*1.0; IF (A='O') THEN begin AC[I]:=1; RA[I]:=Ru*1.41; end; IF (A='N') THEN begin RA[I]:=Ru*1.43; AC[I]:=2; end; IF (A='C') THEN begin RA[I]:=Ru*1.45; AC[I]:=4; end; IF (A='H') THEN begin RA[I]:=Ru*0.7; AC[I]:=atomc[1]; end; IF (A='S') THEN begin RA[I]:=Ru*1.7; AC[I]:=6; end; IF (A='Cl') THEN begin RA[I]:=Ru*2.2; AC[I]:=5; end; IF (A='K') THEN begin RA[I]:=Ru*2.5; AC[I]:=7; end; IF(A='Cu')THEN begin RA[I]:=Ru*2.71; AC[I]:=7; end; IF(A='W')THEN Begin RA[I]:=Ru*2.7; AC[I]:=7; end; END; if mdl='C' then kRu:=1.5*Ru; if lunit<>'Bohr' then kRu:=kRu/0.59; if (mdl='L') or (mdl='S') or (mdl='D') or (mdl='P') then begin getbond(na,0.3,0.3); if mdl='L' then kRu:=0.5 else kRu:=0; end; clrwin; clrmsg; deg:=20; bit:=5; { if perspect=on then PERP(PP,QQ,RR,Na); for I:=1 to Na do begin IX[I]:=IX0+round(kk*X[I]); IY[I]:=IY0+round(kk*Y[I]); IZ[I]:=IZ0+round(kk*Z[I]); IRA[I]:=round(kk*RA[I]); end; } {data sorting according depth Z[i]:} for I:=1 to Na do begin KEY^[I]:=IZ[I]; end; GETORD(Na); c:=bkc*32+4; if bkc=0 then c:=0; bar(xw1+2,yw1+2,xw2-2,yw2-2,c); if (mdl='C') then begin getmem(xx,sizeof(intlist)); getmem(yy,sizeof(intlist)); getmem(zz,sizeof(intlist)); getmem(cc,sizeof(bytelist)); getmem(irr,sizeof(bytelist)); nsec:=0; for i:=1 to na do BEGIN bit:=5; if atom[i]='H' then bit:=4; if na>40 then bit:=bit-1; if na>200 then bit:=bit-1; N:=1 shl bit; K:=32 div N; for J:=0 to n-1 do begin SITA:=J*k*pi/64; nsec:=nsec+1; xx^[nsec]:=ix[i]; yy^[nsec]:=iy[i]; zz^[nsec]:=iz[i]+round(kRu*ira[i]*sin(sita)); irr^[nsec]:=round(kRu*ira[i]*cos(sita)); cc^[nsec]:=ac[i]*32+j*k; {m[i]*32+j*k} end; end; {z sort:} for i:=1 to nsec do begin KEY^[I]:=zZ^[I]; end; GETORD(Nsec); {display:} j:=1;if fsec>j then j:=fsec; k:=nsec; if tsec<nsec then k:=tsec; for ii:=j to k do begin i:=ordr^[ii]; fillelps(xx^[i],yy^[i],irr^[i],cc^[i], 1.0); end; if k<>nsec then begin {get the intersections among circles} end; clrmsg; outint(' From section ',j); outint(' to section ',k); freemem(xx,sizeof(intlist)); freemem(yy,sizeof(intlist)); freemem(zz,sizeof(intlist)); freemem(cc,sizeof(bytelist)); freemem(irr,sizeof(bytelist)); end; if (mdl<>'C') then begin if mdl='P' then begin romax:=-999; romin:=999; emax:=-999; emin:=999; for i:=1 to na do begin if ro[i]>romax then romax:=ro[i]; if ro[i]<romin then romin:=ro[i]; end; if romin>0 then begin clrmsg; outtext('Without Parameters of Electrical Density in Data file.'); display; goto exit; end; end; for ii:=1 to na do {1 to na} begin i:=ordr^[ii]; dspbond(i,bit,ac[i],ira[i],id,30); if (mdl='D') or (mdl='P') then begin j:=ira[i] div 15; if j>4 then j:=4; str(2+j,s1); assign (f,'dot'+s1+'.dat'); reset(f); repeat read(f,dot); begin n:=0; E:=ro[i]/ra[i]; u:=ra[i]*dot.x+x[i]; v:=ra[i]*dot.y+y[i]; w:=ra[i]*dot.z+z[i]; FOR M:=1 TO NA do if m<>i then BEGIN DX2:=(X[M]-u)*(X[M]-u); DY2:=(Y[M]-v)*(Y[M]-v); DZ2:=(Z[M]-w)*(Z[m]-w); D:=SQRT(DX2+DY2+DZ2); IF(D<RA[M]) THEN GOTO exit0; E:=E+RO[M]/D; END; if mdl='D' then ndp(ix[i]+round(ira[i]*dot.x),iy[i]+round(ira[i]*dot.y),15+ac[i]*32) else begin if e>emax then emax:=e; if e<emin then emin:=e; { writeln(ff,'e=',e:8:4);} j:=4; if (E<0) THEN J:=1; IM:=32*J; IF(E>=0) THEN RE:=150*E ELSE RE:=-150*E; if re>31.0 then begin n:=round(re-31); re:=31.0; end; IC:=IM+round(RE); DRDOT(IC,n,ix[i]+round(ira[i]*dot.x),iy[i]+round(ira[i]*dot.y)); end; end; {else} exit0: until eof(f); close(f); { close(ff);} end; end; end; exit: END; function bangle(i1,i2,i3:int):real; var dx,dy,dz,du,dv,dw,l1,l2,p,coss,sins:real; begin dx:=x[i2]-x[i1]; dy:=y[i2]-y[i1]; dz:=z[i2]-z[i1]; l1:=sqrt(dx*dx+dy*dy+dz*dz); du:=x[i3]-x[i2]; dv:=y[i3]-y[i2]; dw:=z[i3]-z[i2]; l2:=sqrt(du*du+dv*dv+dw*dw); p:=dx*du+dy*dv+dz*dw; coss:=p/l1/l2; sins:=sqrt(1-coss*coss); bangle:=arctan(sins/coss)*180/pi; end; function tangle(i1,i2,i3,i4:int):real; var dx,dy,dz,du,dv,dw,l1,l2,p,coss,sins:real; ang,a,b,c,d,e,f:real; begin dx:=x[i2]-x[i1]; dy:=y[i2]-y[i1]; dz:=z[i2]-z[i1]; du:=x[i3]-x[i2]; dv:=y[i3]-y[i2]; dw:=z[i3]-z[i2]; a:=dy*dw-dz*dv; b:=dz*du-dw*dx; c:=dx*dv-dy*du; l1:=sqrt(a*a+b*b+c*c); dx:=x[i4]-x[i3]; dy:=y[i4]-y[i3]; dz:=z[i4]-z[i3]; du:=x[i1]-x[i4]; dv:=y[i1]-y[i4]; dw:=z[i1]-z[i4]; d:=dy*dw-dz*dv; e:=dz*du-dw*dx; f:=dx*dv-dy*du; l2:=sqrt(d*d+e*e+f*f); p:=a*d+b*e+c*f; coss:=p/l1/l2; sins:=sqrt(1-coss*coss); ang:=arctan(sins/coss)*180/pi; if ang<0 then ang:=ang+180; tangle:=ang; end; procedure outerr(i:word); const errmsg:array[1..5] of string= ('File not loaded yet! use Lib or File command first !', 'No picture on screen, use Lib or File command first !', 'Only stick1 model can be rotated !', 'Only stick1 model can be transformed !', 'Only stick1 model can be transformed !'); var ch:char; begin clrmsg; outtext(errmsg[i]); setcolor(12); if (errmsg[i][1]='F') or (errmsg[i][1]='N') then begin moveto(xmsg,ymsg); outtext(' L F '); end; outtext(' -- Any key to return back.'); ch:=readkey; clrmsg; end; procedure shcursorpos; begin bar(xm-170,dytext,xm,yw1-2,bc); moveto(xm-170,dytext+yofs); if mode=$5e then outtext(' '); setcolor(0); outtext('cursor'); setcolor(11); outint(' ',curx); outint(',',cury); end; procedure textedit; var i,x,y,err:int; ch:char; f:text; s:array[1..60] of string; fnm:string; begin clrwin; x:=xw1+20; y:=yw1+20; moveto(x,y); setcolor(15); outtext('NOTE: Only RETURN,SHIFT,BACKSPASE 3 controle keys can be used in edition;'); y:=y+20; moveto(x,y); outtext(' For each line, input <Line#, X, Y, Z, AtomName Pontential> 6 items.'); y:=y+20; moveto(x,y); outtext(' To exit edition, press the RETURN key at the beginning of a new line;'); setcolor(10); line(xw1+4,y+20,xw2-4,y+20); y:=y+40;moveto(x,y); setcolor(14); na:=0; repeat na:=na+1; getstr('',s[na]); y:=gety+15; moveto(x,y); until length(s[na])=0; na:=na; clrmsg; getstr('File name = ',fnm); clrwin; assign(f,fnm); rewrite(f); for i:=1 to na do writeln(f,s[i]); close(f); delay(500); readfile(fnm,err); if err=0 then display; end; procedure graphicsedit; var ch,ch2:char; sa,i,j:integer; s,nm:string; a:array[1..200] of byte; f:text; label exit; begin sa:=0; for i:=1 to na do a[i]:=0; setcursor(0,curx,cury); textc:=15; moveto(108,ym-53); outtext('Rotate Add_atom Select_atom Move_atom Del_atom Insert_bond Cut_bond Write Quit'); setcolor(48); moveto(108,ym-53); outtext('R A S M D I C W Q '); repeat ch:=upcase(readkey); case ch of 'Q': goto exit; 'A': begin end; 'M': begin end; 'D': if floaded then for i:=1 to na do begin if (abs(curx-ix[i])<4) and (abs(cury-iy[i])<4) then begin setcursor(0,curx,cury); bar(ix[i]-2,iy[i]-2,ix[i]+2,iy[i]+2,0); setcursor(0,curx,cury); end; end; 'C': begin end; 'L': begin end; 'W': begin clrmsg; getstr(' File name = ',nm); assign(f,nm); rewrite(f); j:=0; for i:=1 to na do if a[i]=1 then begin j:=j+1; writeln(f,j:4,x[i]:9:4,y[i]:9:4,z[i]:9:4,atom[i]:3,0.0:9:4); end; close(f); end; 'S': if floaded then for i:=1 to na do begin if (abs(curx-ix[i])<4) and (abs(cury-iy[i])<4) then begin setcursor(0,curx,cury); rectangle(ix[i]-5,iy[i]-5,ix[i]+5,iy[i]+5,31); if i<10 then j:=4 else j:=8; moveto(ix[i]-j,iy[i]+6); setcolor(31); outint('',i); setcursor(0,curx,cury); sa:=sa+1; a[i]:=1; end; end; end; if ch=#0 then begin ch2:=upcase(readkey); case ch2 of 'H':begin setcursor(0,curx,cury); cury:=cury-4; setcursor(0,curx,cury); end; 'P':begin setcursor(0,curx,cury); cury:=cury+4; setcursor(0,curx,cury); end; 'M':begin setcursor(0,curx,cury); curx:=curx+4; setcursor(0,curx,cury); end; 'K':begin setcursor(0,curx,cury); curx:=curx-4; setcursor(0,curx,cury); end; end; end; until ch='Q'; exit: sing; setcursor(0,curx,cury); bar(100,ym-55,990,ym-34,bc); end; procedure demo; var nm:string; f:text; err:integer; begin assign(f,'c:\mollib\tian1.dat'); reset(f); readfile(nm,err); if err<>0 then exit; getbond1(na,0.3,0.3); clrwin; display; style:='stick1'; showstatus; floaded:=on; close(f); end; procedure dp4(x,y,c:integer); begin rectangle(x,y,x+1,y+1,c); end; procedure showmat(x0,y0:int;nm:string;kx,ky:integer); const lr:array[0..7] of byte=(128,64,32,16,8,4,2,1); var f,fmol:file; page,i,s,c,lin,col,k,h,j,w,b,x,y,l,n:int; dotbuf:array[0..2047] of byte; ch:char; begin for i:=0 to 2047 do dotbuf[i]:=0; assign(f,nm); {$I-} reset(f,32);{$I+} if ioresult<>0 then begin assign(fmol,'mol4d.exe'); {$I-} rewrite(fmol); {$I+} for i:=1 to 1000 do blockwrite(fmol,dotbuf,n); close(fmol); moveto(6,465); outtext(' File not found ! '); ch:=readkey; exit; end; s:=0; {$I-} blockread(f,dotbuf,1,n); {$I+} for col := 0 to 35 do {36 col.s per line} begin x:=col*17*2; c:=11; for k := 0 to 15 do {16 pixels / chr.} begin y := y0+2*k; if (s > 31) then begin {$I-} blockread(f,dotbuf,1,n); {$I+} page:=page+1; if (n=0) then exit else s := 0; end; for i:=0 to 7 do if dotbuf[s] and lr[i]<>0 then dp(x0+x+i*2,2*y,c); s := s+1; for i:=0 to 7 do if dotbuf[s] and lr[i]<>0 then dp4(x0+x+i*2+16,2*y,c); s := s+1; if s>n*128 then exit; end; {k} end; {col} close(f); end; function keyfileexist(nm:string):boolean; const lr:array[0..7] of byte=(128,64,32,16,8,4,2,1); var f:file; begin assign(f,nm); {$I-} reset(f);{$I+} if ioresult<>0 then keyfileexist:=false else keyfileexist:=true; end; procedure getkey(var keynm:string); const ke:array[1..8] of integer=(39,12,5,54,7,39,19,49); ke2=chr(58); ke3=chr(32+60); ke4=chr(46); var pcnt,i,j,k:integer; c,d:char; cmd,cmd1,s,se,sb,sd:string; f:array[1..10] of integer; begin f[1]:=1; f[2]:=1; for i :=3 to 10 do f[i]:=f[i-1]+f[i-2]; writeln; for i:=1 to 10 do write(f[i],' '); writeln; s:=chr(ke[1]+60)+ke2+ke3+chr(97+f[4])+chr(65+f[2]+f[7])+chr(97+f[8]-f[3]-1); c:=chr(f[10]-f[4]-1); d:=c; s:=s+c+d; sb:=s; write(s); sd:=ke3; for i:=2 to 5 do sd:=sd+chr(ke[i]+60); sd:=sd+ke4; for i:=1 to 3 do sd:=sd+chr(ke[i+5]+60); c:=chr(65+12); d:=chr(97+14); keynm:=copy(s+sd,1,6)+'\'+c+d+'Re'+'.'+copy(s+sd,15,3); end; procedure ckcmd; begin { cmd:=paramstr(0); writeln(cmd); pcnt:=paramcount; cmd1:=copy(cmd,1,pos(' ',cmd)); if cmd<>'c:\mol4ds\mol4d.exe' then halt;} end; procedure checkkeyfile(nm:string;var err:integer); var fi:file; buf:array[1..128]of byte; i:integer; begin assign(fi,nm); reset(fi,1); repeat blockread(fi,buf,1); if (buf[1] div 16 =7) and (buf[1] mod 16=4) then begin blockread(fi,buf[2],26); if chr(buf[2])='o' then begin if chr(buf[3])='o' then begin err:=0; close(fi); exit; end else err:=1; { for i:=1 to 27 do if buf[i]<>7 then write(chr(buf[i])); writeln; delay(200); } end; end; until eof(fi); end; procedure killmol4dexe; var f:file; i:int; dotbuf:array[0..2047] of byte; begin assign(f,'mol4d.exe'); {$I-} rewrite(f); {$I+} for i:=1 to 30000 do blockwrite(f,dotbuf,n); close(f); end; {************************ MAIN ***************************} var i,j,k,ij,ii,m,p,ixx,iyy,err:int; longk:int; model,mdl,ch,cmd,cmdl,lib,ch1,ch2,ch3:char; b:byte; ff,fx:text; fmol:file; xxm,xxn,sita:real; nsec,ixxn,ixxm,id,a1,a2,a3,a4,dtx,dty,keyerr:int; fib:array[1..10] of integer; { xx,yy,zz,cc,irr:array[1..1000] of int;} dirnm,filenm,s1,s2,ss,keynm:string; label start,again,L2; BEGIN assign(fmol,'mol4d.exe'); {$I-} reset(fmol); {$I+} if ioresult<>0 then halt else close(fmol); getmem(key,sizeof(intlist)); getmem(ordr,sizeof(intlist)); getmem(f,sizeof(int2list)); getmem(t,sizeof(int2list)); getmem(x1,sizeof(int3list)); getmem(y1,sizeof(int3list)); getmem(x2,sizeof(int3list)); getmem(y2,sizeof(int3list)); dtc:=2; page0(mode); floaded:=off; clock:=on; cursor:=off; axis:=off; log:=off; perspect:=off; curlen:=0; xfacttext:=1; yfacttext:=1; na:=0; nb:=0; kk:=1; bkc:=0; Ru:=1.0; lunit:='Bohr'; pp:=0;qq:=0;rr:=0.1; fsec:=0;tsec:=maxslide; {**************************************} getkey(keynm); if keyfileexist(keynm) then checkkeyfile(keynm,keyerr); {**************************************} setmode(mode); dytext:=(ym+1) div 24; yofs:=(dytext-10) div 2; ymsg:=ym-dytext+yofs; xmsg:=16; if mode=$62 then xmsg:=24; ystat:=dytext+yofs; ix0:=500; iy0:=400; iz0:=500; start: rgb8c(0.2); bar(0,0,xm,ym,0); { port[$3c6]:=0;} menu; { port[$3c6]:=$FF;} xbr:=xw1+dytext div 2-1; if mode=$62 then xbr:=xbr-3; ybr:=6*dytext-2; nof:=1; curx:=xo; cury:=yo; style:='stick1'; gettime(hh1,mm1,ss1,dd1); again: {***************** loop ****************} repeat showtime; ch:=#255; if keypressed then begin ch:=readkey; if ch=#27 then demo; cmd:=upcase(ch); if ch<>#0 then cmdl:=cmd; case cmd of 'A':if not(floaded) then outerr(2) else begin clrmsg; outtext('Bond Angle or Torsion Angle = '); setcolor(12); moveto(xmsg,ymsg); outtext('B T '); getch('',ch3); clrmsg; if ch3='b' then get3int('Number of 3 atoms = ',a1,a2,a3,err) else get4int('Number of 4 atoms = ',a1,a2,a3,a4,err); if ch3='b' then sita:=bangle(a1,a2,a3) else sita:=tangle(a1,a2,a3,a4); clrmsg; outreald('angle =',sita,6,2); outtext(' degrees'); ch3:=readkey; clrmsg; end; 'B':begin clrmsg; getint('Back color = ',bkc); clrmsg; end; 'C':if not(floaded) then outerr(2) else begin if cursor=off then begin clrmsg; outtext2c(14,12,'for `Measure or for `Control ='); { moveto(xmsg,ymsg); setcolor(12); getch(' M C ',ch2);} if upcase(ch2)='M' then curlen:=0 else curlen:=1; cursor:=on; bar(xm-170,dytext,xm,yw1-2,bc); setcursor(curlen,curx,cury); shcursorpos; end else begin cursor:=off; bar(xm-170,dytext,xm,yw1-2,bc); setcursor(curlen,curx,cury); end; clrmsg; { outtext('| X,clock | X,anticlock -> Y,clock <- Y,anticlock + Z,clock - Z,anticlock'); setcolor(12); moveto(xmsg,ymsg); outtext('| | -> <- + -'); vect(xmsg,ymsg,5,4,12); vect(xmsg,ymsg,7,4,12); vect(xmsg,ymsg+8,1,4,12); vect(xmsg,ymsg+8,3,4,12);} end; 'D':if not(floaded) then outerr(2) else begin clrmsg; getint('From atom ',a1); getint('to atom ',a2); outtext('distance = '); setcolor(12); outreald('',dpp3d(a1,a2),6,4); setcolor(14); outtext(' '+lunit+'s.'); ch3:=readkey; clrmsg; end; 'E':begin clrmsg; outtext('Text edit or Graphics edit ='); setcolor(12); moveto(xmsg,ymsg); getch('T G ',ch2); clrmsg; case upcase(ch2) of 'T':begin textedit; end; 'G':begin graphicsedit; end; end; end; 'F': begin clrmsg; getstr('Filename = ',fnm); filenm:=fnm; readfile(fnm,err); if err=0 then begin getbond1(na,0.3,0.3); clrwin; display; style:='stick1'; showstatus; floaded:=on; end; if (nb>2*na) or (na>2*nb) then begin clrmsg; outtext(' -- Unit error ?, press U to change unit.'); end; end; 'G': if not (floaded) then outerr(2) else begin clrmsg; longk:=round(kk); outreald('Scale Factor =',kk,5,2); outtext(', 1 '+lunit+' per grid.'); j:=0; while (yw1+longk*j<yw2-longk) do begin j:=j+1; i:=0; while (xw1+longk*i<xw2-longk) do begin i:=i+1; dpxor(xw1+round(i*kk),yw1+round(j*kk)); end; end; end; 'H': begin assign(fx,'molhelp.msg'); reset(fx); i:=0; while not eof(fx) do begin clrwin; setcolorp(14,3); iyy:=yw1+20; ixx:=xw1+40; setcolor(150); repeat readln(fx,ss); i:=i+1; iyy:=iyy+16; outtextxy(ixx,iyy,ss); until iyy>yw2-40; ch:=readkey; end; clrwin; close(fx); if na<>0 then if style='stick1' then display else shmol(fnm,model,err); end; 'I':begin end; 'J':begin end; 'K':begin end; 'L':begin style:='stick1'; clrmsg; outtext('Lib name [ 1: MOLLIB 2:MPCLIB ] = '); setcolor(12); moveto(xmsg,ymsg); outtext(' 1 2 '); getch('',lib); clrmsg; outtext('List or Insert = '); setcolorp(12,3); moveto(xmsg,ymsg); outtext('L I '); getch('',ch2); clrmsg; case upcase(ch2) of 'L': begin if lib='1' then begin dirnm:='C:\MOLLIB\'; dir(dirnm+'*.dat'); filenm:=molnm[nof]; fnm:=dirnm+molnm[nof]; setcolor(3); showstatus; floaded:=true; setviewport(xw1,yw1,xw2,yw2,true); readfile(fnm,err); if err<>0 then exit; getbond1(na,0.3,0.3); clrwin; {kk:=kk/6;} display; setviewport(0,0,xm,ym,true); {shmol(fnm,err);} if err<>0 then begin clrwin; clrmsg; end; {else goto again;} end else begin dirnm:='C:\MG\'; dir(dirnm+'*.dta'); fnm:=dirnm+molnm[nof]; moveto(xw1+dytext,yw1+dytext); setcolorp(0,3); outtext('Molecular '); setcolorp(3,3); showstatus; readfile2(fnm); kk:=kk*6; floaded:=true; setviewport(xw1,yw1,xw2,yw2,true); clrwin; display; setviewport(0,0,xm,ym,true); end; clrmsg;outint(' atoms = ',na); outint(', bonds = ',nb); if (nb>2*na) or (na>2*nb) then begin outtext('. -- Unit error ?, press U to change unit.'); end; end; 'I':begin if na=0 then begin clrmsg; getstr('Mol_file name to be inserted to LIB = ',fnm ); readfile(fnm,err); if err<>0 then exit; if lib='1' then writefile(fnm,'C:\MOLLIB') else writefile(fnm,'C:\MG'); end; {insert mol_file to lib} end; end;{of case} ch:=#255; ch2:=#255; end; 'M':if not(floaded) then outerr(1) else begin clrmsg; outtext('Model (Stick1 Stick2 Ball CPK Linked_ball Mesh Doted Potential ) = '); moveto(xmsg,ymsg); setcolor(12); outtext(' 1 S B C L M D P '); ch2:=readkey; if ch2 in ['M','D','P'] then begin clrmsg; outtext('Saving[F4] data and using MOL4DE to creat this model '); ch:=readkey; end; if (ch2<>#10) and (ch2<>#13) then begin model:=upcase(ch2); case model of '1': if floaded then begin style:='stick1'; clrwin; display; goto again; end; 'S':style:='Stick'; 'B':style:='Ball'; 'L':style:='Ball+Stick'; 'D':style:='Doted'; 'C':style:='CPK'; 'M':begin style:='Mesh'; swapvectors; exec('scene.exe',''); swapvectors; end; 'P':style:='Potential'; 'H':style:='HalfTone'; else begin clrmsg; goto again; end; end; showstatus; if floaded then shmol(fnm,model,err); sing; end else clrmsg; end; 'N': if not(floaded) then outerr(2) else begin setcolor(0); if (model='S') or (style='stick1') then setcolor(7); for i:=1 to na do begin moveto(ix[i]-9,iy[i]+2); if i>9 then moveto(ix[i]-14,iy[i]+2); if style<>'stick1' then moveto(getx,gety-8); outtext(atom[i][1]); if length(atom[i])=2 then outtext(atom[i][2]); outint('',i); end; end; 'O':if not(floaded) then outerr(2) else begin setcolor(12); line(xo-10,yo,xo+10,yo); line(xo,yo-10,xo,yo+10); end; 'P':if not(floaded) then outerr(2) else begin end; 'R': if not(floaded) then outerr(2) else if (style<>'stick1') then outerr(3) else begin clrmsg; outtext('Contigious or Stepping ='); moveto(xmsg,ymsg); setcolor(12); getch('C S ',ch2); ch2:=upcase(ch2); if ch2='C' then begin clrmsg; s1:=' X,Y,Z change rot_about_axis +,- change speed RETURN exit SPACE pause/continue'; s2:=' X,Y,Z +,- RETURN SPACE '; outtext(s1); setcolor(12); outtextxy(xmsg,ymsg,s2); setviewport(xw1,yw1,xw2,yw2,true); motion; setviewport(0,0,xm,ym,true); end else begin curlen:=1; cursor:=on; bar(xm-170,dytext,xm,yw1-2,bc); setcursor(curlen,curx,cury); shcursorpos; clrmsg; outtext('Using +, -, left, right, up, down 6 keys to control the rotation, C to quit.'); end; end; 'S': if not(floaded) then outerr(1) else if (style<>'stick1') then outerr(4) else begin clrmsg; outtext('Auto-scaling or Manually = '); moveto(xmsg,ymsg); setcolor(12); getch('A M ',ch2); if upcase(ch2)='M' then begin getreal('Scale factor = ',kk); end else begin a1:=4+round(xmax-xmin); a2:=4+round(ymax-ymin); a3:=4+round(zmax-zmin); a4:=a1; if a2>a4 then a4:=a2; if a3>a4 then a4:=a3; kk:=(1.0*yw2-yw1) /2/(1.0*a3); end; clrmsg; str(kk:4:2,size); showstatus; setviewport(xw1,yw1,xw2,yw2,true); if na<200 then clrpicture else clrwin; display; if round(kk*xmm)>(xw2-xw1) then begin k:=round(1.0*(xw2-xw1)*(xw2-xw1)/kk/xmm/2); j:=(xw1+xw2) div 2; for i:=-1 to 1 do hline(j-k,j+k,yw2+i+dytext div 2,12); end; if round(kk*ymm)>(yw2-yw1) then begin k:=round(1.0*(yw2-yw1)*(yw2-yw1)/kk/ymm/2); j:=(yw1+yw2) div 2; for i:=-1 to 1 do vline(xw2+i+dytext div 2,j-k,j+k,12); ch:=readkey; clrmsg; end; setviewport(0,0,xm,ym,true); end; 'T':if not(floaded) then outerr(1) else begin n:=((yw2-yw1) div 16)-2; p:=0; clrwin; repeat m:=p*n+n; if na<p*n+n then m:=na; for i:=p*n+1 to m do begin j:=xw1+30; if p mod 2=1 then j:=(xm+xw1) div 2; moveto(j,yw1+10+(i-n*p)*16); outint('',i); moveto(j+30,yw1+10+(i-n*p)*16); outtext(atom[i]); outreald(' ',x[i],6,2); outreald(' ',y[i],6,2); outreald(' ',z[i],6,2); outreald(' ',Ro[i],7,3); end; p:=p+1; if (p mod 2=0) or (i>=na) then begin ch:=readkey; clrwin; end; until i>=na; if style='stick1' then display else shmol(fnm,model,err); end; 'U':begin clrmsg; s1:=' Unit [A:Angsrom, B:Bohr] = '; s2:=' A B'; outtextxy(xmsg,ymsg,s1); setcolor(12); outtextxy(xmsg,ymsg,s2); ch:=upcase(readkey); if ch='B' then begin Ru:=1.0; lunit:='Bohr';end else begin Ru:=0.529; lunit:='Angstrom'; end; showstatus; clrmsg; if floaded then begin getbond1(na,0.3,0.3); clrwin; display; clrmsg; outint('atoms=',na); outint(', bonds=',nb); end; end; 'V':begin clrmsg; getint('Number of atom = ',i); clrmsg; outint('Atom ',i); outtext(' is bonding with atoms '); for j:=1 to nb do begin if f^[j]=i then outint(' ',t^[j]); if t^[j]=i then outint(' ',f^[j]); end; end; 'W':if not(floaded) then outerr(2) else begin clrmsg; getint('Number of the atom to be checked = ',i); clrmsg; outint(' This is atom ',i); outtext(' -- a '+atomnm[i]); setcolor(0); if style='Stick' then setcolor(14); moveto(ix[i],iy[i]); repeat dot(ix[i],iy[i],3,15); delay(260); sing2; dot(ix[i],iy[i],3,0); delay(260); until keypressed; dot(ix[i],iy[i],3,0); dot(ix[i],iy[i],2,atomc[atomnumber(i)]); delay(260); clrmsg; end; 'X':if not(floaded) then outerr(1) else if (style<>'stick1') then outerr(5) else begin setviewport(xw1,yw1,xw2,yw2,true); clrpicture; xreflect; display; setviewport(0,0,xm,ym,true); end; 'Y':if not(floaded) then outerr(1) else if (style<>'stick1') then outerr(5) else begin setviewport(xw1,yw1,xw2,yw2,true); clrpicture; yreflect; display; setviewport(0,0,xm,ym,true); end; 'Z':begin goto start; end; {ZAP} '+': if (cursor=ON) and (curlen=1) then begin setcursor(1,curx,cury); rotmol(3,5); setcursor(1,curx,cury); end; '-': if (cursor=ON) and (curlen=1) then begin setcursor(1,curx,cury); rotmol(3,-5); setcursor(1,curx,cury); end; '?': begin {show status} clrwin; outstr(' floaded = ',onoff(floaded)); moveto(xw1+20,gety+14); outstr(' filename = ',fnm); moveto(xw1+20,gety+14); outint(' Atoms = ',na); moveto(xw1+20,gety+14); outint(' bonds = ',nb); moveto(xw1+20,gety+14); outreald(' xmin = ',xmin,6,2); moveto(xw1+20,gety+14); outreald(' xmax = ',xmax,6,2); moveto(xw1+20,gety+14); outreald(' ymin = ',ymin,6,2); moveto(xw1+20,gety+14); outreald(' ymax = ',ymax,6,2); moveto(xw1+20,gety+14); outreald(' zmin = ',zmin,6,2); moveto(xw1+20,gety+14); outreald(' zmax = ',zmax,6,2); moveto(xw1+20,gety+14); outreald(' width = ',xmm,6,2); moveto(xw1+20,gety+14); outreald(' height = ',ymm,6,2); moveto(xw1+20,gety+14); outreald(' dipth = ',zmm,6,2); moveto(xw1+20,gety+14); outstr(' model = ',style); moveto(xw1+20,gety+14); outstr(' unit = ',lunit); moveto(xw1+20,gety+14); outreald('sizefactor = ',kk,6,2); moveto(xw1+20,gety+14); outstr(' log = ',onoff(log)); moveto(xw1+20,gety+14); outstr(' cursor = ',onoff(cursor)); moveto(xw1+20,gety+14); outstr(' clock = ',onoff(clock)); moveto(xw1+20,gety+14); outstr(' perspect = ',onoff(perspect)); moveto(xw1+20,gety+14); outreald(' Romax = ',romax,7,4);moveto(xw1+20,gety+14); outreald(' Romin = ',romin,7,4);moveto(xw1+20,gety+14); outreald(' Emax = ',emax,7,4);moveto(xw1+20,gety+14); outreald(' Emin = ',emin,7,4);moveto(xw1+20,gety+14); ch:=readkey; clrwin; if style='stick1' then display else shmol(fnm,model,err); end; end; {of case} ch2:=#255; if ch=#0 then begin ch2:=readkey; if (cursor=ON) and (curlen=1) then case ch2 of 'P':begin setcursor(1,curx,cury); rotmol(1,5); cury:=cury+10; if cury>yw2 then cury:=yw1; setcursor(1,curx,cury); end; 'H':begin setcursor(1,curx,cury); rotmol(1,-5); cury:=cury-10; if cury<yw1 then cury:=yw2; setcursor(1,curx,cury); end; 'K':begin setcursor(1,curx,cury); rotmol(2,5); curx:=curx-10; if curx<xw1 then curx:=xw2; setcursor(1,curx,cury); end; 'M':begin setcursor(1,curx,cury); rotmol(2,-5); curx:=curx+10; if curx>xw2 then curx:=xw1; setcursor(1,curx,cury); end; end; if (cursor=ON) and (curlen=0) then case ch2 of 'P':begin cursordown; shcursorpos; end; 'H':begin cursorup; shcursorpos; end; 'K':begin cursorleft; shcursorpos; end; 'M':begin cursorright;shcursorpos; end; end; case ord(ch2) of 49: begin xfacttext:=2; yfacttext:=2; setcolor(31); textc:=16; i:=100+(924-length(fnm)*18) div 2; outtextxy(i,660,fnm); xfacttext:=1; yfacttext:=1; end; 59: headline(2); 60: begin clock:=on; freemem(sbar,imagesize(0,0,xm1 div 7,dytext)); freemem(mbar,imagesize(0,0,xw1,dytext)); menu; end; 61: if axis=off then begin setcolor(12); line(xm-xw1,yw1*2,xm-xw1,yw1+14); outtextxy(xm-xw1-5,yw1+4,'y'); line(xm-xw1,yw1*2,xm-dytext-14,yw1*2); outtextxy(xm-dytext-12,yw1*2-8,'x'); vect(xm-xw1,yw1*2,7,14,12); outtextxy(xw2-dytext-10,yw1+dytext-2,'z'); axis:=on; end else begin setcolor(0); line(xm-xw1,yw1*2,xm-xw1,yw1+14); outtextxy(xm-xw1-5,yw1+4,'y'); line(xm-xw1,yw1*2,xm-dytext-14,yw1*2); outtextxy(xm-dytext-12,yw1*2-8,'x'); vect(xm-xw1,yw1*2,7,14,0); outtextxy(xw2-dytext-10,yw1+dytext-2,'z'); axis:=off; end; 62: begin for k:=0 to 1 do begin ss:=' '; if k=1 then begin if pos(' ',filenm)>0 then for j:=1 to length(filenm) do begin if ord(filenm[j])>32 then ss[j]:=filenm[j] else begin ss[0]:=chr(j-5); goto L2; end end; if pos(' ',filenm)=0 then begin ss:=filenm; ss[0]:=chr(ord(filenm[0])-4); goto L2; end; end else ss:='tmp'; L2: assign(fx,ss+'.rdt'); rewrite(fx); writeln(fx,na,' ',nb,' ',kk:6:2); for i:=1 to na do writeln(fx,i:4,x[i]:9:4,y[i]:9:4,z[i]:9:4,atom[i]:3,ro[i]:9:4); for i:=1 to nb do begin writeln(fx,f^[i]:4,t^[i]:4); writeln(fx,' ',x1^[i]:4,y1^[i]:4,x2^[i]:4,y2^[i]:4); end; close(fx); assign(fx,ss+'.bdt'); rewrite(fx); for i:=1 to nb do begin writeln(fx,f^[i]:4,t^[i]:4); writeln(fx,' ',ix[f^[i]]:4,iy[f^[i]]:4, ix[t^[i]]:4,iy[t^[i]]:4); end; close(fx); assign(fx,ss+'.idt'); rewrite(fx); for i:=1 to na do writeln(fx,i:4,ix[i]:4,iy[i]:4,iz[i]:4,atom[i]:3,ira[i]:4); sing2; sing2; close(fx); end; clrmsg; outtext('Out files: TMP/'+ss+' + Extention[.RDT,IDT,BDT]. '); end; 63: if clock=on then begin clock:=off; for i:=1 to 15 do _dacrgb(i,0,0,0); end else begin rgb8c(0.2); clock:=on; end; 64:if floaded then begin style:='stick1'; clrwin; display; end; {F6} 65:begin setcolor(15); outtextxy((xw1+xw2) div 2-8*9,yw1*2,'SYSTEM PALETTE'); ixx:=(xw2-xw1) div 32; iyy:=(yw2-yw1) div 12; setcolor(10); for j:=0 to 31 do begin a1:=xw1+j*ixx+5; if mode=$5e then a1:=a1+11; a2:=3*yw1-20; if j<10 then a1:=a1+4; moveto(a1,a2); outint('',j); end; for i:=0 to 7 do for j:=0 to 31 do begin a1:=xw1+j*ixx+5; if mode=$5e then a1:=a1+11; a2:=3*yw1+i*iyy+5; a3:=a1+ixx-5; a4:=a2+iyy-5; k:=i*32+j; bar(a1,a2,a3,a4,k); rectangle(a1,a2,a3,a4,15); end; ch:=readkey; clrwin; end; 66:begin clrwin; dtx:=(xw2-xw1) div 10; dty:=yw1 div 2; for i:=1 to 7 do begin draw_ball_with_filled_ellypse(i,4, 2*xw1+i*dtx,2*yw1,30,20); end; setcolor(8); for i:=0 to 7 do begin line(5*xw1 div 2+i*dtx,3*yw1,5*xw1 div 2+i*dtx,yw2-yw1); end; for i:=0 to 14 do begin line(5*xw1 div 2,3*yw1+i*dty, 5*xw1 div 2 +7 *dtx,3*yw1+i*dty); end; setcolor(15); for i:=1 to 7 do begin j:=5*yw1 div 2+i*dty+dty div 2; outtextxy(2*xw1,j,atomn[i]); outtextxy(2*xw1+dtx*ballc[i],j,'+'); end; ch:=readkey; clrwin; end; 67: begin clrmsg; outtext('coordinate system ( Discarts / Cristal ) ='); setcolor(12); moveto(xmsg,ymsg); getch(' D C ',ch2); if upcase(ch2)='C' then begin clrmsg; end else clrmsg; end; 68: begin clrmsg; outtext('Perspetive with Default / New values ='); moveto(xmsg,ymsg); setcolor(12); getch(' D N ',ch2); if upcase(ch2)='N' then begin clrmsg; get3int('Values of 1/p,1/q,1/r (a41,a42,a43) = ',a1,a2,a3,err); pp:=1/a1; qq:=1/a2; rr:=1/a3; end; perspect:=on; shmol(fnm,model,err); clrmsg; end; 70: begin bar(0,0,xm,ym,2); end; {F12} 71:{home} begin if cmd='M' then moveleft(20) else begin setviewport(xw1,yw1,xw2,yw2,true); clrwin; toleft; display; setviewport(0,0,xm,ym,true); end; end; 79:{end} begin if cmd='M' then moveright(20) else begin setviewport(xw1,yw1,xw2,yw2,true); clrwin; toright; display; setviewport(0,0,xm,ym,true); end; end; 73:{up} begin if cmd='M' then moveup(20) else begin setviewport(xw1,yw1,xw2,yw2,true); clrwin; totop; display; setviewport(0,0,xm,ym,true); end; end; 81:{up} begin if cmd='M' then movedown(20) else begin setviewport(xw1,yw1,xw2,yw2,true); clrwin; tobottom; display; setviewport(0,0,xm,ym,true); end; end; end; end; end; until upcase(ch)='Q'; clrmsg; outtext('Are you sure to quit ? [Y/N] = '); moveto(xmsg,ymsg); setcolor(12); getch(' Y N ',ch); if (ch <>'y') AND (CH<>'Y') then begin clrmsg; goto again; end; freemem(key,sizeof(intlist)); freemem(ordr,sizeof(intlist)); freemem(f,sizeof(int2list)); freemem(f,sizeof(int2list)); freemem(x1,sizeof(int3list)); freemem(y1,sizeof(int3list)); freemem(x2,sizeof(int3list)); freemem(y2,sizeof(int3list)); xfacttext:=2; yfacttext:=2; bar(0,0,xm,ym,0); textc:=15; if keyerr<>0 then killmol4dexe; { showmat((xm-238) div 2-34,ym div 4-24,'c:\dos33\harc.com',4,4); showmat((xm-238) div 2,ym div 4+15,'str2',4,4); } ch:=readkey; setmode(3); clrscr; end. {------------------------------完-------------------------------}