MultiID.Pas Program Listing, Part 2




{--------------------------------------}
function MultiSI.Comp( var X : MultiSI) : Integer; {Comp = sign( Self - X)}
{Sign = -1 if Self < X; Sign = 0 if Self = X; Sign = +1 if Self > X}
{Self.S and X.S used but not changed;  Self, X not changed}
begin
  if Not S and Not X.S then  Comp:= AbComp(X)       {Both positive}
  else if S and X.S    then  Comp:= X.AbComp( Self) {Both negative}
  else if X.S then  Comp:= +1                       {Self pos, X neg}
  else Comp:= -1;                                   {Self neg, X pos}
end; {MultiSI.Comp}

{--------------------------------------}
procedure WriteMax( var Out : TEXT; St : String);
{Output String and line feed every MuMaxW, MuTot = characters on line so far}
var
  I : Integer;
begin
  if (@Out = @OutPut) or (MuMaxW <= 0) then  Write( Out, St)
  else
    for I:= 1 to Length( St) do begin
      Write( Out, St[I]);  Inc( MuTot);
      if (MuTot >= MuMaxW) then begin
        WriteLn( Out);  MuTot:= 0;
      end;
    end;
end; {WriteMax}

{--------------------------------------}
procedure WriteMaxLn( var Out : TEXT; St : String);
{Output String and line feed every MuMaxW, MuTot = characters on line so far
 and a new line}
begin
  WriteMax( Out, St);
  WriteLn( Out);  MuTot:= 0;
end; {WriteMaxLn}

{--------------------------------------}
procedure MultiSI.Writ( var Out : TEXT); {Output Self as a line of text}
{Self is not modified}
var
  I, J, ToGo, LenD : LongInt;
  St : String[8];
begin
  ToGo:= LongInt(N) * MuDMax;
  if S then WriteMax( Out, '-');
  Str( Base + V^[N - 1] :0:0, St);
  J:= 1;
  repeat
    Inc(J);
  until (St[J] <> '0') or (J = MuDMax+1);
  WriteMax( Out, St[J]);
  Dec( ToGo, J - 1);
  LenD:= ToGo + 1;
  while J <= MuDMax do begin
    Inc(J);
    if (ToGo Mod MuDpG) = 0 then  WriteMax( Out, ',');
    WriteMax( Out, St[J]);
    Dec( ToGo);
  end;
  for I:= 2 to N do begin
    Str( Base + V^[N - I] :0:0, St);
    for J:= 2 to MuDMax+1 do begin
      if (ToGo Mod MuDpG) = 0 then  WriteMax( Out, ',');
      WriteMax( Out, St[J]);
      Dec( ToGo);
    end;
  end;
  if LenD >= MuLenD then begin
    Str( LenD, St);
    if (@Out <> @OutPut) and (MuMaxW > 0) and
       (Length(St) > (MuMaxW - MuTot - 3)) then begin
      WriteLn( Out);  MuTot:= 0;
    end;
    if (@Out = @OutPut) or (MuMaxW <= 0) or (MuTot <> 0) then
      WriteMax( Out, ' ');
    WriteMax( Out, '(' + St + ')');
  end;
end; {MultiSI.Writ}

{--------------------------------------}
procedure MultiSI.WritLn( var Out : TEXT); {Output Self and a new line}
begin
  Writ( Out);
  WriteLn( Out);  MuTot:= 0;
end; {MultiSI.WritLn}

{--------------------------------------}
procedure MultiSI.ShortWr( var Out : TEXT; Short : LongInt);
{Output Self in short form ... if more than Short digits}
{Self is not modified}
var
  Did : Integer;
  I, J, ToGo, LenD : LongInt;
  St : String[8];
begin
  if (N < 3) or (N <= Short div MuDMax) then begin
    Writ( Out);  Exit;
  end;
  ToGo:= LongInt(N) * MuDMax;
  if S then Write( Out, '-');
  Str( Base + V^[N - 1] :0:0, St);
  J:= 1;
  repeat
    Inc(J);
  until (St[J] <> '0') or (J = MuDMax+1);
  Write( Out, St[J]);  Did:= 1;
  Dec( ToGo, J - 1);
  LenD:= ToGo + 1;
  while (J <= MuDMax) and (Did < 5) do begin
    Inc(J);
    Write( Out, St[J]);  Inc( Did);
  end;
  Str( Base + V^[N - 2] :0:0, St);
  for J:= 2 to 6-Did do begin
    Write( Out, St[J]);
  end;
  Write( Out, ',...,');
  Str( Base + V^[0] :0:0, St);
  for J:= MuDMax-3 to MuDMax+1 do begin
    Write( Out, St[J]);
  end;
  Write( Out, ' (', LenD, ')');
