old/PAS/Long Multiply/MULTIPLY.PAS

Const
  file1    = 'Num1.txt';
  file2    = 'num2.txt';
  result   = 'Res.txt';
  max      = 1000;
Type
  TM = array [0..max] of 0..9;
  TR = array [0..2*max] of 0..9;
Var
  f1       : ^TM;
  f2       : ^TM;
  length1  : word;
  length2  : word;
  res      : ^TR;
{-----------------------------------------------------------------------}
Procedure ReadFile;
Var
  f        : file of char;
  name     : string;
  uze      : boolean;
  i        : word;
  j        : word;
  ch       : char;
Begin
  for j := 0 to max do f1^[j] := 0;
  for j := 0 to max do f2^[j] := 0;
  for j := 0 to 2*max do res^[j] := 0;
  if ParamCount >= 2 then Assign(f,paramstr(1))
  else Assign(f,file1);
  {$I-}
  Reset(f);
  if IOResult <> 0 then
    Begin
      WriteLn;
      repeat
        Write('Неверное имя 1 - го фаила, введите новое: ');
        Readln(name);
        Assign(f,name);
        Reset(f);
      until IOResult = 0;
    End;
  {$I+}
  uze := false;
  length1 := 0;
  seek(f,filesize(f)-1);

  repeat
    Read(f,ch);
    if ch in ['0'..'9'] then
     begin
      f1^[length1] := ord(ch) - $30;
      inc(length1);
     end;
    if Filepos(F)=1 then uze:=true;
    seek(F,filepos(f)-2);
  until uze;
  Close(f);

  if ParamCount >= 2 then Assign(f,paramstr(2))
    else Assign(f,file2);
  {$I-}
  Reset(f);
  if IOResult <> 0 then
    Begin
      WriteLn;
      repeat
        Write('Неверное имя 2 - го фаила, введите новое: ');
        Readln(name);
        Assign(f,name);
        Reset(f);
      until IOResult = 0;
    End;
  {$I+}
  length2 := 0;
  seek(f,filesize(f)-1);
  uze := false;
  repeat
    Read(f,ch);
    if ch in ['0'..'9'] then
     begin
      f2^[length2] := ord(ch) - $30;
      inc(length2);
     end;
    if Filepos(F)=1 then uze:=true;
    seek(F,filepos(f)-2);
  Until uze;
  Close(f);
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 Multiply(F1,F2:TM;var RES:TR;Length1,Length2:word);
Var
  i,j,b,a   :word;
  tmp1,tmp2 :word;
  modcur    :word;
  modmain   :word;
Begin
  modmain:=0;
  modcur:=0;
  for i := 0 to length2-1 do
    begin
      modcur := 0;
      for j := 0 to length1-1 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}
{----------------------------------------------}
Function Length3(res:TR;M:word):word;
Var
  i        : word;
Begin
  i := m;
  While res[i] = 0 do dec(i);
  length3 := i;
End;{Length3}
{----------------------------------------}
Procedure WriteRes(Re:TR);
Var
  i        : word;
  f        : text;
Begin
  if ParamCount = 3 then Assign(f,ParamStr(3))
  else Assign(f,result);
  Rewrite(f);
  for i := length3(re,2*MAX) downto 0 do
      Write(f,re[i]);
  Close(f);
End;{WriteRes}
{-----------------------------------------}
Begin
  New(F1);
  New(F2);
  New(Res);
  fillchar(F1^,MAX,0);
  fillchar(F2^,MAX,0);
  fillchar(Res^,MAX*2,0);
{  readfile;}
  F1^[0]:=2;
  Multiply(F1^,F1^,RES^,1,1);
  WriteRes(Res^);
  Dispose(F1);
  Dispose(F2);
  Dispose(Res);
End.