program WrgCnTab;                 {Number of solutions of congruence
                                   x_1^k + ... + x_s^k ð n (mod m)}
{$R+,N+,E+}
uses crt, nothy, printer;
{$I GetInput.i }

const
MaxM = 4999;                      {maximum allowed size of modulus}
MaxK = 10;
MaxS = 75;
PrinterLimit = 500;               {number of lines the printer is allowed}

var
n,                                {residue class represented}
m,                                {modulus}
f,                                {factor relating to multiplicity of repn}
q,                                {m^(s-1)}
cs,                               {a check sum}
y                                 {a k-th power}
  : comp;
n0,                               {view of table begins at n0}
i, j,                             {indices}
k,                                {power}
s                                 {number of summands}
  : integer;
r,                                {number of solutions of the congruence}
pwr                               {pwr[i] is a k-th power}
  : array[0..MaxM-1] of longint;
mul                               {x^k ð pwr[i] has mul[i] solutions}
  : array[0..MaxM-1] of integer;
x
  : array[0..MaxS] of integer;
OriginalMode                      {original video mode -- will be restored}
  : word;
Ch                                {character read from keyboard}
  : char;
St                                {prompt}
  : string[80];
FuncKey,                          {Was a function key pressed?}
InputOk                           {Is the input ok?}
  : Boolean;

procedure Reps(m : longint);      {calculate the number of representations}

var
i0                                {marked index for incrementing}
  : integer;
h,                                {multiplicity of summand}
n                                 {number represented}
  : comp;
begin
  for i := 0 to m - 1 do          {initialize arrays}
    begin
      r[i] := 0;
      pwr[i] := 0;
      mul[i] := 0
    end;
  for i := 0 to  m - 1 do         {determine how many time each residue is  }
    begin                         {a k-th power}
      y := power(i, k, m);
      mul[round(y)] := mul[round(y)] + 1
    end;
  j := 0;
  for i := 0 to m - 1 do          {consolidate list of k-th powers
                                   and multiplicities}
    begin
      if mul[i] > 0
      then
        begin
          mul[j] := mul[i];
          pwr[j] := i;
          j := j + 1
        end
    end;
  for i := j to m do              {clear remainder of arrays}
    begin
      mul[i] := 0;
      pwr[i] := 0
    end;
  for i := 1 to s do x[i] := 0;
  i0 := s;
  repeat
    if mul[x[s]] > 0
    then
      begin
        n := 0;
        for i := 1 to s do n := n + pwr[x[i]];
        n := condition(n, m);
        f := 1;
        for i := 1 to s do f := f*mul[x[i]];
        j := 1;
        for i := 1 to s do
          begin
            if (i > 1) and (x[i] = x[i-1])
            then j := j + 1
            else j := 1;
            f := f*i/j
          end;
        r[round(n)] := r[round(n)] + round(f);
        x[s] := x[s] + 1
      end
    else
      begin
        i0 := s - 1;
        while (x[i0] = x[i0+1]) and (i0 >= 1) do i0 := i0 - 1;
                        {find i0 so that x[i0] < x[i0+1] = ... = x[s]}
        if i0 > 0
        then
          begin
            x[i0] := x[i0]+1;
            for i := i0+1 to s do x[i] := x[i0]
          end;
        if (i0 <= s - k) and (KeyPressed)    {allow termination}
        then
          begin
            TextMode(OriginalMode);
            Halt
          end
      end;
  until i0 = 0;
  q := 1;
  for i := 1 to s-1 do q := q*m;
  cs := 0;                        {check that the sum of r[n] is m^s}
  for i := 0 to round(m-1) do cs := cs + r[i];
  if cs <> m*q
  then
    begin
      TextMode(OriginalMode);
      ClrScr;
      GoToXY(10, 10);
      Write('Error in computation of number of representations.');
      Halt
    end
end;                              {of procedure Reps}

procedure Display;                {display data on the screen}

var
i                                 {index of rows in table}
  : integer;