end; {MultiSI.ShortWr}

{--------------------------------------}
procedure MultiSI.ShortWrLn( var Out: TEXT; Short : LongInt);
{Output Self short and a new line}
begin
  ShortWr( Out, Short);
  WriteLn( Out);  MuTot:= 0;
end; {MultiSI.ShortWrLn}

{--------------------------------------}
procedure MultiSI.RMul1( D1 : Mu1Digit); {Self = Self * D1}
{Multi-precision one super digit multiply; D1 is not changed}
{MuErr set true if Self overflows}
var
  K : Mu1Digit;
begin
  S:= S xor (D1 < 0);
  IpMul1(D1, Self, K);
  if K > 0 then
    MuWriteErr('One digit multiply overflow, continuing...');
end; {MultiSI.RMul1}

{--------------------------------------}
procedure MultiSI.Mul1( var X : MultiSI; D1 : Mu1Digit); {Self = X * D1}
{Multi-precision one super digit multiply; X and D1 are not changed}
{MuErr set true if Self overflows}
begin
  SetTo(X);
  RMul1( D1);
end; {MultiSI.Mul1}

{--------------------------------------}
procedure MultiSI.Mul( var X, Y : MultiSI); {Self = X * Y}
{X or Y or both may have the same address in memory as Self}
{X, Y are not changed unless they share memory with Self}
{Sets MuErr True if overflow}
var
  XL, YL   : ^MultiSI;
  I, J, IJ : Integer;
  K : Mu1Digit;
  T : Mu2Digit;
  NewXL, NewYL : Boolean;
begin
  XL:= @X;  NewXL:= False;
  YL:= @Y;  NewYL:= False;
  if X.V = Self.V then begin
    New( XL, Init( X.N));  XL^.SetTo(X);  NewXL:= True;
  end
  else if Y.V = Self.V then begin
    New( YL, Init( Y.N));  YL^.SetTo(Y);  NewYL:= True;
  end;
  if @X = @Y then  YL:= XL;
  S:= XL^.S xor YL^.S;
  for I:= 0 to XL^.N-1 do  V^[I]:= 0; {Clear lower of Self}
  KeyHit:= False;
  for J:= 0 to YL^.N-1 do begin
    K:= 0;  I:= 0;
    while I < XL^.N do begin
      IJ:= I + J;
      if IJ < Self.M then begin              {Mult, add and carry next Digit}
        T:= XL^.V^[I] * YL^.V^[J] + Self.V^[ IJ] + K;
        K:= Int(T / Base);
        Self.V^[ IJ]:= T - K * Base;
      end
      else
        I:= XL^.N; {Break out of inner loop}
      Inc(I);
    end;
    Inc( IJ);
    if IJ < Self.M then  Self.V^[ IJ]:= K;
    MuInterrupt;
    if MuAbort then begin
      Clear;
      if NewXL then  Dispose( XL, Done);
      if NewYL then  Dispose( YL, Done);
      Exit;
    end;
    if KeyHit then begin
      for I:= 0 to Echo do
        WriteLn( OutP[I]^, 'Integer Multiply: ',
          Trunc( (100.0 * (J+1)) / YL^.N), ' Percent done');
      KeyHit:= False;
    end;
  end;
  if K <> 0 then  Inc( IJ);
  if IJ > Self.M then begin
    IJ:= Self.M;
    MuWriteErr('Multiplication overflow, continuing...');
  end;
  N:= IJ;
  Norm;
  if NewXL then  Dispose( XL, Done);
  if NewYL then  Dispose( YL, Done);
end; {MultiSI.Mul}

{--------------------------------------}
procedure MultiSI.RMul( var X : MultiSI); {Self = Self * X}
{X may have the same address in memory as Self}
{X is not changed unless it shares memory with Self}
{Sets MuErr True if overflow}
begin
  Mul( Self, X);
end; {MultiSI.RMul}

{--------------------------------------}
procedure MultiSI.Sq( var X : MultiSI); {Self = X * X}
{X may have the same address in memory as Self}
{X is not changed unless it shares memory with Self}
{Sets MuErr True if overflow}
begin
  Mul(X, X);
end; {MultiSI.Sq}

