帮我看看这个源代码（http://chemailse.myetang.com/pp2.zip），是从DOS的Pascal转过来的，为什么只能按一次Button1

chemer · 2002-07-14

帮我看看这个源代码（http://chemailse.myetang.com/pp2.zip），是从DOS的Pascal转过来的，为什么只能按一次Button1？ (200分) (200分)<br />ce.pas
Program main;
{$g+}
{$x+}
uses crt,DOS;
{
Version:5.00
Programmer

ick Shao FROM Dick & DARYL Studio Suzhou Middle School Since 1997.
}

const
num=30;
leng=30;
ElementSum=110;
e: array[1..110]of String[3]
=('H','He',
'Li','Be','B','C','N','O','F','Ne',
'Na','Mg','Al','Si','P','S','Cl','Ar',
'K','Ca','Sc','Ti','V','Cr','Mn','Fe','Co','Ni','Cu','Zn','Ga','Ge','As','Se','Br','Kr',
'Rb','Sr','Y','Zr','Nb','Mo','Tc','Ru','Rh','Pd','Ag','Cd','In','Sn','Sb','Te','I','Xe',
'Cs','Ba','La','Ce','Pr','Nd','Pm','Sm','Eu','Gd','Tb','Dy','Ho','Er','Tm','Yb','Lu',
'Hf','Ta','W','Re','Os','Ir','Pt','Au','Hg','Tl','Pb','Bi','Po','At','Rn',
'Fr','Ra','Ac','Th','Pa','U','Np','Pu','Am','Cm','Bk','Cf','Es','Fm','Md','No','Lr','Rf','Ha',
'Unh','Uns','Uno','Une','E');

type
equationtype=array[0..num,0..leng]of longint;

var
enumber:byte;
eline:array[1..num]of byte;
equation:equationtype;
matnumber:byte;
s,l,r,L2,R2:string;
a,b:integer;
err:boolean;

{$i solvepoc.pas}
{$i setfont.pas}
{$i fntreset.pas}

procedure SayGoodBye;
begin
textcolor(lightred);
writeln;
writeln(' Thank you for using!');
textcolor(lightgreen);
Writeln(' If you like our program, please write to us! ');
writeln(' Name: Dick Shao or DARYL Wu');
writeln(' Address: Class 2 Senior 2');
writeln(' Suzhou Middle School ');
writeln(' Jiangsu Province ');
writeln(' PostCode: 215000');
textcolor(lightgray);
writeln;
FontReset;
end;

procedure init;
begin
matnumber:=0;
enumber:=0;
fillchar(equation,sizeof(equation),0);
end;

function inttostr(a:integer):string;
var
temp:string;
begin
str(a,temp);
inttostr:=temp;
end;

procedure killbrackets(var d:string);
var
i,j,k,l,m,n,q,r:integer;
temp:string;
begin
i:=pos(')',d);
while i>0 do
begin
j:=i-1;
while (j>0) and (d[j]<>'(') do dec(j);
if j=0 then writeln(' Brackets error! ');
temp:=copy(d,i+1,length(d)-i);
r:=1;
while temp[r] in ['0'..'9'] do inc(r);
temp[0]:=chr(r-1) ;
if r>1 then val(temp,l,m)
else l:=1;
k:=j;
d:=copy(d,1,j-1)+copy(d,j+1,length(d)-j);
while d[k]<>')' do
begin
if d[k+1] in ['a'..'z'] then inc(k);
temp:=copy(d,k+1,length(d)-k);
m:=1;
while temp[m] in ['0'..'9'] do inc(m);
temp[0]:=chr(m-1);
if m>1 then begin
val(temp,n,q);
end
else n:=1;
n:=n*l;
d:=copy(d,1,k)+inttostr

+copy(d,k+m,length(d)-k-m+1);
k:=k+length(inttostr

)+1;
end;
d:=copy(d,1,k-1)+copy(d,k+r,length(d)-k-r+1);
i:=pos(')',d);
end;
end;

procedure getone(var s:string;left:boolean);
var
i,j,k,start:integer;
n:string;
enow:string[2];
num:string;
minus:boolean;
begin
i:=pos('+',s);
if (i<length(s)) and (s[i+1]='+') then inc(i);
if i=0 then begin
n:=s;
s:='';
end
else begin
n:=copy(s,1,i-1);
s:=copy(s,i+1,length(s)-i);
end;
inc(matnumber);
repeat
enow:=copy(n,1,2);
if not (enow[2] in ['a'..'z']) then begin
enow[0]:=chr(1);
n:=copy(n,2,length

-1);
end
else n:=copy(n,3,length

-2);
if n<>'' then begin
start:=1;
minus:=false;
if enow='E' then
begin
if (n[1]='+') or (n[1]='-') then start:=2;
minus:=(n[1]='-');
end;
i:=start;
while (length

>=i) and (n in ['0'..'9'])
do inc(i);
dec(i);
if i>start-1 then begin
num:=copy(n,start,i);
n:=copy(n,i+1,length-i);
val(num,j,k);
if k>0 then writeln('Syntax error!!!');
end
else j:=1;
if enow='E' then
begin
minus:=(n[1]='-');
n:='';
end;
i:=start;
if minus then j:=-j;
end
else j:=1;
k:=0;
repeat
inc(k);

