Question

求一个Pascal语言的高精度除法程序，要求优化

3q

Answer 1

var
a:array[1..3,0..250]of int64;
b:array[1..3,0..250]of int64;
m,mm:longint;
n:longint;
s:ansistring;
function compare(i,j:longint):boolean;
var k:longint;
begin
if a[i,0]>a[j,0] then exit(true);
if a[i,0]<a[j,0] then exit(false);
k:=a[i,0];
while(a[i,k]=a[j,k])and(k>1)do dec(k);
if a[j,k]>a[i,k] then exit(false)
else exit(true);
end;
procedure add;
var j:longint;
x:int64;
begin
j:=1;
x:=0;
for j:=1 to b[1,0] do
begin
x:=x+b[1,j]+b[2,j];
b[3,j]:=x mod 10000000;
x:=x div 10000000;
end;
for j:=b[1,0]+1 to b[2,0] do
begin
x:=x+b[2,j];
b[3,j]:=x mod 10000000;
x:=x div 10000000;
end;
b[3,0]:=b[2,0];
while(x<>0)do
begin
inc(b[3,0]);
b[3,b[3,0]]:=x mod 10000000;
x:=x div 10000000;
end;

for j:=b[3,0] downto 1 do
begin
x:=x*10000000+b[3,j];
b[3,j]:=x div 2;
x:=x mod 2;
end;
while(b[3,b[3,0]]=0)and(b[3,0]>=1)do dec(b[3,0]);
end;

procedure cheng(o,p:longint);
var i,j,k:longint;
x:int64;
begin
fillchar(a[3],sizeof(a[3]),0);
for k:=1 to b[o,0]+a[p,0]-1 do
for i:=1 to k do
begin
j:=k+1-i;
x:=a[3,k]+b[o,i]*a[p,j];
a[3,k]:=x mod 10000000;
a[3,k+1]:=a[3,k+1]+x div 10000000;
end;
a[3,0]:=b[o,0]+a[p,0];
while(a[3,a[3,0]]>10000000)do
begin
inc(a[3,0]);
a[3,a[3,0]]:=a[3,a[3,0]-1] div 10000000;
a[3,a[3,0]-1]:=a[3,a[3,0]-1] mod 10000000;
end;
while(a[3,0]>0)and(a[3,a[3,0]]=0)do dec(a[3,0]);
end;

procedure dele;
var j,k:longint;
begin
j:=1;
while(b[2,j]=0)do inc(j);
b[2,j]:=b[2,j]-1;
for k:=1 to j-1 do
b[2,k]:=9999999;
end;
function plus1:boolean;
var k:longint;
begin
if b[2,0]>b[1,0]
then exit(true);
k:=b[2,0];
while(b[2,k]=b[1,k])and(k>1)do dec(k);
if ((b[2,k]-b[1,k]>1)and(k=1))or((b[2,k]>b[1,k])and(k<>1))
then exit(true)
else exit(false);
end;

procedure plus2(o,p:longint);
var j,x:longint;
begin
for j:=1 to a[p,0] do
if a[o,j]<a[p,j]
then
begin
a[o,j]:=a[o,j]-a[p,j]+10000000;
dec(a[o,j+1]);
end
else
a[o,j]:=a[o,j]-a[p,j];

for j:=a[p,0]+1 to a[o,0] do
if a[o,j]<0
then
begin
a[o,j]:=a[o,j]+10000000;
dec(a[o,j+1])
end
else
a[o,j]:=a[o,j];
a[o,0]:=a[o,0];
while(a[o,0]>0)and(a[o,a[o,0]]=0)do dec(a[o,0]);
end;

procedure out1(o:longint);
var s:string;
i,j:longint;
begin
write(a[o,a[o,0]]);
for i:=a[o,0]-1 downto 1 do
begin
str(a[o,i],s);
for j:=1 to 7-length(s) do
write(0);
write(a[o,i]);
end;
close(input);
close(output);
halt;

end;

procedure work;
begin
m:=1;mm:=2;
repeat
b[2]:=a[m];
b[1,0]:=0;
while plus1 do
begin
add;
cheng(3,mm);
if compare(m,3)
then
b[1]:=b[3]
else
begin
b[2]:=b[3];
dele;
end;
end;
cheng(2,mm);
if compare(m,3)
then
b[3]:=b[2]
else
b[3]:=b[1];
cheng(3,mm);
plus2(m,3);
if a[m,0]=0
then
out1(mm);
mm:=3-mm;
m:=3-m;
until false;
end;

begin
assign(input,'Cont.in');
assign(output,'Cont.out');
rewrite(output);
reset(input);
readln(s);
while(length(s)>=8)do
begin
inc(a[1,0]);
val(copy(s,length(s)-6,7),a[1,a[1,0]]);
delete(s,length(s)-6,7);
end;
if length(s)<>0
then
begin
inc(a[1,0]);
val(copy(s,length(s)-6,7),a[1,a[1,0]]);
end;
readln(s);
while(length(s)>=8)do
begin
inc(a[2,0]);
val(copy(s,length(s)-6,7),a[2,a[2,0]]);
delete(s,length(s)-6,7);
end;
if length(s)<>0
then
begin
inc(a[2,0]);
val(copy(s,length(s)-6,7),a[2,a[2,0]]);
end;
if not compare(1,2)
then
begin
a[3]:=a[1];a[1]:=a[2];a[2]:=a[3];
end;
work;
end.