{--------------------------------------}
procedure MultiSI.RSq; {Self = Self * Self}
{Sets MuErr True if overflow}
begin
  Mul( Self, Self);
end; {MultiSI.RSq}

{--------------------------------------}
procedure MultiSI.ModMB; {Self = Self Mod MuMB}
{Self is changed}
var  I : Integer;  QL : ^MultiSI;
begin
  if MuMB^.ZTest then  Exit;
  I:= AbComp( MuMB^);
  if I >= 0 then begin {if |Self| >= |MuMB|}
    New( QL, Init( Self.N));
    IpDiv( MuMB^, Self, QL^, Self);
    Dispose( QL, Done);
  end;
end; {MultiSI.ModMB}

{--------------------------------------}
procedure MultiSI.RDiv1( D1 : Mu1Digit); {Self = Self / D1}
{Multi-precision one super digit divide, D1 is not changed}
{Allows literal D1, MuErr set True if D1 = 0}
var
  RL : Mu1Digit;
begin
  IpDiv1( D1, Self, RL);
end; {MultiSI.RDiv1}

{--------------------------------------}
procedure MultiSI.Div1( var U : MultiSI; D1 : Mu1Digit); {Self = U / D1}
{Multi-precision one super digit divide, D1 and U not changed}
{U and Self may have same address in memory, then U is changed}
{Allows literal D1, MuErr set True if D1 = 0}
var
  RL : Mu1Digit;
begin
  SetTo(U);
  IpDiv1( D1, Self, RL);
end; {MultiSI.Div1}

{--------------------------------------}
procedure MultiSI.Mod1( D1: Mu1Digit; var R1: Mu1Digit); {R1 = Rem( Self / D1)}
{Multi-precision one super digit Modulo, D1 and Self not changed}
{D1 and R1 may have same address in memory, then D1 is changed}
{Allows literal D1, MuErr set True if D1 = 0}
var
  QL : ^MultiSI;
begin
  New( QL, Init( Self.N));
  QL^.SetTo( Self);
  IpDiv1( D1, QL^, R1);
  Dispose( QL, Done);
end; {MultiSI.Mod1}

{--------------------------------------}
procedure MultiSI.RDiv1QR( D1: Mu1Digit; var R1: Mu1Digit);
  {Self = Self / D1, R1 = Rem}
{Multi-precision one super digit Divide Q & R.  D1 and U not changed}
{D1 and R1 may have same address in memory, then D1 is changed}
{Allows literal D1, MuErr set True if D1 = 0}
begin
  IpDiv1( D1, Self, R1);
end; {MultiSI.RDiv1QR}

{--------------------------------------}
procedure MultiSI.Div1QR( var U: MultiSI; D1: Mu1Digit; var R1: Mu1Digit);
  {Self = U / D1, R1 = Rem}
{Multi-precision one super digit Divide Q & R.  D1 and U not changed}
{D1 and R1 may have same address in memory, then D1 is changed}
{Allows literal D1, MuErr set True if D1 = 0}
begin
  SetTo(U);
  IpDiv1( D1, Self, R1);
end; {MultiSI.Div1QR}

{--------------------------------------}
procedure MultiSI.Divi( var U, D : MultiSI); {Self = U / D}
{U or D or both may have the same address in memory as Self}
{U, D are not changed unless they share memory with Self}
{Sets MuErr True if D = 0}
var
  DL, RL : ^MultiSI;
  NewDL : Boolean;
begin
  DL:= @D;  NewDL:= False;
  if D.V = Self.V then begin
    New( DL, Init( D.N));  DL^.SetTo(D);  NewDL:= True;
  end;
  New( RL, Init( U.N));  RL^.SetTo(U);
  IpDiv( DL^, RL^, Self, RL^);
  if NewDL then  Dispose( DL, Done);
  Dispose( RL, Done);
end; {MultiSI.Divi}

{--------------------------------------}
procedure MultiSI.RDiv( var D : MultiSI); {Self = Self / D}
{D may have the same address in memory as Self}
{D is not changed unless it shares memory with Self}
{Sets MuErr True if D = 0}
begin
  Divi( Self, D);
end; {MultiSI.RDiv}

{--------------------------------------}
procedure MultiSI.Modu( var U, D : MultiSI); {Self = Rem(U / D)}
{U or D or both may have the same address in memory as Self}
{U, D are not changed unless they share memory with Self}
{Sets MuErr True if D = 0}
var
  DL, QL : ^MultiSI;
  NewDL : Boolean;
