program Wrg2Tab;                  {Determine the number of kth powers
                                   required to write a given number}
{$N+,E+}
uses crt, printer;
{$I GetInput.i }

const
lines = 20;                       {Number of rows in display}
length = 200;                     {Number of entries in display
                                   is 10 times the number of lines}
MaxK = 10;
PrinterLimit = 999;

var
k,                                {power}
n0                                {table begins at 10n0}
  : integer;
s                                 {number of summands required}
  : array[0..10000] of integer;


OriginalMode                      {original video mode -- will be restored}
  : word;
Ch                                {character read from keyboard}
  : char;
St,                               {prompt}
Stk                               {k expressed as a string}
  : string[80];
PrinterOn,                        {Is the printer responding/}
FuncKey,
InputOk                           {Is the input ok?}
  : Boolean;

procedure MakeTable(k : integer);

var
i, j,                             {indices}
MaxPwr,                           {largest number whose k-th power is needed}
posx,                             {number of x[i] that are positive}
i0,                               {marked index,
                                   used in lexicographic ordering}
i0min,                            {smallest i0 encountered so far}
m,                                {number represented}
r                                 {number of i remaining}
  : longint;
x                                 {variables---k of them}
  : array[0..MaxK] of integer;
pwr                               {k-th powers, computed in advance}
  : array[0..101] of integer;
done                              {is the table complete?}
  : Boolean;

begin
                                  {First we use k summands, and compute the
                                   entries for those i requiring ó k terms}
  MaxPwr := 1 + round(exp(ln(10000)/k));
  pwr[0] := 0;
  for i := 1 to MaxPwr do pwr[i] := round(exp(k*ln(i)));
  for i := 0 to 10000 do s[i] := 0;
  for i := 1 to k - 1 do x[i] := 0;
  x[k] := 1;
  i0 := k;
  i0min := k;
  posx := 1;
  repeat
    m := 0;
    for i := 1 to k do m := m + pwr[x[i]];
                                  {form the sum of k k-th powers}
    if m <= 10000
    then
      begin
        if s[m] = 0               {m has not been hit before}
        then s[m] := posx;
        x[k] := x[k]+1
      end
    else
      begin
        i0 := k-1;
        while (x[i0] = x[i0+1]) and (i0 >= 1) do i0 := i0 - 1;
                                  {find i0 so that
                                   x[i0] < x[i0+1] = ... = x[k]}
        if i0 < i0min
        then
          begin
            i0min := i0;
            posx := k + 1 - i0
          end;
        if i0 > 0
        then
          begin
            x[i0] := x[i0]+1;
            for i := i0 + 1 to k do x[i]  := x[i0]
          end
      end
  until i0 = 0;
  repeat
    done := true;
    for i := 10000 downto 1 do
    if s[i] = 0
    then
      begin
        j := 1;
        m := i-1;
        repeat
          if s[m] > 0
          then s[i] := s[m]+1
          else
            begin
              j := j + 1;
              m := i - pwr[j]
            end
        until (s[i] > 0) or (m <= 0);
        if m <= 0
        then done := false
      end;
  until done;
end;                              {of procedure MakeTable}

procedure Display;

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

begin
  TextColor(15);
  TextBackground(0);
  ClrScr;
  if k = 2
  then WriteLn('                    WARING''S PROBLEM FOR SUMS OF SQUARES');
  if k = 3
  then WriteLn('                     WARING''S PROBLEM FOR SUMS OF CUBES');
  if k > 3
  then
    begin
      Write('                    WARING''S PROBLEM FOR SUMS OF ');
      WriteLn(k:1, '-TH POWERS')
    end;
  WriteLn;
  Write('    n     10n   10n+1  10n+2  10n+3  10n+4  10n+5  10n+6  ');
  WriteLn('10n+7  10n+8  10n+9');
  for i := n0 to n0 + lines - 1 do
    begin
      Write(i:6);
      TextColor(14);
      TextBackground(1);
      if i = 0
      then Write('       ')
      else Write(s[10*i]:7);
      for j := 1 to 9 do Write(s[10*i+j]:7);
      Write('  ');
      TextColor(15);
      TextBackground(0);
      WriteLn
    end;
  WriteLn;
  GoToXY(1, 25);
  TextBackground(7);
  ClrEoL;
  if n0 > 0
  then TextColor(4)
  else TextColor(15);
  Write('     PgUp');
  if n0 < 980
  then TextColor(4)
  else TextColor(15);
  Write('          PgDn');
  TextColor(4);
  Write('          k          N');
  if PrinterOn
  then
    begin
      TextColor(4);
      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, j                              {indices}
  : integer;

