Владимир Игоревич, я попробовал(только сильно не пинайте):
Код:
function Summa(ast1,ast2:string):string;
var b,b1,b2,b3,b4:byte;
begin
b1:=Length(ast1);
b2:=Length(ast2);
b4:=0;
While b2<>0 do
begin
b:=(Ord(ast1[b1])-Ord('0'))+(Ord(ast2[b2])-Ord('0'))+b4;
b3:=b mod 10;
ast1[b1]:=Char(b3+Ord('0'));
b4:=b div 10;
Dec(b1);
Dec(b2);
end;
if b4<>0 then
repeat
if b1<>0
then
begin
b4:=(Ord(ast1[b1])-Ord('0'))+b4;
b:=b4 mod 10;
ast1[b1]:=Char(b+Ord('0'));
b4:=b4 div 10;
Dec(b1);
end
else
begin
ast1:=' '+ast1;
ast1[1]:=Char(b4+Ord('0'));
b4:=0;
end;
until b4=0;
Summa:=ast1;
end;
function Proizved(as1,as2:string):string;
var n,n1,n2,n3,n4,n5,i,j:integer;
st1,st2:string;
begin
n1:=Length(as1);
n2:=Length(as2);
n4:=0; st1:='';
for i:=1 to n2 do
begin
st1:=st1+'0';
n:=Ord(as2[i])-Ord('0');
st2:='';
for j:=n1 downto 1 do
begin
n3:=((Ord(as1[j])-Ord('0'))*n)+n4;
n5:=n3 mod 10;
st2:=Char(n5+Ord('0'))+st2;
n4:=n3 div 10;
end;
if n4<>0 then
begin
st2:=Char(n4+Ord('0'))+st2;
n4:=0;
end;
if Length(st1)>=Length(st2)
then st1:=Summa(st1,st2)
else st1:=Summa(st2,st1);
end;
Proizved:=st1;
end;
var a,x,x1,x2,y:byte;
s1,s2,f:string;
begin
Write('a = '); Readln(a);
Writeln;
f:='0';
for y:=1 to a do
begin
s1:='1';
for x:=1 to y do
begin
s2:='';
x1:=x;
While x1<>0 do
begin
x2:=x1 mod 10;
s2:=Char(x2+Ord('0'))+s2;
x1:=x1 div 10;
end;
s1:=Proizved(s1,s2);
end;
if Length(s1)>Length(f)
then f:=Summa(s1,f)
else f:=Summa(f,s1);
end;
Writeln('Summa factorialov ot 1 do ',a,' = '+f);
Readln;
end.