begin
  DL:= @D;  NewDL:= False;
  if D.V = Self.V then begin
    New( DL, Init( D.N));  DL^.SetTo(D);  NewDL:= True;
  end;
  New( QL, Init( U.N));
  SetTo(U);
  IpDiv( DL^, Self, QL^, Self);
  if NewDL then  Dispose( DL, Done);
  Dispose( QL, Done);
end; {MultiSI.Modu}

{--------------------------------------}
procedure MultiSI.RMod( var D : MultiSI); {Self = Rem( Self / D)}
{D may have the same address in memory as Self}
{D is not changed unless it shares memory with Self}
{Sets MuErr True if D = 0}
begin
  Modu( Self, D);
end; {MultiSI.RMod}

{--------------------------------------}
procedure MultiSI.DivQR( var U, D, R : MultiSI); {Self = U / D, R = Rem}
{U or D or both may have the same address in memory as Self or R}
{U, D are not changed unless they share memory with Self or R}
{Self and R may not have the same location in memory. Sets MuErr True if D = 0}
var
  DL : ^MultiSI;
  NewDL : Boolean;
begin
  if Self.V = R.V then begin
    MuWriteErr(
     'Cannot set same location to both quotient and remainder, continuing...');
    Exit;
  end;
  DL:= @D;  NewDL:= False;
  if (D.V = Self.V) or (@D =  @R) then begin
    New( DL, Init( D.N));  DL^.SetTo(D);  NewDL:= True;
  end;
  R.SetTo(U);
  IpDiv( DL^, R, Self, R);
  if NewDL then  Dispose( DL, Done);
end; {MultiSI.DivQR}

{--------------------------------------}
procedure MultiSI.RDivQR( var D, R : MultiSI); {Self = Self / D, R = Rem}
{Self may have the same address in memory as D or R}
{D is not changed unless it shares memory with Self or R}
{Sets MuErr True if D = 0}
begin
  DivQR( Self, D, R);
end; {MultiSI.RDivQR}

{--------------------------------------}
procedure MultiSI.PowMB( var B, P : MultiSI); {Self = (B ** P) Mod MuMB}
{B or P or both may have the same address in memory as Self}
{B, P are not changed unless they share memory with Self}
{Sets MuErr True if overflow or error}
var
  BL, PL : ^MultiSI;
  L      : LongInt;
  R      : Mu1Digit;
  Fini   : Boolean;
begin
  if B.ZTest then begin  {B = 0}
    if P.S then begin
      MuWriteErr('Cannot raise zero to a negative power');
    end
    else if P.ZTest then begin  {P = 0}
      MuWriteErr('Cannot raise zero to the zero power');
    end;
    Clear;  Exit;
  end;
  if (P.S) and ((B.N > 1) or (B.V^[0] > 1)) then begin { (>1) ** -P}
    Clear;  Exit;
  end;
  if (B.N = 1) and (B.V^[0] = 1) then begin {B = +/-1}
    L:= Round( P.V^[0]);
    S:= B.S and ((L Mod 2) = 1);
    N:= 1;  V^[0]:= 1;  Exit;
  end;

  Fini:= False;
  New( BL, Init( Self.M));  BL^.SetTo(B);
  New( PL, Init( P.N));     PL^.SetTo(P);
  SetTo1(1);
  repeat
    L:= Round( PL^.V^[0]);
    if (L Mod 2) = 1 then begin
      Self.Mul( BL^, Self);
      Self.ModMB;
    end;
    IpDiv1(2, PL^, R);
    if PL^.ZTest then Fini:= True
    else begin
      BL^.Mul( BL^, BL^);
      BL^.ModMB;
    end;
    if MuAbort then begin
      Clear;
      Fini:= True;
    end;
  until Fini;
  Dispose( PL, Done);
  Dispose( BL, Done);
end; {MultiSI.PowMB}

{--------------------------------------}
procedure MultiSI.RPowMB( var P : MultiSI); {Self = (Self ** P) Mod MuMB}
{P may have the same address in memory as Self}
{P is not changed unless it shares memory with Self}
{Sets MuErr True if overflow or error}
begin
  PowMB( Self, P);
end; {MultiSI.RPowMB}

{--------------------------------------}
procedure MultiSI.GCD( var A, B : MultiSI);{Self = Greatest common divisor A, B}
{A, B are not modified unless they share memory with Self}
{Will write to standard output if MuErrRep is True}
var
  AL, BL : ^MultiSI;
  I, NN  : Integer;
  Fini   : Boolean;
