Const
{  file1    = 'Num1.txt';
  file2    = 'num2.txt';}
  result   = 'Res.txt';
  max      = 5000;
  n        : word = 17;
Type
  TM = array [0..max] of 0..9;
  PM = ^TM;
Var
  i,j,b,a   :word;
  tmp1,tmp2 :word;
  modcur    :word;
  modmain   :word;
  f1       : PM;
  f2       : PM;
  umn      : array [1..max] of integer;
  res      : PM;
{----------------------------------------------}
Function Length3(res:PM):word;
Var
  i        : word;
Begin
  i := max-1;
  While res^[i] = 0 do dec(i);
  length3 := i;
End;{Length3}
{-----------------------------------------------------------------------}
Procedure MakeLong(var Long:TM;va:word);
var st : string;i : word;
Begin
  Str(va,st);
  for i := 0 to length(st)-1 do Long[i] := ord(st[length(st)-i])-ord('0');
End;{}
{-------------------------------------}
Function getwrite(inp : integer):byte;
Var
  st       : string;
  code     : integer;
  rc       : integer;
Begin
  str(inp,st);
  val(st[length(st)],rc,code);
  GetWrite := rc;
End;{GetWrite}
{----------------------------------------------}
Function GetMemory(inp : integer) : integer;
Var
  code     : integer;
  st       : string;
  rc       : integer;
Begin
  if inp >9 then begin
    Str(inp,st);
    delete(st,length(st),1);
    val(st,rc,code);
    GetMemory := rc;
  end
  else GetMemory :=0;
End;{GetMemory}
{----------------------------------------------}
Procedure Mult(F1,F2:PM;var RES:TM);
Begin
  modmain:=0;
  modcur:=0;
  for i := 0 to length3(f2) do
    begin
      modcur := 0;
      for j := 0 to length3(f1) do
        begin
          tmp1 := f2^[i]*f1^[j]+modcur;
          modcur := getmemory(tmp1);
          tmp2 := modmain+res[i+j]+getwrite(tmp1);
          res[i+j] := getwrite(tmp2);
          modmain := getmemory(tmp2)
        end;
      a := i+j+1;
      b := modcur;
      repeat
        tmp1 := getwrite(b)+modmain;
        res[a] := getwrite(tmp1);
        modmain := getmemory(tmp1);
        inc(a);
        b := getmemory(b)
      until getmemory(b) = 0;
    end;
End;{Multiply}
{----------------------------------------}
Procedure WriteRes(Re:PM);
Var
  i        : word;
  f        : text;
Begin
  if ParamCount = 3 then Assign(f,ParamStr(3))
  else Assign(f,result);
  Rewrite(f);
  for i := length3(re) downto 0 do
      Write(f,re^[i]);
  Close(f);
End;{WriteRes}
{-----------------------------------------}
Procedure _2VN(var FI:TM;st:word);
var i:word;
    ret,ret2,ret3:TM;
Begin
  fillchar(ret,MAX,0);
  fillchar(ret2,MAX,0);
  fillchar(ret3,MAX,0);
  MakeLong(ret,n);
  MakeLong(ret3,n);

  for i := 2 to st do
  begin
   fillchar(ret2,max,0);
   MULT(@ret,@ret3,ret2);
   ret:=ret2;
  end;
  FI := Ret;

End;
{-----------------------------------------}
Var
  cur   : word;
  p,ost : word;
Begin
  Write('Введите N <=1000 двойки: ');
  Read(n);
  New(F1);
  New(F2);
  New(Res);
  fillchar(F1^,MAX,0);
  fillchar(F2^,MAX,0);
  fillchar(Res^,MAX,0);
  fillchar(umn,MAX,1);
  cur := 1;
  p := 1;

  while cur+cur < n do
   begin
    cur := cur+cur;
    umn[p] := -1;
    inc(p);
   end;

  ost := n - cur;
  repeat
   cur := 1;
   while cur+cur <= ost do cur := cur+cur;
   ost := ost - cur;
   umn[p] := cur;
   inc(p);
  until ost = 0;

  WriteLn('Начинаем работу');

  MakeLong(F1^,n);

  for cur := 1 to p-1 do
    begin
      if umn[cur] = -1 then
       begin
        fillchar(res^,max,0);
        MULT(F1,F1,Res^)
       end
      else
        begin
          _2VN(F2^,umn[cur]);
          fillchar(res^,max,0);
          MULT(F1,F2,Res^)
        end;
        F1^:=RES^;
    end;
  WriteLn('Работа окончена !!!');
  WriteRes(Res);
  Dispose(F1);
  Dispose(F2);
  Dispose(Res);
End.