until (k>ElementSum) or (e[k]=enow);
if k>ElementSum then
begin
writeln('Unrecognized element: ',enow);
err:=true;
exit;
end
else begin
i:=0;
repeat
inc(i);
until (i>enumber) or (eline=k);
if i>enumber then begin
enumber:=i;
eline:=k;
end;
if left then inc(equation[i,matnumber],j)
else dec(equation[i,matnumber],j);
end;
until n='';
end;

Begin
FontReset;
SetFont;
init;
clrscr;
writeln;
writeln;
textcolor(lightgreen);
writeln(' CHEMISTRY EQUATION V5.00');
textcolor(14);
writeln;
writeln(' Copyright 1997 ');
writeln(' Dick & DARYL Studio Since 1997');
writeln(' Class 2 Senior 2 Suzhou Middle School ');
writeln(' Program by Dick Shao & DARYL Wu');
writeln;
textcolor(lightgray);
writeln;
writeln(' Example: Fe + HNO3 = Fe(NO3)3 + N2O + H2O');
writeln(' Fe + HE+ +NO3E- = FeE3+ + N2O + H2O');
writeln(' E means electron.');
writeln(' See readme file for more information');
WRITELN;
writeln(' Please input the equation: ');
assign(input,'');
reset(input);
readln(s);
repeat
a:=pos(' ',s);
if a>0 then s:=copy(s,1,a-1)+copy(s,a+1,length(s)-a);
until a=0;
a:=pos('=',s);
if a=0 then begin
writeln('''='' not found!');
writeln('Press any key to exit...');
readkey;
SayGoodBye;
exit;
end;
l2:=copy(s,1,a-1);
r2:=copy(s,a+1,length(s)-a);
killbrackets(s);
a:=pos('=',s);
{
if pos('*',s)>0 then
writeln(' Warning: I don''t know which element your ''*'' means because Element 107,108,109 are all called ''*'' ! ');
}
l:=copy(s,1,a-1);
r:=copy(s,a+1,length(s)-a);
if l='' then begin
writeln(' Warning: Left side empty!');
SayGoodBye;
exit;
end;
if r='' then begin
writeln(' Warning: Right side empty!');
SayGoodBye;
exit;
end;
err:=false;
while l<>'' do begin
getone(l,true);
if err then begin
SayGoodBye;
exit;
end;
end;
while r<>'' do begin
getone(r,false);
if err then begin
SayGoodBye;
exit;
end;
end;
solvetest(equation,enumber,matnumber);
b:=0;
a:=1;
while l2<>'' do
begin
textcolor(lightred);
write(equation[0,a]);
textcolor(lightgray);
b:=pos('+',l2);
if (length(l2)>b) and (l2[b+1]='+') then inc(b);
if b=0 then begin
write(l2);
l2:='';
end
else begin
write(copy(l2,1,b-1));
l2:=copy(l2,b+1,length(l2)-b);
end;
if l2<>'' then write(' + ');
inc(a);
end;
textcolor(lightgreen);
write(' = ');
while r2<>'' do
begin
textcolor(lightred);
write(equation[0,a]);
textcolor(lightgray);
b:=pos('+',r2);
if (length(R2)>b) and (R2[b+1]='+') then inc(b);
if b=0 then begin
write(r2);
r2:='';
end
else begin
write(copy(r2,1,b-1));
r2:=copy(r2,b+1,length(r2)-b);
end;
if r2<>'' then write(' + ');
inc(a);
end;
writeln;
readkey;
SayGoodBye;
end.

---------------------------------------------
solvepoc.pas

procedure solvetest(var equation:equationtype;enum,mnum:byte);
{PROGRAMMER: DICK SHAO FROM Dick & DARYL Studio since 1997
DATE: 97/07/11
}
const
max=300;
no_answer=1;
not_q=2;

{type
equationtype=array[0..num,0..leng]of longint;
}
var
err:byte;
next:boolean;
e:equationtype;
i,j:longint;
t:array[1..512]of word;
b:boolean;

procedure sett;
var p,i,j,pt:word;
b:boolean;
begin
t[1]:=2;
t[2]:=3;
t[3]:=5;
t[4]:=7;
p:=11;
i:=5;
while i<512+1 do
begin
b:=true;
j:=p;
pt:=1;
while j>0 do
asm
shr j,2
shl pt,1
end;

j:=1;
while b and (j<i) and (t[j]<pt) do
begin
b:=(p mod t[j]<>0);
inc(j);
end;
if b then begin
t:=p;
inc(i);
end;
inc(p);
end;
end;

function minpublic(a1,a2:longint):longint;
var
mt:array[1..2,1..512]of byte;
a:array[1..2]of word;
i,j,k,temp:longint;
begin
fillchar(mt,sizeof(mt),0);
if (a1=0) or (a2=0) then begin
minpublic:=0;
exit;
end;
a[1]:=abs(a1);
a[2]:=abs(a2);
for k:=1 to 2 do
begin
i:=1;
j:=1;
while a[k]>1 do
begin
if a[k] mod t[j]=0 then begin
inc(mt[k,j]);
a[k]:=a[k] div t[j];
end
else inc(j);
if j=257 then writeln('Program overflow!!!',^g);
end;
end;
temp:=1;
for k:=1 to 512 do
begin
if mt[1,k]<mt[2,k] then j:=mt[2,k]
else j:=mt[1,k];
for i:=1 to j do
temp:=temp*t[k];
end;
minpublic:=temp;
end;

function maxpublic(a1,a2:longint):longint;
var
mt:array[1..2,1..512]of byte;
a:array[1..2]of longint;
i,j,k,temp:longint;
begin
fillchar(mt,sizeof(mt),0);
if a1=0 then begin
maxpublic:=a2;
exit;
end;
if a2=0 then begin
maxpublic:=a1;
exit;
end;

a[1]:=abs(a1);
a[2]:=abs(a2);
for k:=1 to 2 do
begin
i:=1;
j:=1;
while a[k]>1 do
begin
if a[k] mod t[j]=0 then begin
inc(mt[k,j]);
a[k]:=a[k] div t[j];
end
else inc(j);
if j=257 then writeln('Program overflow!!!',^g);
end;
end;
temp:=1;
for k:=1 to 512 do
begin
if mt[1,k]<mt[2,k] then j:=mt[1,k]
else j:=mt[2,k];
for i:=1 to j do
temp:=temp*t[k];
end;
maxpublic:=temp;
end;

procedure solve(var a:equationtype;ln,xn:byte);
label step2;
type
knowntype=array[0..leng]of boolean;
donetype=array[0..num]of boolean;
var
known:knowntype;
nz:array[1..num]of byte;
done:donetype;
fit:array[1..num]of boolean;
last:array[1..num]of byte;
mainlast,mainfirst:byte;
i,j,h,lp,sp,temp,temp2,spt:longint;
m:longint;
k1,k2:longint;
changed:boolean;
line1,line2:array[0..leng]of longint;
c:^equationtype;

procedure easy(var a:equationtype);forward;
procedure getkey(var a:equationtype);
var lp:byte;known2:knowntype;
begin
known2:=known; for lp:=1 to ln do
if (not done[lp]) and (nz[lp]=1) then
begin
temp:=a[lp,0] div a[lp,last[lp]];
if temp*a[lp,last[lp]]<>a[lp,0] then begin
err:=not_q;
exit;
end;
if known2[last[lp]] and (a[0,last[lp]]<>temp) then
begin
err:=no_answer;
exit;
end;
known2[last[lp]]:=true;
done[lp]:=true;
a[0,last[lp]]:=temp;
end;
known:=known2; done[0]:=true;
for lp:=1 to ln do done[0]:=done[0] and done[lp];
end;

procedure cal(var d:equationtype);
var
i,j:integer;

begin
for i:=1 to xn do
if known then for j:=1 to ln do
begin
d[j,0]:=d[j,0]-d[j,i]*d[0,i];
d[j,i]:=0;
end;

end;

procedure stepon;
label next;
var i,j,g:integer;
done1:donetype;
begin
i:=1;
while (i<=xn) and (known) do inc(i);
if i>xn then exit;
g:=a[0,i];
done1:=done;
repeat
next: known:=true;
inc(g);
c^:=a;
c^[0,i]:=g;
cal(c^);
easy(c^);
if err<>0 then begin
done:=done1;
goto next;
end;
getkey(c^);
if (done[0]) then begin
for j:=1 to xn do
a[0,j]:=c^[0,j];
err:=0;
exit;
end;
if err=0 then stepon;
if g>max then begin
err:=no_answer;
exit;
end;
done:=done1;
until false;
end;

procedure easy(var a:equationtype);
var i,j,h,lp,sp,m:integer;
begin
mainlast:=xn;
temp:=0;
while (temp<2) and (mainlast>0) do
begin
temp:=0;
for i:=1 to ln do if a[i,mainlast]<>0 then inc(temp);
if temp<2 then dec(mainlast);
end;
for lp:=1 to ln do
begin
m:=maxpublic(a[lp,0],a[lp,1]);
for h:=2 to xn do
m:=maxpublic(m,a[lp,h]);
if a[lp,0]<0 then m:=-m;
if m<>0 then for h:= 0 to xn do
a[lp,h]:=a[lp,h] div m;
end;
for i:=1 to ln do
begin
temp:=xn;
for j:=1 to xn do
if a[i,j]=0 then dec(temp);
nz:=temp;
j:=xn;
while (a[i,j]=0) and (j>0) do dec(j);
if j=0 then if a[i,0]=0 then begin
done:=true
end
else begin
err:=no_answer;
exit;
end;
last:=j;

end;

if mainlast>0 then
begin
changed:=true;
while changed do
begin
changed:=false;
for lp:=1 to ln do
if not done[lp] then
{for sp:=1 to ln do
if (not done[lp]) and (lp<>sp) then}
{for i:=xn downto 1 do}
begin
temp:=0;spt:=0;
for sp:=1 to ln do
begin
m:=mainlast;
while a[lp,m]=0 do dec(m);
fit[sp]:=(lp<>sp) and (not done[sp]) and ((last[lp]=last[sp]) or ((last[lp]>mainlast) and (m=last[sp])));
if fit[sp] then begin
if last[lp]=last[sp] then
begin
temp2:=minpublic(a[lp,last[lp]],a[sp,last[sp]]);
if (temp=0) or ((temp2>0)and(temp2<temp)) then
begin
spt:=sp;
temp:=temp2;
end;
end
else begin
m:=mainlast;
while a[lp,m]=0 do dec(m);
temp2:=minpublic(a[lp,m],a[sp,m]);
if (temp=0) or ((temp2>0)and(temp2<temp)) then
begin
spt:=sp;
temp:=temp2;
end;
end;
end;
end;
if spt>0 then
begin
sp:=spt;
if last[lp]<=mainlast then i:=last[lp]
else begin
i:=mainlast;
while a[lp,i]=0 do dec(i);
end;

{if (a[lp,i]<>0) and (a[sp,i]<>0) then}
begin
for j:=0 to xn do
begin
line1[j]:=a[lp,j];
line2[j]:=a[sp,j];
end;
m:=minpublic(line1,line2);
k1:=m div line1;
k2:=m div line2;
for h:=0 to xn do
begin
line1[h]:=k1*line1[h];
line2[h]:=k2*line2[h];
line2[h]:=line1[h]-line2[h];
end;
temp:=xn;
for h:=1 to xn do
if line2[h]=0 then dec(temp);
{if temp<nz[lp] then
begin
changed:=true;
for h:=0 to xn do
a[lp,h]:=line2[h];
nz[lp]:=temp;
if temp=0 then if line2[0]=0 then done[lp]:=true
else begin
err:=no_answer;
exit;
end;
end
else} begin
h:=mainlast+1;
repeat
dec(h);
until (line1[h]=0) xor (line2[h]=0);
if line2[h]=0 then
begin
changed:=true;
for h:=0 to xn do
a[lp,h]:=line2[h];
nz[lp]:=temp;
if temp=0 then if line2[0]=0 then done[lp]:=true
else begin
err:=no_answer;
exit;
end;
h:=last[lp];
while (a[lp,h]=0) and (h>0) do dec(h);
last[lp]:=h;
m:=maxpublic(a[lp,0],a[lp,1]);
for h:=2 to xn do
m:=maxpublic(m,a[lp,h]);
if a[lp,0]<0 then m:=-m;
if m<>0 then for h:= 0 to xn do
a[lp,h]:=a[lp,h] div m;
temp:=0;
while (temp<2) and (mainlast>0) do
begin
temp:=0;
for h:=1 to ln do if a[h,mainlast]<>0 then inc(temp);
if temp<2 then dec(mainlast);
end;
if mainlast=0 then begin
err:=0;
exit;
end;
end;
end;
end;
end;
end;
end;
end;
err:=0;
end;

begin
step2:
for i:=1 to ln do done:=false;
for i:=1 to xn do known:=false;
easy(a);
getkey(a);
if (done[0]) or (err<>0) then exit;
new(c);
c^:=a;
stepon;
exit;
dispose(c);

end;

BEGIN
sett;
err:=0;
SOLVE(equation,enum,mnum);
if err>0 then writeLN('Error ',err);
b:=true;
for err:=1 to matnumber do
b:=b and (equation[0,err]=0);
if b then begin
SOLVE(EQUATION,ENUM,MNUM);
for err:=1 to matnumber do
b:=b and (equation[0,err]=0);
if b then writeln(' I can''t work it out!');
end;
END;

----------------------------------------------
fntreset.pas
procedure FontReset;
var r:registers;
begin
r.ah:=$11;
r.al:=4;
r.bl:=3;
intr($10,r);
end;

-----------------------------------------------------
setfont.pas

procedure SetFont;
const numberfont:array[1..160]of byte=
(0,0,0,0,0,0,0,0,0,60,102,102,102,102,102,60,
0,0,0,0,0,0,0,0,0,24,56,24,24,24,24,126,
0,0,0,0,0,0,0,0,0,56,108,12,24,48,100,124,
0,0,0,0,0,0,0,0,0,60,102,6,24,6,102,60,
0,0,0,0,0,0,0,0,0,12,28,44,76,126,12,30,
0,0,0,0,0,0,0,0,0,124,96,96,124,6,70,60,
0,0,0,0,0,0,0,0,0,60,96,96,124,102,102,60,
0,0,0,0,0,0,0,0,0,126,6,6,12,24,24,24,
0,0,0,0,0,0,0,0,0,60,102,102,60,102,102,60,
0,0,0,0,0,0,0,0,0,60,102,102,60,12,24,48);
var r:registers;
begin
r.ah:=$11;
r.al:=0;
r.bh:=16;{bytes per character}
r.bl:=3;
r.cx:=10;{number of characters}
r.dx:=48;
r.es:=Seg(numberfont);
r.bp:=Ofs(numberfont);
intr($10,r);
r.ah:=$11;
r.al:=3;
r.bl:=3;
intr($10,r);
end;

感谢

chemer · 2002-07-14

再加100分

小黄鱼 · 2002-07-14

也不写注释，天呀

xf-wangyi · 2002-07-14

头大了，要看一段时间[

]

chemer · 2002-07-14

关键是有一部分语句，我根本就不知道是什么意思，看来Pascal和Object Pascal区别还是
比较大的。到目前为止，只明白writeln和textcolor。我也曾经试过将其代码一段段导入
到Delphi中，可是有一些我看上去明明是对的，但就是不能变异。

chemer · 2002-07-15

提前一下

张无忌 · 2002-07-15

其实只要主算法正确就没有问题了，其他的颜色方面就必那么认真了

BeginDelphi · 2002-07-15

呵呵！有意思，我来试试。

tseug · 2002-07-15

我简单的改了一下, 可以运行, 但我没有试怎么用, 另外说明一下:
我把SetFont 和 FontReset给处理了以下，因为这两个过程实际上引用了
软中断INT 10h, 用来动态加载自定义字体。textColor是用来设置字符颜色的
给注释掉了，还有ReadKey我用ReadLn替换了。

program Project1;

{$APPTYPE CONSOLE}
{$g+}
{$x+}
{$H-}

uses
SysUtils;
{
Version:5.00
Programmer

ick Shao FROM Dick & DARYL Studio Suzhou Middle School Since 1997.
}

const
num=30;
leng=30;
ElementSum=110;
e: array[1..110]of String[3]
=('H','He',
'Li','Be','B','C','N','O','F','Ne',
'Na','Mg','Al','Si','P','S','Cl','Ar',
'K','Ca','Sc','Ti','V','Cr','Mn','Fe','Co','Ni','Cu','Zn','Ga','Ge','As','Se','Br','Kr',
'Rb','Sr','Y','Zr','Nb','Mo','Tc','Ru','Rh','Pd','Ag','Cd','In','Sn','Sb','Te','I','Xe',
'Cs','Ba','La','Ce','Pr','Nd','Pm','Sm','Eu','Gd','Tb','Dy','Ho','Er','Tm','Yb','Lu',
'Hf','Ta','W','Re','Os','Ir','Pt','Au','Hg','Tl','Pb','Bi','Po','At','Rn',
'Fr','Ra','Ac','Th','Pa','U','Np','Pu','Am','Cm','Bk','Cf','Es','Fm','Md','No','Lr','Rf','Ha',
'Unh','Uns','Uno','Une','E');

type
equationtype=array[0..num,0..leng]of longint;

var
enumber:byte;
eline:array[1..num]of byte;
equation:equationtype;
matnumber:byte;
s,l,r,L2,R2:string;
a,b:integer;
err:boolean;
procedure FontReset;
begin
end;

procedure SetFont;
const numberfont:array[1..160]of byte=
(0,0,0,0,0,0,0,0,0,60,102,102,102,102,102,60,
0,0,0,0,0,0,0,0,0,24,56,24,24,24,24,126,
0,0,0,0,0,0,0,0,0,56,108,12,24,48,100,124,
0,0,0,0,0,0,0,0,0,60,102,6,24,6,102,60,
0,0,0,0,0,0,0,0,0,12,28,44,76,126,12,30,
0,0,0,0,0,0,0,0,0,124,96,96,124,6,70,60,
0,0,0,0,0,0,0,0,0,60,96,96,124,102,102,60,
0,0,0,0,0,0,0,0,0,126,6,6,12,24,24,24,
0,0,0,0,0,0,0,0,0,60,102,102,60,102,102,60,
0,0,0,0,0,0,0,0,0,60,102,102,60,12,24,48);
begin
end;

procedure solvetest(var equation:equationtype;enum,mnum:byte);
{PROGRAMMER: DICK SHAO FROM Dick & DARYL Studio since 1997
DATE: 97/07/11
}
const
max=300;
no_answer=1;
not_q=2;

{type
equationtype=array[0..num,0..leng]of longint;
}
var
err:byte;
next:boolean;
e:equationtype;
i,j:longint;
t:array[1..512]of word;
b:boolean;

procedure sett;
var p,i,j,pt:word;
b:boolean;
begin
t[1]:=2;
t[2]:=3;
t[3]:=5;
t[4]:=7;
p:=11;
i:=5;
while i<512+1 do
begin
b:=true;
j:=p;
pt:=1;
while j>0 do
asm
shr j,2
shl pt,1
end;

j:=1;
while b and (j<i) and (t[j]<pt) do
begin
b:=(p mod t[j]<>0);
inc(j);
end;
if b then begin
t:=p;
inc(i);
end;
inc(p);
end;
end;

function minpublic(a1,a2:longint):longint;
var
mt:array[1..2,1..512]of byte;
a:array[1..2]of word;
i,j,k,temp:longint;
begin
fillchar(mt,sizeof(mt),0);
if (a1=0) or (a2=0) then begin
minpublic:=0;
exit;
end;
a[1]:=abs(a1);
a[2]:=abs(a2);
for k:=1 to 2 do
begin
i:=1;
j:=1;
while a[k]>1 do
begin
if a[k] mod t[j]=0 then begin
inc(mt[k,j]);
a[k]:=a[k] div t[j];
end
else inc(j);
if j=257 then writeln('Program overflow!!!',^g);
end;
end;
temp:=1;
for k:=1 to 512 do
begin
if mt[1,k]<mt[2,k] then j:=mt[2,k]
else j:=mt[1,k];
for i:=1 to j do
temp:=temp*t[k];
end;
minpublic:=temp;
end;

function maxpublic(a1,a2:longint):longint;
var
mt:array[1..2,1..512]of byte;
a:array[1..2]of longint;
i,j,k,temp:longint;
begin
fillchar(mt,sizeof(mt),0);
if a1=0 then begin
maxpublic:=a2;
exit;
end;
if a2=0 then begin
maxpublic:=a1;
exit;
end;

a[1]:=abs(a1);
a[2]:=abs(a2);
for k:=1 to 2 do
begin
i:=1;
j:=1;
while a[k]>1 do
begin
if a[k] mod t[j]=0 then begin
inc(mt[k,j]);
a[k]:=a[k] div t[j];
end
else inc(j);
if j=257 then writeln('Program overflow!!!',^g);
end;
end;
temp:=1;
for k:=1 to 512 do
begin
if mt[1,k]<mt[2,k] then j:=mt[1,k]
else j:=mt[2,k];
for i:=1 to j do
temp:=temp*t[k];
end;
maxpublic:=temp;
end;

procedure solve(var a:equationtype;ln,xn:byte);
label step2;
type
knowntype=array[0..leng]of boolean;
donetype=array[0..num]of boolean;
var
known:knowntype;
nz:array[1..num]of byte;
done:donetype;
fit:array[1..num]of boolean;
last:array[1..num]of byte;
mainlast,mainfirst:byte;
i,j,h,lp,sp,temp,temp2,spt:longint;
m:longint;
k1,k2:longint;
changed:boolean;
line1,line2:array[0..leng]of longint;
c:^equationtype;

procedure easy(var a:equationtype);forward;
procedure getkey(var a:equationtype);
var lp:byte;known2:knowntype;
begin
known2:=known; for lp:=1 to ln do
if (not done[lp]) and (nz[lp]=1) then
begin
temp:=a[lp,0] div a[lp,last[lp]];
if temp*a[lp,last[lp]]<>a[lp,0] then begin
err:=not_q;
exit;
end;
if known2[last[lp]] and (a[0,last[lp]]<>temp) then
begin
err:=no_answer;
exit;
end;
known2[last[lp]]:=true;
done[lp]:=true;
a[0,last[lp]]:=temp;
end;
known:=known2; done[0]:=true;
for lp:=1 to ln do done[0]:=done[0] and done[lp];
end;

procedure cal(var d:equationtype);
var
i,j:integer;

begin
for i:=1 to xn do
if known then for j:=1 to ln do
begin
d[j,0]:=d[j,0]-d[j,i]*d[0,i];
d[j,i]:=0;
end;

end;

procedure stepon;
label next;
var i,j,g:integer;
done1:donetype;
begin
i:=1;
while (i<=xn) and (known) do inc(i);
if i>xn then exit;
g:=a[0,i];
done1:=done;
repeat
next: known:=true;
inc(g);
c^:=a;
c^[0,i]:=g;
cal(c^);
easy(c^);
if err<>0 then begin
done:=done1;
goto next;
end;
getkey(c^);
if (done[0]) then begin
for j:=1 to xn do
a[0,j]:=c^[0,j];
err:=0;
exit;
end;
if err=0 then stepon;
if g>max then begin
err:=no_answer;
exit;
end;
done:=done1;
until false;
end;

procedure easy(var a:equationtype);
var i,j,h,lp,sp,m:integer;
begin
mainlast:=xn;
temp:=0;
while (temp<2) and (mainlast>0) do
begin
temp:=0;
for i:=1 to ln do if a[i,mainlast]<>0 then inc(temp);
if temp<2 then dec(mainlast);
end;
for lp:=1 to ln do
begin
m:=maxpublic(a[lp,0],a[lp,1]);
for h:=2 to xn do
m:=maxpublic(m,a[lp,h]);
if a[lp,0]<0 then m:=-m;
if m<>0 then for h:= 0 to xn do
a[lp,h]:=a[lp,h] div m;
end;
for i:=1 to ln do
begin
temp:=xn;
for j:=1 to xn do
if a[i,j]=0 then dec(temp);
nz:=temp;
j:=xn;
while (a[i,j]=0) and (j>0) do dec(j);
if j=0 then if a[i,0]=0 then begin
done:=true
end
else begin
err:=no_answer;
exit;
end;
last:=j;

end;

if mainlast>0 then
begin
changed:=true;
while changed do
begin
changed:=false;
for lp:=1 to ln do
if not done[lp] then
{for sp:=1 to ln do
if (not done[lp]) and (lp<>sp) then}
{for i:=xn downto 1 do}
begin
temp:=0;spt:=0;
for sp:=1 to ln do
begin
m:=mainlast;
while a[lp,m]=0 do dec(m);
fit[sp]:=(lp<>sp) and (not done[sp]) and ((last[lp]=last[sp]) or ((last[lp]>mainlast) and (m=last[sp])));
if fit[sp] then begin
if last[lp]=last[sp] then
begin
temp2:=minpublic(a[lp,last[lp]],a[sp,last[sp]]);
if (temp=0) or ((temp2>0)and(temp2<temp)) then
begin
spt:=sp;
temp:=temp2;
end;
end
else begin
m:=mainlast;
while a[lp,m]=0 do dec(m);
temp2:=minpublic(a[lp,m],a[sp,m]);
if (temp=0) or ((temp2>0)and(temp2<temp)) then
begin
spt:=sp;
temp:=temp2;
end;
end;
end;
end;
if spt>0 then
begin
sp:=spt;
if last[lp]<=mainlast then i:=last[lp]
else begin
i:=mainlast;
while a[lp,i]=0 do dec(i);
end;

{if (a[lp,i]<>0) and (a[sp,i]<>0) then}
begin
for j:=0 to xn do
begin
line1[j]:=a[lp,j];
line2[j]:=a[sp,j];
end;
m:=minpublic(line1,line2);
k1:=m div line1;
k2:=m div line2;
for h:=0 to xn do
begin
line1[h]:=k1*line1[h];
line2[h]:=k2*line2[h];
line2[h]:=line1[h]-line2[h];
end;
temp:=xn;
for h:=1 to xn do
if line2[h]=0 then dec(temp);
{if temp<nz[lp] then
begin
changed:=true;
for h:=0 to xn do
a[lp,h]:=line2[h];
nz[lp]:=temp;
if temp=0 then if line2[0]=0 then done[lp]:=true
else begin
err:=no_answer;
exit;
end;
end
else} begin
h:=mainlast+1;
repeat
dec(h);
until (line1[h]=0) xor (line2[h]=0);
if line2[h]=0 then
begin
changed:=true;
for h:=0 to xn do
a[lp,h]:=line2[h];
nz[lp]:=temp;
if temp=0 then if line2[0]=0 then done[lp]:=true
else begin
err:=no_answer;
exit;
end;
h:=last[lp];
while (a[lp,h]=0) and (h>0) do dec(h);
last[lp]:=h;
m:=maxpublic(a[lp,0],a[lp,1]);
for h:=2 to xn do
m:=maxpublic(m,a[lp,h]);
if a[lp,0]<0 then m:=-m;
if m<>0 then for h:= 0 to xn do
a[lp,h]:=a[lp,h] div m;
temp:=0;
while (temp<2) and (mainlast>0) do
begin
temp:=0;
for h:=1 to ln do if a[h,mainlast]<>0 then inc(temp);
if temp<2 then dec(mainlast);
end;
if mainlast=0 then begin
err:=0;
exit;
end;
end;
end;
end;
end;
end;
end;
end;
err:=0;
end;

begin
step2:
for i:=1 to ln do done:=false;
for i:=1 to xn do known:=false;
easy(a);
getkey(a);
if (done[0]) or (err<>0) then exit;
new(c);
c^:=a;
stepon;
exit;
dispose(c);

end;

BEGIN
sett;
err:=0;
SOLVE(equation,enum,mnum);
if err>0 then writeLN('Error ',err);
b:=true;
for err:=1 to matnumber do
b:=b and (equation[0,err]=0);
if b then begin
SOLVE(EQUATION,ENUM,MNUM);
for err:=1 to matnumber do
b:=b and (equation[0,err]=0);
if b then writeln(' I can''t work it out!');
end;
END;

procedure SayGoodBye;
begin
// textcolor(lightred);
writeln;
writeln(' Thank you for using!');
// textcolor(lightgreen);
Writeln(' If you like our program, please write to us! ');
writeln(' Name: Dick Shao or DARYL Wu');
writeln(' Address: Class 2 Senior 2');
writeln(' Suzhou Middle School ');
writeln(' Jiangsu Province ');
writeln(' PostCode: 215000');
// textcolor(lightgray);
writeln;
FontReset;
end;

procedure init;
begin
matnumber:=0;
enumber:=0;
fillchar(equation,sizeof(equation),0);
end;

function inttostr(a:integer):string;
var
temp:string;
begin
str(a,temp);
inttostr:=temp;
end;

procedure killbrackets(var d:string);
var
i,j,k,l,m,n,q,r:integer;
temp:string;
begin
i:=pos(')',d);
while i>0 do
begin
j:=i-1;
while (j>0) and (d[j]<>'(') do dec(j);
if j=0 then writeln(' Brackets error! ');
temp:=copy(d,i+1,length(d)-i);
r:=1;
while temp[r] in ['0'..'9'] do inc(r);
temp[0]:=chr(r-1) ;
if r>1 then val(temp,l,m)
else l:=1;
k:=j;
d:=copy(d,1,j-1)+copy(d,j+1,length(d)-j);
while d[k]<>')' do
begin
if d[k+1] in ['a'..'z'] then inc(k);
temp:=copy(d,k+1,length(d)-k);
m:=1;
while temp[m] in ['0'..'9'] do inc(m);
temp[0]:=chr(m-1);
if m>1 then begin
val(temp,n,q);
end
else n:=1;
n:=n*l;
d:=copy(d,1,k)+inttostr+copy(d,k+m,length(d)-k-m+1);
k:=k+length(inttostr)+1;
end;
d:=copy(d,1,k-1)+copy(d,k+r,length(d)-k-r+1);
i:=pos(')',d);
end;
end;

procedure getone(var s:string;left:boolean);
var
i,j,k,start:integer;
n:string;
enow:string[2];
num:string;
minus:boolean;
begin
i:=pos('+',s);
if (i<length(s)) and (s[i+1]='+') then inc(i);
if i=0 then begin
n:=s;
s:='';
end
else begin
n:=copy(s,1,i-1);
s:=copy(s,i+1,length(s)-i);
end;
inc(matnumber);
repeat
enow:=copy(n,1,2);
if not (enow[2] in ['a'..'z']) then begin
enow[0]:=chr(1);
n:=copy(n,2,length-1);
end
else n:=copy(n,3,length-2);
if n<>'' then begin
start:=1;
minus:=false;
if enow='E' then
begin
if (n[1]='+') or (n[1]='-') then start:=2;
minus:=(n[1]='-');
end;
i:=start;
while (length>=i) and (n in ['0'..'9'])
do inc(i);
dec(i);
if i>start-1 then begin
num:=copy(n,start,i);
n:=copy(n,i+1,length-i);
val(num,j,k);
if k>0 then writeln('Syntax error!!!');
end
else j:=1;
if enow='E' then
begin
minus:=(n[1]='-');
n:='';
end;
i:=start;
if minus then j:=-j;
end
else j:=1;
k:=0;
repeat
inc(k);

until (k>ElementSum) or (e[k]=enow);
if k>ElementSum then
begin
writeln('Unrecognized element: ',enow);
err:=true;
exit;
end
else begin
i:=0;
repeat
inc(i);
until (i>enumber) or (eline=k);
if i>enumber then begin
enumber:=i;
eline:=k;
end;
if left then inc(equation[i,matnumber],j)
else dec(equation[i,matnumber],j);
end;
until n='';
end;

Begin
FontReset;
SetFont;
init;
// clrscr;
writeln;
writeln;
// textcolor(lightgreen);
writeln(' CHEMISTRY EQUATION V5.00');
// textcolor(14);
writeln;
writeln(' Copyright 1997 ');
writeln(' Dick & DARYL Studio Since 1997');
writeln(' Class 2 Senior 2 Suzhou Middle School ');
writeln(' Program by Dick Shao & DARYL Wu');
writeln;
// textcolor(lightgray);
writeln;
writeln(' Example: Fe + HNO3 = Fe(NO3)3 + N2O + H2O');
writeln(' Fe + HE+ +NO3E- = FeE3+ + N2O + H2O');
writeln(' E means electron.');
writeln(' See readme file for more information');
WRITELN;
writeln(' Please input the equation: ');
assign(input,'');
reset(input);
readln(s);
repeat
a:=pos(' ',s);
if a>0 then s:=copy(s,1,a-1)+copy(s,a+1,length(s)-a);
until a=0;
a:=pos('=',s);
if a=0 then begin
writeln('''='' not found!');
writeln('Press any key to exit...');
ReadLn;
SayGoodBye;
exit;
end;
l2:=copy(s,1,a-1);
r2:=copy(s,a+1,length(s)-a);
killbrackets(s);
a:=pos('=',s);
{
if pos('*',s)>0 then
writeln(' Warning: I don''t know which element your ''*'' means because Element 107,108,109 are all called ''*'' ! ');
}
l:=copy(s,1,a-1);
r:=copy(s,a+1,length(s)-a);
if l='' then begin
writeln(' Warning: Left side empty!');
SayGoodBye;
exit;
end;
if r='' then begin
writeln(' Warning: Right side empty!');
SayGoodBye;
exit;
end;
err:=false;
while l<>'' do begin
getone(l,true);
if err then begin
SayGoodBye;
exit;
end;
end;
while r<>'' do begin
getone(r,false);
if err then begin
SayGoodBye;
exit;
end;
end;
solvetest(equation,enumber,matnumber);
b:=0;
a:=1;
while l2<>'' do
begin
// textcolor(lightred);
write(equation[0,a]);
// textcolor(lightgray);
b:=pos('+',l2);
if (length(l2)>b) and (l2[b+1]='+') then inc(b);
if b=0 then begin
write(l2);
l2:='';
end
else begin
write(copy(l2,1,b-1));
l2:=copy(l2,b+1,length(l2)-b);
end;
if l2<>'' then write(' + ');
inc(a);
end;
// textcolor(lightgreen);
write(' = ');
while r2<>'' do
begin
// textcolor(lightred);
write(equation[0,a]);
// textcolor(lightgray);
b:=pos('+',r2);
if (length(R2)>b) and (R2[b+1]='+') then inc(b);
if b=0 then begin
write(r2);
r2:='';
end
else begin
write(copy(r2,1,b-1));
r2:=copy(r2,b+1,length(r2)-b);
end;
if r2<>'' then write(' + ');
inc(a);
end;
writeln;
ReadLn;
SayGoodBye;
end.

chemer · 2002-07-15

太棒了！！！就是天才！谢谢你
这好像是一个控制台程序，能否让它变为Form呢？

tseug · 2002-07-15

很抱歉, 正在项目开发中, 如果手头没有事情的话, 我就改成GUI的了[

]

chemer · 2002-07-15

tseug:能否告诉我一些控制台转GUI的技巧？

tseug · 2002-07-15

没有什么特别的技巧, 一般只要注意MSDOS和WIN平台的区别, 还有就是
TP 和 Delphi 在一些数据类型和函数的区别, 当然, 一定要知道原来
代码中每个模块的功能, 如果用到了一的不兼容的代码, 要把它转换为
同样功能的相应代码.

chemer · 2002-07-16

我将readln和writeln等删除，将write换成showmessage，对吗？
运行后，我发现根本就不能配平。还会没有响应，经检查错误就在
procedure solvetest(var equation:equationtype;enum,mnum:byte);这段中？
怎么解决？

chemer · 2002-07-16

chemer · 2002-07-16

这是一个化学方程式配平工具。在edit1中输入没有配平的方程式（CH4 + O2 = CO2 + H2O）
按Button1，在edit2中就会输出配平好的方程式，但奇怪的是，我只能按一次Button1，
若我再重新输入一方程式，按Button1，程序就会没有响应。pp2.zip中有源代码，
请大家帮我分析分析毛病在哪里？

ljsh2008 · 2002-08-05

你们太牛了
向你们学习

酷尔贝塔 · 2002-08-05

哈利波特 · 2002-08-05

头大

帮我看看这个源代码（http://chemailse.myetang.com/pp2.zip），是从DOS的Pascal转过来的，为什么只能按一次Button1

chemer

Unregistered / Unconfirmed

chemer

Unregistered / Unconfirmed

小黄鱼

Unregistered / Unconfirmed

xf-wangyi

Unregistered / Unconfirmed

chemer

Unregistered / Unconfirmed

chemer

Unregistered / Unconfirmed

张无忌

Unregistered / Unconfirmed

BeginDelphi

Unregistered / Unconfirmed

tseug

Unregistered / Unconfirmed

chemer

Unregistered / Unconfirmed

tseug

Unregistered / Unconfirmed

chemer

Unregistered / Unconfirmed

tseug

Unregistered / Unconfirmed

chemer

Unregistered / Unconfirmed

chemer

Unregistered / Unconfirmed

chemer

Unregistered / Unconfirmed

ljsh2008

Unregistered / Unconfirmed

酷尔贝塔

Unregistered / Unconfirmed

哈利波特

Unregistered / Unconfirmed

Similar threads