begin
  New( AL, Init( A.N));  AL^.SetTo(A);
  New( BL, Init( B.N));  BL^.SetTo(B);
  Fini:= False;
  AL^.S:= False;  BL^.S:= False;
  if AL^.ZTest then begin  Self.SetTo( BL^);  Fini:= True;  end;
  if BL^.ZTest then begin  Self.SetTo( AL^);  Fini:= True;  end;
  NN:= 0;
{ if MuErrRep and Not Fini then  for I:= 0 to Echo do  WriteLn( OutP[I]^); }
  while Not Fini do begin
    Inc( NN);
    if Odd( NN) then begin
      AL^.Modu( AL^, BL^);
      if MuErrRep then begin
        for I:= 0 to Echo do begin
	  Write( OutP[I]^, NN, ' ');  AL^.WritLn( OutP[I]^);
        end;
      end;
      if AL^.ZTest then begin  Self.SetTo( BL^);  Fini:= True;  end;
    end
    else begin
      BL^.Modu( BL^, AL^);
      if MuErrRep then begin
        for I:= 0 to Echo do begin
	  Write( OutP[I]^, NN, ' ');  BL^.WritLn( OutP[I]^);
        end;
      end;
      if BL^.ZTest then begin  Self.SetTo( AL^);  Fini:= True;  end;
    end;
  end;
  Dispose( AL, Done);
  Dispose( BL, Done);
end; {MultiSI.GCD}

{--------------------------------------}
procedure MultiSI.RGCD( var A: MultiSI); {Self=Greatest common divisor A, Self}
{A is not modified unless it shares memory with Self}
{Will write to standard output if MuErrRep is True}
begin
  GCD(A, Self);
end; {MultiSI.RGCD}

{--------------------------------------}
procedure MultiSI.FacMB( var X: MultiSI); {Self = (X !) Mod MuMB = 1*2*3*...*X}
{X may have the same address in memory as Self}
{X is not changed unless it shares memory with Self}
{Sets MuErr True if overflow or error}
var
  XL : ^MultiSI;
  NN : Double;
begin
  if X.S then begin
    MuWriteErr('Cannot take factorial of number < zero');
    Clear;  Exit;
  end;
  if X.N > 2 then begin
    MuWriteErr('Number too large for factorial function');
    Clear;  Exit;
  end;

  New( XL, Init( X.N));  XL^.SetTo(X);
  Self.SetTo1(1);
  XL^.GetD( NN);
  while NN > 1 do begin
    Self.Mul( XL^, Self);
    Self.ModMB;
    if MuAbort then begin
      Dispose( XL, Done);
      Clear;  Exit;
    end;
    NN:= NN - 1;
    XL^.SetToD( NN);
  end;
  Dispose( XL, Done);
end; {MultiSI.FacMB}

{--------------------------------------}
procedure MultiSI.RFacMB; {Self = (Self !) Mod MuMB = 1*2*3*...*X}
{Sets MuErr True if overflow or error}
begin
  FacMB( Self);
end; {MultiSI.RFacMB}

{--------------------------------------}
procedure MultiSI.SqRtRem( var X, R : MultiSI); {Self = SqRt(X), R = Rem}
{X is not changed, X is moved to R and then R is "divided"}
{in place to give the SqRt in Self and a remainder in R, it is ok for X and R}
{or X and Self to have the same location in memory, but then X will be changed}
{Self and R may not have the same location in memory. Sets MuErr True if error}
var
  D0, QH   : Mu1Digit;
  T, T2, D4, K  : Mu2Digit;
  I, J, RI0, DI0, RI, DI, IJ  : Integer;
