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[i]:=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[i] 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[i]) do inc(i);
                if i>xn then exit;
                g:=a[0,i];
                done1:=done;
                repeat
          next:       known[i]:=true;
                      inc(g);
                      c^:=a;
                      c^[0,i]:=g;
                      cal(c^);
                      easy(c^);
                      if err<>0 then begin
                                     done:=done1;
                                     goto next;
                                     end;