IPB
ЛогинПароль:

> Прочтите прежде чем задавать вопрос!

1. Заголовок темы должен быть информативным. В противном случае тема удаляется ...
2. Все тексты программ должны помещаться в теги [code=pas] ... [/code], либо быть опубликованы на нашем PasteBin в режиме вечного хранения.
3. Прежде чем задавать вопрос, см. "FAQ", если там не нашли ответа, воспользуйтесь ПОИСКОМ, возможно такую задачу уже решали!
4. Не предлагайте свои решения на других языках, кроме Паскаля (исключение - только с согласия модератора).
5. НЕ используйте форум для личного общения, все что не относится к обсуждению темы - на PM!
6. Одна тема - один вопрос (задача)
7. Проверяйте программы перед тем, как разместить их на форуме!!!
8. Спрашивайте и отвечайте четко и по существу!!!

 
 Ответить  Открыть новую тему 
> Сумма квадратов
сообщение
Сообщение #1


Perl. Just code it!
******

Группа: Пользователи
Сообщений: 4 100
Пол: Мужской
Реальное имя: Андрей

Репутация: -  44  +


Продолжаю выкладывать понравившиеся мне олимпиадные задачи

Пара четверок. Найти минимальное число, которое представляется суммой четырех квадратов натуральных чисел не единственным образом

т.е 1112 и 1121 - одно и тоже.


Вот мое первое решение, если доделаю сейчас, выложу втрое, более короткое

uses crt;
var
i,j,k,l,t : byte;
n : word;
a : array[1..4] of byte;
flag : boolean;
begin
clrscr;
n := 0;
repeat
inc(n);
flag := true;
fillchar(a, sizeof(a), 0);
i := 1;
while (sqr(i) < n) and flag do begin
j := 1;
while(sqr(i) + sqr(j) < n) and flag do begin
k := 1;
while(sqr(i) + sqr(j) + sqr(k) < n) do begin
l := 1;
while(sqr(i) + sqr(j) + sqr(k) + sqr(l) <= n) and flag do begin
if sqr(i) + sqr(j) + sqr(k) + sqr(l) < n then inc(l)
else begin
if a[1] = 0 then begin
a[1] := i; a[2] := j; a[3] := k; a[4] := l;
inc(l);
end{A[1] = 0}
else begin
t := 1;
while (t <= 4) and flag do begin
flag := not((a[t] <> i) and (a[t] <> j) and (a[t] <> k) and (a[t] <> l));
inc(t);
end;{WHILE}
if not(flag) then begin
writeln(n);
writeln(i,' ',j,' ',k,' ',l);
writeln(a[1],' ',a[2],' ',a[3],' ',a[4]);
end;{END}
end;{A[1] <> 0}
end;{S = N}
inc(l);
end;{L}
inc(k);
end;{K}
inc(j);
end;{J}
inc(i);
end;{I}
until not(flag);
readln
end.



Давайте, может у кого-то будут координально другие идеи !


--------------------
perl -e 'print for (map{chr(hex)}("4861707079204E6577205965617221"=~/(.{2})/g)), "\n";'
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #2


N337
****

Группа: Пользователи
Сообщений: 737
Пол: Мужской

Репутация: -  26  +


Неопределённость в условии - поэтому два решения. Первое - для случая, когда в сумме могут присутствовать одинаковые слагаемые, второе - для случая, когда все слагаемые различны. Естественно, результаты отличаются.

1) С повторениями:
program Sqr4;

type
T4 = array[0..4] of LongInt;

procedure AdvanceT4(var a: T4);
begin
if a[3] < a[4] then
Inc(a[3])
else
if a[2] < a[3] then
Inc(a[2])
else
if a[1] < a[2] then
Inc(a[1])
else
begin
a[1] := 1;
a[2] := 1;
a[3] := 1;
Inc(a[4]);
end;
Inc(a[0]);
end;

procedure WriteT4(const a: T4);
begin
Writeln(
'= Sqr(', a[1],
') + Sqr(', a[2],
') + Sqr(', a[3],
') + Sqr(', a[4], ')'
);
end;

var
a, b: T4;
na, nb: LongInt;
i: Integer;