begin
  if k = 2
  then
    begin
      Write(lst, '                    WARING''S PROBLEM');
      WriteLn(lst, ' FOR SUMS OF SQUARES')
    end;
  if k = 3
  then
    begin
      Write(lst, '                            WARING''S PROBLEM');
      WriteLn(lst, ' FOR SUMS OF CUBES')
    end;
  if k > 3
  then
    begin
      Write(lst, '                    WARING''S PROBLEM FOR SUMS OF ');
      WriteLn(lst, k:1, '-TH POWERS')
    end;
  WriteLn(lst);
  Write(lst, '    n     10n   10n+1  10n+2  10n+3  10n+4  10n+5  10n+6  ');
  WriteLn(lst, '10n+7  10n+8  10n+9');
  for i := 0 to PrinterLimit do
    begin
      Write(lst, i:6);
      if i = 0
      then Write(lst, '       ')
      else Write(lst, s[10*i]:7);
      for j := 1 to 9 do Write(lst, s[10*i+j]:7);
      WriteLn(lst)
    end;
  WriteLn(lst)
end;                              {of procedure PrinTab}

begin                             {main body}
  OriginalMode := LastMode;
  TextBackground(1);
  TextColor(14);
  ClrScr;
  GoToXY(30, 8);
  Write('WARING''S PROBLEM');
  GoToXY(10,10);
  WriteLn('Will determine the least number of k-th powers required');
  WriteLn('         to represent a given integer n, for 1 ó n < 10000.');
  str(MaxK:1, St);
  St := '                                 (2 ó k ó ' + St + ')';
  k := round(GetInput(10, WhereY,
        'Begin by choosing the power, k = ', St, 2, MaxK));
  WriteLn;
  Write('                     Computing values . . . ');
  MakeTable(k);
  Ch := 'F';
  FuncKey := False;
  n0 := 0;
  Repeat
    {$I-}
    Write(lst,#0);
    if IOResult = 0
    then PrinterOn := True
    else PrinterOn := False;
    {$I+}
    if (not FuncKey) and (UpCase(Ch) = 'K')
    then
      begin
        str(Maxk:1, Stk);
        St := '          (2 ó k ó ' + Stk + ')';
        k := round(GetInput(1, 24, 'Enter exponent k = ', St, 2, Maxk));
        n0 := 0;
        Write('                        Computing values . . . ');
        MakeTable(k)
      end;
    if (not FuncKey) and (UpCase(Ch) = 'N')
    then
      n0 := round(GetInput(1, 24, 'Start table at 10N, where  N = ',
                    '                      (0 ó N ó 980)', 0, 980));
    if (not FuncKey) and (UpCase(Ch) = 'P')
    then PrinTab;
    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 > 980 then n0 := 980;
      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)
      then InputOk := True;
      if FuncKey and (Ch = #81) and (n0 < 980)
      then InputOk := True;
      if (not FuncKey) and (Ch IN [#27, 'k', 'K', 'n', 'N'])
      then InputOk := true;
      if (PrinterOn) and (not FuncKey) and (UpCase(Ch) = 'P')
      then InputOk := True
    until InputOk
  until (not FuncKey) and (Ch = #27);       {Esc was pressed}
  TextMode(OriginalMode)
end.