народ, помогите пож решить олимпиадную задачку

[Ламер_001]

вот соптимизировал, вроде все отлично работает. при 1000 где то 5 сек считает.

{$APPTYPE CONSOLE}

var x,y,z,r,k,y_n,z_n:integer;

BEGIN
  readln(r);
  k := 6; {"нулевые"}
  for x:= 1 to r-1 do
   begin
    y_n := trunc(sqrt(r*r - x*x));
    for y:= 0 to y_n do
    begin
     z_n:= trunc(sqrt(r*r - x*x - y*y));
     for z:= 0 to z_n do
      if r*r = ( x*x + z*z + y*y ) then
       if z=0 then
        begin
         if y=0 then k:=k+2
         else k:=k+4;
        end
       else k:=k+8;
    end;
   end;
  writeln(k);
  readln;
end.

теперь объясняю.
нам необходимо найти целые {x, y, z} удовл. условию x*x + y*y + z*z = r*r.
т.к. в условии не говорится о равенстве вещественных числе (т.е. когда одно вещественное число равно другому), то соответственно надо перебирать множество целых, как сделал puporev. но при граничных условиях программа должна будет пройти слишком большой чикл, который естественно вылезет за пределы по времени. я предлогаю следующую оптимизацию:
берем числа [1..r-1], т.е. будем считать что первое целое число x мы нашли. затем ищем второе целое, меньшее чем sqrt(r*r-x*x) т.е которое сможет войти в уравнение x*x + y*y + z*z = r*r, при известных x и r. после в 3 ем цикле ищем последнее целое, меньшее чем sqrt(r*r-x*x-y*y). если наши числа удовлетворяют условию то нам необходимо найти симметричные им. если нет нулевых значений то количество симметричных будет равно 8, если же 1 из них нулевая то 4, ну и если содержится 2 нулевых то 2 симметричных точки, хотя последнее условие никогда не выполнится в силу первого цикла, но пусть будет

оптимизация: если 5 сек много то сузить диапозон поиска, и учесть это в месте наращивания k.
спасибо за внимание.

вопросы?

[puporev]

Вообще-то решаем в Паскале, где Ваша программа при r=190 уже вылетает с ошибкой 207, а при замене integer на Longint, считает даже значительно дольше, чем у меня.

[Ламер_001]

1) она никак не может работать дольше т.к. Ваша перебирает ВСЕ значения, в то время как у меня те которые не выходят за пределы.
2) ничего она не вылетает а выдает 630, столько же сколько и ваша (только если во все циклы идут от -R до R)
3) что бы перевести ее в паскаль уберите {$APPTYPE CONSOLE}

[puporev]

что бы перевести ее в паскаль уберите {$APPTYPE CONSOLE}

Надо же! А я и не знал. Это Вы уберите и прогоните программу в Паскале вместо умственных заключений по принципу "Этого не может быть, потому, что этого не может быть никогда".

[Ламер_001]

не знали - теперь будете знать.
у меня нет паскаля только дельфя 7.
предъявите пожалуйста картинку или пусть нас кто нибудь рассудит
З.Ы. кстати на олимпиадах почти везде стоит компилятор дельфийский для паскалевских решений

[alexBlack]

Сразу предупрежу: это Delphi

function getCountPointSphere(R:integer):integer;
var z, x, y, c, k:integer;
    Rz2, a : integer;
begin
   result := 1;
   if R <= 0 then exit;
   result := 2;

   Rz2 := R*R; k := 4;
   for z := 0 to R-1 do begin
      x := trunc(sqrt(Rz2)); // R2-z2
      y := 0;
      a := x*x+ {y*y+} -Rz2;
      c := 0;
      while (x >= y) do begin
         if a = 0 then
            if (y = 0) or (x = y)
            then inc(c)
            else inc(c, 2);

         if abs(a - (2*x-1)) < abs(a + (2*y+1))
         then begin
            dec(a, 2*x-1); dec(x)
         end else begin
            inc(a, 2*y+1); inc(y);
         end;
      end;

      inc(result, c*k);
      dec(Rz2, 2*z+1);
      k := 8;
   end;
end;

var T:DWORD;
    c, i{, c1}:integer;
begin
   T := getTickCount;
   //c1 := 0;
   for i := 0 to 1000 do begin
      c := getCountPointSphere(i);
      //c1 := c1 +c;
      if (i < 15) or (i mod 107 = 0) then Writeln(i, ' -> ', c);
   end;
   WriteLn({c1, ' ', }GetTickCount - T, ' ms.');
   readln;
end.

На все вычисления 2 секунды. Еще бы корень убрать...

[puporev]

Вот это класс! Для R=1000 в Турбо Паскаль 7.0 считает доли секуды.
Весь массив примерно 35 секунд.
P.S.
При типе integer выбрасывает, заменил на Longint, стало 35 секунд. Потом дошло сделать Word, стало тоже пару секунд, не измерял.

[lexus_ilia]

предъявите пожалуйста картинку или пусть нас кто нибудь рассудит

Легко, при r=182 прога выдала Error:207 ...
А вот и скрины, смотрите сами...

[puporev]

Потом дошло сделать Word, стало тоже пару секунд, не измерял.

Глупость. Работает быстро, но для больших значений выдает неверные результаты. Максимум что за счет типов сделал, 3-5 секунд отыграл.
Но в задании и нет прогонять весь массив.

[alexBlack]

Вот этот вариант в BP считает 4-5 сек.:

uses dos;

function getCount3(R:word):word;
var z, x, y, c, k:word;
    Rz2, a : longint;
    result : word;
    x1, y1:word;
begin
   result := 1;
   if R = 0 then begin
      getCount3 := result;
      exit;
   end;
   result := 2;

   Rz2 := longint(R)*R; { R2-z2 }
   k := 4;
   for z := 0 to R-1 do begin
      x := trunc(sqrt(Rz2));
      y := 0;
      a := longint(x)*x+ {y*y+} -Rz2;
      c := 0;
      while (x >= y) do begin
         if a = 0 then
            if (y = 0) or (x = y)
            then inc(c)
            else inc(c, 2);

         x1 := 2*x-1; 
         y1 := 2*y+1;
         if abs(a - x1) < abs(a + y1)
         then begin
            dec(a, x1); dec(x)
         end else begin
            inc(a, y1); inc(y);
         end;
      end;

      inc(result, c*k);
      dec(Rz2, 2*z+1);
      k := 8;
   end;
   getCount3 := result;
end;

var H, M, S, S100, T:word;
    c, i, c1:longint;
begin
   c1 := 0;
   getTime(H, M, S, S100); T := M*60+S;
   for i := 0 to 1000 do begin
      c := getCount3(i);
      c1 := c1 + c;
      if i mod 107 = 0 then Writeln(i, ' -> ', c);
   end;
   getTime(H, M, S, S100);

   WriteLn(c1, ' ', M*60+S - T);
   { c1 - контрольное значение = 2695201 }
   readln;
end.