begin
for i := 0 to 4 do
begin
a[i] := 1;
b[i] := 1;
end;
repeat
na := Sqr(a[1]) + Sqr(a[2]) + Sqr(a[3]) + Sqr(a[4]);
nb := Sqr(b[1]) + Sqr(b[2]) + Sqr(b[3]) + Sqr(b[4]);
if na < nb then
AdvanceT4(a)
else
if (na > nb) or (a[0] = b[0]) then
AdvanceT4(b)
else
Break;
until False;
Writeln(na);
WriteT4(a);
WriteT4(b);
end.


2) Без повторений:
program Sqr4;

type
T4 = array[0..4] of LongInt;

procedure AdvanceT4(var a: T4);
begin
if a[3] < a[4] - 1 then
Inc(a[3])
else
if a[2] < a[3] - 1 then
Inc(a[2])
else
if a[1] < a[2] - 1 then
Inc(a[1])
else
begin
a[1] := 1;
a[2] := 2;
a[3] := 3;
Inc(a[4]);
end;
Inc(a[0]);
end;

procedure WriteT4(const a: T4);
begin
Writeln(
'= Sqr(', a[1],
') + Sqr(', a[2],
') + Sqr(', a[3],
') + Sqr(', a[4], ')'
);
end;

var
a, b: T4;
na, nb: LongInt;
i: Integer;

begin
for i := 0 to 4 do
begin
a[i] := i;
b[i] := i;
end;
repeat
na := Sqr(a[1]) + Sqr(a[2]) + Sqr(a[3]) + Sqr(a[4]);
nb := Sqr(b[1]) + Sqr(b[2]) + Sqr(b[3]) + Sqr(b[4]);
if na < nb then
AdvanceT4(a)
else
if (na > nb) or (a[0] = b[0]) then
AdvanceT4(b)
else
Break;
until False;
Writeln(na);
WriteT4(a);
WriteT4(b);
end.


--------------------
The idiots are winning.
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #3


Perl. Just code it!
******

Группа: Пользователи
Сообщений: 4 100
Пол: Мужской
Реальное имя: Андрей

Репутация: -  44  +


Особо пока не вникал в твое решение, но в задании надо найти минимальное число, твоя вторая програма выдает 336, а моя как минимальное 28 ...


--------------------
perl -e 'print for (map{chr(hex)}("4861707079204E6577205965617221"=~/(.{2})/g)), "\n";'
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #4


Новичок
*

Группа: Пользователи
Сообщений: 38
Пол: Женский

Репутация: -  0  +


начальные значения
j:=i;
k:=j;
l:=k;

Сообщение отредактировано: Pola -
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #5


Perl. Just code it!
******

Группа: Пользователи
Сообщений: 4 100
Пол: Мужской
Реальное имя: Андрей

Репутация: -  44  +


Нажать кнопку удалить, кстати, я поменял результат не поменялся ... а итераций то явно меньше будет, ну ладно пусть это останется в секрете secret.gif


--------------------
perl -e 'print for (map{chr(hex)}("4861707079204E6577205965617221"=~/(.{2})/g)), "\n";'
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #6


Новичок
*

Группа: Пользователи
Сообщений: 38
Пол: Женский

Репутация: -  0  +


Да, итераций будет меньше
и из
1112
1121
1211
2111
останется только первая комбинация

Цитата(klem4 @ 15.01.2006 14:04) *

Нажать кнопку удалить,

Где она? около сообщения не вижу...
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #7


Perl. Just code it!
******

Группа: Пользователи
Сообщений: 4 100
Пол: Мужской
Реальное имя: Андрей

Репутация: -  44  +


Цитата
Где она? около сообщения не вижу...


Хмм.. возможно сейчас это доступно только модераторам и администраторам, надо узнать ...


--------------------
perl -e 'print for (map{chr(hex)}("4861707079204E6577205965617221"=~/(.{2})/g)), "\n";'
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #8


Новичок
*

Группа: Пользователи
Сообщений: 38
Пол: Женский

Репутация: -  0  +


Ладно, уже не нужно smile.gif

А вот сокращение перебора для олимпиадной задачи дело не последнее...
теперь можно наверное и проверку убрать
Код

                       begin
                         t := 1;
                         while (t <= 4) and flag do begin
                            flag := not((a[t] <> i) and (a[t] <> j) and (a[t] <> k) and (a[t] <> l));
                            inc(t);
                         end;{WHILE}
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #9