begin
  if Self.V = R.V then begin
    MuWriteErr(
  'Cannot set same location to both square root and remainder, continuing...');
    Exit;
  end;
  R.SetTo(X);
  MultiSI.CLear;
  if R.S then begin
    MuWriteErr('Cannot take square root of negative number, continuing...');
    R.Clear;  Exit;
  end;
  if R.N < 4 then begin
    for I:= R.N to 3 do  R.V^[I]:= 0;
    R.N:= 4;
  end;
  if Odd( R.N) then begin
    R.V^[ R.N]:= 0;
    R.N:= R.N + 1;
  end;
  Self.N:= R.N div 2 + 1;
  T:= 0;
  for I:= 1 to 4 do  T:= T * Base + R.V^[ R.N - I];
  T2:= Int( SqRt(T));
  repeat
    D0:= Int( T2 / Base);
    QH:= 1 + T2 - D0 * Base; {+1 for safety}
    T:= R.V^[ R.N - 1] * Base + R.V^[ R.N - 2] - D0 * D0;
    if T < 0 then T2:= T2 - 1;
  until T >= 0;
  K:= Int(T / Base);
  R.V^[ R.N - 2]:= T - K * Base;
  R.V^[ R.N - 1]:= K;
  if Self.N >= 4 then Self.V^[ Self.N - 4]:= 0;
  Self.V^[ Self.N - 3]:= QH;
  T:= 2 * D0;
  K:= Int(T / Base);
  Self.V^[ Self.N - 2]:= T - K * Base;
  Self.V^[ Self.N - 1]:= K;
  KeyHit:= False;
  for J:= 2 to R.N div 2 do begin
    K:= Base;  RI0:= R.N - J - J;  DI0:= Self.N - J - 1;
    RI:= RI0;   DI:= DI0;   IJ:= RI0 + J;
    while RI <= IJ do begin     {Multiply and subtract}
      T:= R.V^[ RI] - QH * Self.V^[ DI] + K + BSMB; {+ BaseSq - Base}
      K:= Int(T / Base);
      T:= T - K * Base;
      R.V^[ RI]:= T;
      Inc( RI);  Inc( DI);
    end;
    T:= R.V^[ RI] + K + BSMB; {+ BaseSq - Base}
    K:= Int(T / Base);
    R.V^[ RI]:= T - K * Base;
    while K = MaxDigit do begin  {Test remainder}
{WriteLn('MuSqRt: Doing an add back'); .Diag for add back test}
      QH:= QH - 1;  {Add back}
      K:= QH;  RI:= RI0;  DI:= DI0;
      while RI <= IJ do begin
        T:= R.V^[ RI] + Self.V^[ DI] + K;
        K:= Int(T / Base);
        R.V^[ RI]:= T - K * Base;
        Inc( RI);  Inc( DI);
      end;
      T:= R.V^[ RI] + K;
      K:= Int(T / Base);
      R.V^[ RI]:= T - K * Base;
      K:= K + MaxDigit;
      Self.V^[ DI0]:= QH;
    end;
    I:= DI0;  IJ:= I + J;  K:= QH;
    while (I <= IJ) do begin
      T:= Self.V^[I] + K;         {Carry to next super digit}
      K:= Int(T / Base);
      Self.V^[I]:= T - K * Base;
      if K = 0 then  I:= IJ;  {Break out of loop}
      Inc(I);
    end;
    if J < R.N div 2 then begin
      T:= 0;
      for I:= 0 to 4 do begin
        T:= T * Base + R.V^[ R.N - J - I];
      end;
      D4:= 0;
      for I:= 1 to 4 do begin
        D4:= D4 * Base + Self.V^[ Self.N - I];
      end;
      QH:= 1 + Int(T / D4);
      Self.V^[ Self.N - J - 2]:= QH;
    end;
    MuInterrupt;
    if MuAbort then begin
      Self.Clear;  R.Clear;  Exit;
    end;
    if KeyHit then begin
      for I:= 0 to Echo do
        WriteLn( OutP[I]^, 'Integer Square Root: ',
          Trunc( (100.0 * J) / (R.N / 2)), ' Percent done');
      KeyHit:= False;
    end;
  end;
  R.N:= R.N div 2 + 1;
  R.Norm;
  Self.Norm;
  IpDiv1(2, Self, QH);
end; {MultiSI.SqRtRem}

{--------------------------------------}
procedure MultiSI.RSqRtRem( var R : MultiSI); {Self = SqRt( Self), R = Rem}
{Self is moved to R and then R is "divided" in place to give the SqRt in Self}
{and a remainder in R, Self and R may not have the same location in memory}
{Sets MuErr True if error}
begin
  SqRtRem( Self, R);
end; {MultiSI.RSqRtRem}

{--------------------------------------}
procedure MultiSI.SqRoot( var X : MultiSI); {Self = SqRt(X)}
{X is not changed, it is ok for X and Self to have the same location in memory}
{but then X will be changed.  Sets MuErr True if error}
var
  RL : ^MultiSI;
begin
  New( RL, Init( X.N));
  SqRtRem(X, RL^);
  Dispose( RL, Done);
end; {MultiSI.SqRoot}

{--------------------------------------}
procedure MultiSI.RSqRt; {Self = SqRt( Self)}
{Sets MuErr True if error}
begin
  SqRoot( Self);
end; {MultiSI.RSqRt}

