program pwrdem2;          {Demonstration of alternative powering
                           algorithm}
{$N+,E+}
uses CRT, nothy ;
{$I GetInput.i }

const
MaxAllow = 1E18;

var
a,                        {the base}
k,                        {the exponent}
m,                        {the modulus}
p,                        {product being formed}
e,                        {= 0 or 1 -- the value of k (mod 2)}
q,                        {quotient}
t,                        {least power of 2 > k}
a0,                       {original base}
k0                        {original exponent}
         : comp;

x        : extended;
i,                        {an index}
j,                        {number of leading bits in binary expansion}
l,                        {l = length(Binaryk}
code,                     {Error code in translating a string
                           to a real number}
x0                        {cursor coordinate}
         : integer;
Ch       : char;
St,
Binaryk,
ExpStr1,
ExpStr2  : string[80];

procedure Prompt;

var
x0, y0                    {coordinates of cursor location}
         : integer;
Ch       : Char;

begin
  x0 := WhereX;
  y0 := WhereY;
  if y0 = 25
  then
    begin
      WriteLn;
      y0 := 24
    end;
  GoToXY(1, 25);
  ClrEoL;
  Write('                         Press any key to continue ... ');
  Ch := ReadKey;
  if Ch = #0
  then Ch := ReadKey;
  GoToXY(1, 25);
  ClrEoL;
  GoToXY(x0, y0)
end;                              {of procedure Prompt}

begin                             {main body}
  if ParamCount = 3
  then
    begin
      Val(ParamStr(1), x, code);
      if (frac(x) = 0) and (code = 0) and (Abs(x) < MaxAllow)
      then a := x
      else Halt;
      Val(ParamStr(2), x, code);
      if (frac(x) = 0) and (code = 0) and (x >= 0) and (x < MaxAllow)
      then k := x
      else Halt;
      Val(ParamStr(3), x, code);
      if (frac(x) = 0) and (code = 0) and (x > 0) and (x < MaxAllow)
      then m := x
      else Halt
    end
  else
    begin
      str(MaxAllow-1:1:0, St);
      WriteLn('Will find a^k (mod m) where');
      a := GetInput(WhereX, WhereY, '    a = ',
            '  ³a³ ó ' + St, -MaxAllow+1, MaxAllow-1);
      k := GetInput(WhereX, WhereY, '    k = ',
            '0 ó k ó ' + St, 0, MaxAllow-1);
      m := GetInput(WhereX, WhereY, '    m = ',
            '0 < m ó ' + St, 1, MaxAllow-1);
    end;
  ClrScr;
  Write('          This is a demonstration of an ');
  WriteLn('alternative method of powering.');
  Write('     Like the other method, it depends ');
  WriteLn('on repeated squaring, and the');
  Write('     number of multiplications ');
  WriteLn('performed is exactly the same:');
  Write('     [log k/log 2] + w(k), where w(k), ');
  WriteLn('called the `binary weight'' ');
  Write('     of k, is the number of 1''s ');
  WriteLn('in the binary expansion of k.');
  Write('     In this method the binary expansion ');
  WriteLn('of k is accessed from the top');
  Write('     down.  When a 1 is found in the binary ');
  WriteLn('expansion, the existing');
  Write('     power is multiplied by a.  This offers an ');
  WriteLn('advantage of speed in');
  Write('     situations in which multiplication ');
  WriteLn('by a is faster than most other');
  WriteLn('     multiplications.');
  Write('          For clarity, as the calculation ');
  WriteLn('is performed, all exponents');
  WriteLn('     are displayed in binary.  The desired exponent is');
  WriteLn('      k = ', k:1:0, ' (decimal)');
  t := 1;                         {The first step is to determine the binary}
  l := 0;                         {expansion of k}
  while t <= k do
    begin
      t := 2*t;
      l := l + 1
    end;                          {t is now the least power of 2 > k}
  Binaryk := '';                  {l will be length(Binaryk) }
  k0 := k;                        {when Binaryk has been determined.}
  j := 0;
  while k0 > 0 do
    begin
      j := j + 1;
      k0 := 2*k0;
      if k0 >= t
      then
        begin
          k0 := k0 - t;
          Binaryk := Binaryk + '1'
        end
      else Binaryk := Binaryk + '0';
    end;
                        {All the non-zero digits in the binary expansion}
                        {of k are now in Binaryk, but the trailing 0's}
                        {must be appended.  There are l - j trailing 0's}
  for i := 1 to l - j do Binaryk := Binaryk + '0';
  if Binaryk = ''
  then Binaryk := '0';
  WriteLn('        = ', Binaryk + ' (binary)');
  WriteLn;
  Prompt;
  p := 1;
  WriteLn;
  WriteLn;
  ExpStr1 := Binaryk;
  ExpStr2 := '';
  while ExpStr1 <> '' do
    begin
      Ch := ExpStr1[1];
      Delete(ExpStr1, 1, 1);
      if ExpStr2 <> ''
      then
        begin
          Write(a:1:0);
          GoToXY(WhereX, WhereY - 1);
          Write(ExpStr2 + '0');
          GoToXY(WhereX, WhereY + 1);
          x0 := WhereX;
          Write(' = ', a:1:0);
          GoToXY(WhereX, WhereY - 1);
          Write(ExpStr2);
          GoToXY(WhereX, WhereY + 1);
          Write('ù', a:1:0);
          GoToXY(WhereX, WhereY - 1);
          Write(ExpStr2);
          GoToXY(WhereX, WhereY + 1);
          WriteLn;
          WriteLn;
          GoToXY(x0, WhereY);
          WriteLn(' ð ', p:1:0, 'ù', p:1:0);
          WriteLn;
          GoToXY(x0, WhereY);
          p := mult(p, p, m);
          Write(' ð ', p:1:0, ' (mod ', m:1:0, ')');
          WriteLn;
          WriteLn;
          WriteLn;
          Prompt
        end;
      if Ch = '1'
      then
        begin
          Write(a:1:0);
          GoToXY(WhereX, WhereY - 1);
          Write(ExpStr2 + '1');
          GoToXY(WhereX, WhereY + 1);
          x0 := WhereX;
          Write(' = ', a:1:0);
          GoToXY(WhereX, WhereY - 1);
          Write(ExpStr2 + '0');
          GoToXY(WhereX, WhereY + 1);
          WriteLn('ù', a:1:0);
          WriteLn;
          GoToXY(x0, WhereY);
          WriteLn(' ð ', p:1:0, 'ù', a:1:0);
          WriteLn;
          GoToXY(x0, WhereY);
          p := mult(p, a, m);
          WriteLn(' ð ', p:1:0, ' (mod ', m:1:0, ')');
          WriteLn;
          WriteLn;
          Prompt
        end;
      ExpStr2 := ExpStr2 + Ch;
    end;
  WriteLn;
  Write(a:1:0);
  GoToXY(WhereX, WhereY - 1);
  Write(k:1:0);
  GoToXY(WhereX, WhereY + 1);
  WriteLn(' ð ', p:1:0, ' (mod ', m:1:0, ')');
end.