Perl. Just code it!
******

Группа: Пользователи
Сообщений: 4 100
Пол: Мужской
Реальное имя: Андрей

Репутация: -  44  +


угу .. good.gif

Занчится пока выходит вот так :

uses crt;
var
i,j,k,l,t : byte;
n : word;
a : array[1..4] of byte;
flag : boolean;
begin
clrscr;
n := 0;
repeat
inc(n);
flag := true;
fillchar(a, sizeof(a), 0);
i := 1;
while (sqr(i) < n) and flag do begin
j := i;
while(sqr(i) + sqr(j) < n) and flag do begin
k := j;
while(sqr(i) + sqr(j) + sqr(k) < n) do begin
l := k;
while(sqr(i) + sqr(j) + sqr(k) + sqr(l) <= n) and flag do begin
if sqr(i) + sqr(j) + sqr(k) + sqr(l) < n then inc(l)
else begin
if a[1] = 0 then begin
a[1] := i; a[2] := j; a[3] := k; a[4] := l;
inc(l);
end{A[1] = 0}
else begin
flag := false;
writeln(n);
writeln(i,' ',j,' ',k,' ',l);
writeln(a[1],' ',a[2],' ',a[3],' ',a[4]);
end;{A[1] <> 0}
end;{S = N}
inc(l);
end;{L}
inc(k);
end;{K}
inc(j);
end;{J}
inc(i);
end;{I}
until not(flag);
readln
end.


я рад что еще кто-то заинтересовался задаче этой smile.gif


--------------------
perl -e 'print for (map{chr(hex)}("4861707079204E6577205965617221"=~/(.{2})/g)), "\n";'
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #10


Новичок
*

Группа: Пользователи
Сообщений: 38
Пол: Женский

Репутация: -  0  +


что такое flag?
почему его нет в третьем while?

Сообщение отредактировано: Pola -
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #11


Perl. Just code it!
******

Группа: Пользователи
Сообщений: 4 100
Пол: Мужской
Реальное имя: Андрей

Репутация: -  44  +


flag принимает false если результат достигнут и тогда больше ничего делать не надо, в 3-м while-е пропустил ...


--------------------
perl -e 'print for (map{chr(hex)}("4861707079204E6577205965617221"=~/(.{2})/g)), "\n";'
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #12


N337
****

Группа: Пользователи
Сообщений: 737
Пол: Мужской

Репутация: -  26  +


Пардон, я напутал с генерацией последовательностей, поэтому из рассмотрения выпадали некоторые четвёрки чисел. Теперь так:
program Sqr4_3;

procedure Next4(var a: array of LongInt);
begin
if a[1] < a[2] then Inc(a[1])
else if a[2] < a[3] then Inc(a[2])
else if a[3] < a[4] then Inc(a[3])
else
begin
a[1] := 1;
a[2] := 1;
a[3] := 1;
Inc(a[4]);
end;
Inc(a[0]);
end;

var
a, b: array[0..4] of LongInt;
na: LongInt;
i: Integer;

begin
for i := 0 to 4 do a[i] := 1;
repeat
na := Sqr(a[1]) + Sqr(a[2]) + Sqr(a[3]) + Sqr(a[4]);
for i := 0 to 4 do b[i] := 1;
while a[0] <> b[0] do
if Sqr(b[1]) + Sqr(b[2]) + Sqr(b[3]) + Sqr(b[4]) <> na then
Next4(b)
else
begin
Writeln(na);
Exit;
end;
Next4(a);
until False;
end.

Конечно, подбор воторой четвёрки можно ограничить и снизу, начиная с (1, 1, 1, Trunc(Sqrt(na / 4))), но, в свете того, что решение без данной оптимизации прекрасно справляется с поставленной задачей (в т. ч., укладывается в разумные временные рамки), будем считать такой подход избыточным усложнением алгоритма и его реализации.

Сообщение отредактировано: xds -


--------------------
The idiots are winning.
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 

 Ответить  Открыть новую тему 
1 чел. читают эту тему (гостей: 1, скрытых пользователей: 0)
Пользователей: 0

 





- Текстовая версия 2.05.2024 2:57
500Gb HDD, 6Gb RAM, 2 Cores, 7 EUR в месяц — такие хостинги правда бывают
Связь с администрацией: bu_gen в домене octagram.name