ce.pas

化学方程配平软件

Program main;
{$g+}
{$x+}
uses crt,DOS;
{
Version:5.00
Programmer:Dick 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(n)+copy(d,k+m,length(d)-k-m+1);
                      k:=k+length(inttostr(n))+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(n)-1);
                                              end
                                              else n:=copy(n,3,length(n)-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(n)>=i) and (n[i] 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(n)-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[i]=k);
                            if i>enumber then begin
                                              enumber:=i;
                                              eline[i]:=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.