begin
  TextColor(15);
  TextBackground(0);
  ClrScr;
  Write('             WARING''S CONGRUENCE FOR SUMS OF ', s:1);
  if k = 2
  then Write(' SQUARES ');
  if k = 3
  then Write(' CUBES ');
  if k > 3
  then Write(' ', k:1, '-th POWERS ');
  WriteLn('(mod ', m:1:0, ')');
  WriteLn;
  WriteLn('                   n             r(n)       r(n)/m^(s-1)');
  n := n0;
  while (n <= n0 + 19) and (n < m) do
    begin
      Write(n:21:0, '  ');
      TextColor(14);
      TextBackground(1);
      WriteLn(r[round(n)]:15, r[round(n)]/q:16:6, '  ');
      TextColor(15);
      TextBackground(0);
      n := n + 1
    end;
  TextBackground(7);
  GoToXY(1, 25);
  ClrEoL;
  if n0 > 0
  then TextColor(4)
  else TextColor(15);
  Write('   PgUp           ');
  if n0 + 20 < m
  then TextColor(4)
  else TextColor(15);
  Write('PgDn           ');
  if m > 20
  then TextColor(4)
  else TextColor(15);
  Write('n           ');
  TextColor(4);
  Write('m           ');
  if m <= PrinterLimit
  then
    begin
      Write('P');
      TextColor(0);
      Write('rint           ')
    end
  else
    begin
      TextColor(15);
      Write('Print           ')
    end;
  TextColor(4);
  Write('Esc');
  GoToXY(1, 25);                  {hide the cursor}
  TextColor(7);
  Write(' ');
  GoToXY(1, 25);
  TextColor(0)
end;                              {of procedure Display}

procedure PrinTab;                {print the table}

var
i                                 {index}
  : integer;

begin
  WriteLn(lst);
  Write(lst, '             WARING''S CONGRUENCE FOR SUMS OF ', s:1);
  if k = 2
  then Write(lst, ' SQUARES ');
  if k = 3
  then Write(lst, ' CUBES ');
  if k > 3
  then Write(lst, ' ', k:1, '-th POWERS ');
  WriteLn(lst, '(mod ', m:1:0, ')');
  WriteLn(lst);
  WriteLn(lst, '                   n             r(n)       r(n)/m^(s-1)');
  i := 0;
  while i < m do
    begin
      Write(lst, i:21, '  ');
      WriteLn(lst, r[i]:15, r[i]/q:16:6, '  ');
      i := i + 1
    end;
  WriteLn(lst)
end;                              {of PrinTab}