{------End of MultiSI's methods--------}

{--------------------------------------}
{   End of method implementation       }
{--------------------------------------}

{--------------------------------------}
{         Other services               }
{--------------------------------------}

{--------------------------------------}
procedure ShiftUp( var St : String); {Shift string to upper case}
var
  I : Integer;
begin
  for I:= 1 to Length( St) do  St[I]:= UpCase( St[I]);
end; {ShiftUp}

{--------------------------------------}
procedure MuWriteErr( St : String); {Write error statement and set error flag}
{Allows St to be a literal string}
var
  I : Integer;
begin
  MuErr:= True;
  if MuErrRep then
    for I:= 0 to Echo do begin
      WriteLn( OutP[I]^, St);  WriteLn( OutP[I]^);
    end;
end; {MuWriteErr}

{--------------------------------------}
procedure ReadLInt( Mess  : String; Min, Max, Nom : LongInt;
                   var II : LongInt);   {Read in a long integer from keyboard}
var
  St   : String[ 255];
  Stat : Integer;
  LI   : LongInt;
  I    : Integer;
begin
  repeat
    repeat
      for I:= 0 to Echo do begin
        WriteLn( OutP[I]^, Mess);
        Write( OutP[I]^, '  [', Min, ', ', Max, '] (ENTER => ', Nom, '): ');
      end;
      ReadLn( St);
      for I:= 1 to Echo do  WriteLn( OutP[I]^, St);
    until IOResult = 0;
    Val( St, LI, Stat);
  until ((Stat = 0) and (LI >= Min) and (LI <= Max)) or (Length( St) = 0);
  if Length( St) = 0 then  LI:= Nom;
  II:= LI;
  for I:= 0 to Echo do begin
    WriteLn( OutP[I]^, 'Input = ', II);
    WriteLn( OutP[I]^);
  end;
end; {ReadLInt}

{--------------------------------------}
procedure ReadInt( Mess  : String; Min, Max, Nom : Integer;
                  var II : Integer);   {Read in an integer from keyboard}
var
  St   : String[ 255];
  Stat : Integer;
  LI   : LongInt;
  I    : Integer;
begin
  repeat
    repeat
      for I:= 0 to Echo do begin
        WriteLn( OutP[I]^, Mess);
        Write( OutP[I]^, '  [', Min, ', ', Max, '] (ENTER => ', Nom, '): ');
      end;
      ReadLn( St);
      for I:= 1 to Echo do  WriteLn( OutP[I]^, St);
    until IOResult = 0;
    Val( St, LI, Stat);
  until ((Stat = 0) and (LI >= Min) and (LI <= Max)) or (Length( St) = 0);
  if Length( St) = 0 then  LI:= Nom;
  II:= LI;
  for I:= 0 to Echo do begin
    WriteLn( OutP[I]^, 'Input = ', II);
    WriteLn( OutP[I]^);
  end;
end; {ReadInt}

{--------------------------------------}
procedure MuSetMMax( NRegs : Integer); {Set MMax}
var
  Max     : LongInt;
  Percent : Integer;
  I       : Integer;
begin
  Max:= MemAvail;
  for I:= 0 to Echo do
    WriteLn( OutP[I]^, 'MemAvail = ', Max);
  ReadInt('Input % of available memory to use:', 0, 100, 100, Percent);
  Max:= ((Max - 256) * Percent) div (100 * NRegs); {Max per register}
  MMax:= (Max - SizeOf( MultiSI)) div SizeOf( Mu1Digit) - 1;
  if MMax > MuNMax then  MMax:= MuNMax;
  if MMax < 5 then  MMax:= 5;
end; {MuSetMMax}

{--------------------------------------}
procedure MuInterrupt; {Test for ESC key pressed to abort operation}
{MuAbort set TRUE if ESC pressed twice, unchanged if no ESC or ESC, SPACE}
const
  Esc = Chr( 27); {ESCAPE}
  Ret = Chr( 13); {RETURN}
var
  I  : Integer;
  Ch : Char;
begin
  If not Keypressed then  Exit;
  while Keypressed do begin
    Ch:= ReadKey;
  end;
  KeyHit:= True;  KeyCh:= Ch;
  if Trace > 0 then begin
    for I:= 0 to Echo do
      WriteLn( OutP[I]^, '<', Tracn, ' ', Trace, '>');
    Trace:= 0;
  end;
  if (Ch <> Esc) or MuAbort then  Exit;
  for I:= 0 to Echo do begin
    WriteLn( OutP[I]^, '*** INTERRUPT:  To Continue Press RETURN Key;');
    WriteLn( OutP[I]^, 'To Abort Computation Press ESCAPE Key.');
    WriteLn( OutP[I]^);
    KeyHit:= False;
  end;
  repeat
    Ch:= ReadKey;
  until (Ch = Esc) or (Ch = Ret);
  if Ch = Ret then  for I:= 0 to Echo do begin
    WriteLn( OutP[I]^, 'Continuing...');  WriteLn( OutP[I]^);
  end;
  if Ch = Esc then begin
    MuAbort:= True;
    for I:= 0 to Echo do begin
      WriteLn( OutP[I]^, 'Computation aborted by operator!');
      WriteLn( OutP[I]^);
    end;
  end;
end; {MuInterrupt}

{---------------------------------------}
function DosClock : Double; {Get the value of the Dos clock in total seconds}
{Only good to 0.01 seconds, must call earlier once each day}
var
  DC   : Double; {Local value of DosClock}
  Regs : Registers; {Registers for Dos calls defined in Turbo Pascal}
{ Regs : record
    case Integer of
    1 : (AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags : Word);
    2 : (AL, AH, BL, BH, CL, CH, DL, DH : Byte);
    end;
}
begin
  Regs.AH:= $2C;
  MsDos( Regs);
  with Regs do
    DC:= DosDays * 86400.0 + CH * 3600.0 + CL * 60.0 + DH + DL / 100.0;
  if DC < DosClockP then begin
    Inc( DosDays);
    DC:= DC + 86400.0;
  end;
  DosClockP:= DC;
  DosClock := DC;
end; {DosClock}

{--------------------------------------}
procedure Diag( Mess : String); {Output a diagnostic message with delta times}
var
  EI   : Integer;
  Del0 : Double; {Total time from TV0}
  Del1 : Double; {Delta time from last Diag call}
begin
  if DiagOn then begin
    TV1:= TV2;  TV2:= DosClock;
    Del0:= TV2 - TV0;
    Del1:= TV2 - TV1;
    for EI:= 0 to Echo do
      WriteLn( OutP[ EI]^, 'T = ', Del0:0:2,
        '  DT = ', Del1:0:2, ' sec.  ',Mess);
  end;
end; {Diag}

{--------End of other services---------}

{--------------------------------------}
{        Initialization section        }
{--------------------------------------}

{Initialize Multi-precision package}
{Input: MuDMax, MuNMax}
{Output: Base, BaseSq, MaxDigit, BSMB, OutP}
{Initialize: MuDpG=5, MuLenD=21, MuErr=False, MuErrRep=True, MuAbort=False,}
{Echo=0, MMax=MuNMax,  TracN=0, Trace=0, DiagOn=False, TV0=TV1=TV2=DosClock}
var  I : Integer;
begin
  Base:= 10;
  for I:= 2 to MuDMax do  Base:= 10 * Base;
  MaxDigit := Base - 1;
  BaseSq   := Base * Base;
  BSMB     := BaseSq - Base;
  MuDpG    := 5;
  MuLenD   := 21;
  MuErr    := False;
  MuErrRep := True;
  MuAbort  := False;
  KeyHit   := False;
  KeyCh    := ' ';
  Echo     := 0;
  OutP[0]  := @Output;  OutP[1]:= @Lst;
  MMax     := MuNMax;
  TracN    := 0;
  Trace    := 0;
  DiagOn   := False;
  DosClockP:= 86400.0;
  DosDays  := 0;
  TV0      := DosClock;
  TV1      := TV0;
  TV2      := TV1;
  MuMaxW   := 65;
  MuTot    := 0;
end. {MultiIDO unit init}

Revisions made -
--------
Changed line in procedure MultiSI.Value from:
  While St[J] = ' ' do  J:= J + J;
to:
  While St[J] = ' ' do  Inc(J); { HJS 91/04/24, 91/09/24 }
--------
  Added procedures SetToEx and GetEx  { HJS 91/05/02 and 91/05/04 }
--------
  Added test of KeyHit in SqRtRem { HJS 91/08/17 }
--------
  Added MuMaxW and MuTot to global vars and MultiSI.Writ { HJS 92/02/07 }
--------

{End of file MultiID.Pas ***************************************************}

Return to Juggler Numbers
Return to Harry's Home Page
This page accessed times since October 20, 2004.
Page created by: hjsmithh@sbcglobal.net
Changes last made on Saturday, 14-May-05 12:49:08 PDT

1