begin                             {main body}
  OriginalMode := LastMode;
  TextBackground(1);
  TextColor(14);
  ClrScr;
  Ch := 'F';                      {'F' is not an option below}
  FuncKey := False;
  WriteLn('                     WARING''S CONGRUENCE (mod m)');
  WriteLn;
  WriteLn('          In order to write n as a sum of s k-th powers,');
  WriteLn;
  WriteLn;
  Write('                  n = x_1');
  GoToXY(WhereX, WhereY-1);
  Write('k');
  GoToXY(WhereX, WhereY+1);
  Write(' + ùùù + x_s');
  GoToXY(WhereX, WhereY-1);
  Write('k');
  GoToXY(WhereX, WhereY+1);
  WriteLn(',');
  WriteLn;
  WriteLn('     it is necessary that the corresponding congruence');
  WriteLn;
  WriteLn;
  Write('                  n ð x_1');
  GoToXY(WhereX, WhereY-1);
  Write('k');
  GoToXY(WhereX, WhereY+1);
  Write(' + ùùù + x_s');
  GoToXY(WhereX, WhereY-1);
  Write('k');
  GoToXY(WhereX, WhereY+1);
  WriteLn(' (mod m)');
  WriteLn;
  WriteLn('     can be solved for every positive integer m.  For given');
  WriteLn('     values of s, k, and m, will construct a table of the ');
  WriteLn('     number r(n) of solutions of this congruence.  Since the');
  WriteLn('     average of the r(n) is m^(s-1), it is useful to inspect');
  WriteLn('     both r(n) and r(n)/m^(s-1).');
  WriteLn('          WARNING: The amount of calculation is roughly m^s,');
  WriteLn('     so keep the parameters small.');
  WriteLn;
  str(MaxS:1, St);
  St := '                               (1 ó s ó ' + St + ')';
  s := round(GetInput(6, WhereY, 'Choose the number of summands, s = ',
             St, 1, MaxS));
  GoToXY(1, WhereY-1);
  ClrEoL;
  WriteLn('                                    s = ', s:1);
  str(MaxK, St);
  St := '                                   (2 ó k ó ' + St + ')';
  k := round(GetInput(16, WhereY, 'Select the exponent, k = ',
                      St, 2, MaxK));
  GoToXY(1, WhereY - 1);
  ClrEoL;
  GoToXY(37, WhereY);
  WriteLn('k = ', k:1);
  str(MaxM, St);
  St := '                               (1 ó m ó ' + St + ')';
  m := GetInput(20, WhereY, ' Choose modulus, m = ', St, 1, MaxM);
  GoToXY(1, WhereY-1);
  ClrEoL;
  GoToXY(37, WhereY);
  WriteLn('m = ', m:1:0);
  WriteLn;
  Write('           Computing valuesÄÄÄpress any key to terminate . . . ');
  Reps(round(m));
  n0 := 0;
  Repeat
    if FuncKey and (Ch = #73)     {PgUp}
    then
      begin
        n0 := n0 - 20;
        if n0 < 0
        then n0 := 0
      end;
    if FuncKey and (Ch = #81)     {PgDn}
    then
      begin
        n0 := n0 + 20;
        if n0 + 19 >= m
        then n0 := round(m) - 20
      end;
    if (not FuncKey) and (UpCase(Ch) = 'N')
    then
      begin
        str((m-20):1:0, St);
        St := '                   (0 ó n ó ' + St + ')';
        n0 := round(GetInput(10, 24, 'View table starting at line n = ',
                             St, 0, m - 20))
      end;
    if (not FuncKey) and (UpCase(Ch) = 'M')
    then
      begin
        str(MaxM:1, St);
        St := '                      (1 ó m ó ' + St + ')';
        m := GetInput(1, 24, '           Choose modulus, m = ', St, 1, MaxM);
        n0 := 0;
        Write('           Computing values');
        Write('ÄÄÄpress any key to terminate . . . ');
        Reps(round(m))
      end;
    if (not FuncKey) and (UpCase(Ch) = 'P')
    then
      begin
        ClrEoL;
        Write('                    Printing table . . . ');
        PrinTab
      end;
    Display;
    repeat
      Ch := ReadKey;
      if Ch <> #0
      then FuncKey := False
      else
        begin
          FuncKey := True;
          Ch := ReadKey
        end;
      InputOk := False;
      if FuncKey and (Ch = #73) and (n0 > 0)  {PgUp}
      then InputOk := True;
      if FuncKey and (Ch = #81) and (n0 + 20 < m)   {PgDn}
      then InputOk := True;
                                  {These are extended scan codes of function
                                   keys.  Some other handy ones are:
                                      #72   UpArrow
                                      #75   LeftArrow
                                      #77   RightArrow
                                      #80   DownArrow}
      if (not FuncKey) and (Ch = #27)
      then InputOk := true;
      if (not FuncKey) and (UpCase(Ch) = 'M')
      then InputOk := True;
      if (not FuncKey) and (UpCase(Ch) = 'N') and (m > 20)
      then InputOk := True;
      if (not FuncKey) and (UpCase(Ch) = 'P')
      then InputOk := True;
    until InputOk
  until (not FuncKey) and (Ch = #27);         {Esc was pressed}
  TextMode(OriginalMode)
end.