Помогите пожалуйста со следующей задачей: Разделить одномерный массив на 3 части, которые по возможности имеют минимальное расхождение сумм. Например: исходный массив - 1 2 3 4 5 6, полученые массивы - 6 1, 5 2, 3 4. Необязательно чтоб в полученном массиве было одинаковое количество чисел. Я пробывал что-то сделать но ответ выводится неправильно. Не понял только как сделать так чтобы выводились 3 массива которые бы включали все введенные числа.
uses crt;
var
a,b:array[1..100] of integer;
n:byte;
sym:integer;sum,k:real;
f:boolean;
i,j,h,s,rab:integer;
begin
{Vvodim vse podryat}
clrscr;
Writeln('Vvedite kolichestvo elimentov massiva<=100');
Readln(n);
for i:=1 to n do
begin
writeln(i,' :eliment');
readln(a[i]);
end;
{sortirovka elementov}
begin
for j:=1 to n-1 do
for i:=1 to n-1 do
if a[i]>a[i+1] then begin
rab:=a[i];
a[i]:=a[i+1];
a[i+1]:=rab;
end;
end;
sym:=0;
for i:=1 to n do
sym:=sym+a[i];
sum:=sym/3;
{Nachinaetsya glavniji cikl
idem sverhu v niz}
for i:=n downto 1 do
begin
s:=1;
b[1]:=a[i];
repeat
h:=1;
k:=sum-a[i]; {vichitaem naibol'shiji eliment podposledovatel'nosti
i nachinaem proveryat' so sledueshigo}
if k=0 then begin write(a[i]);break;end {dobavil proverku pered
ciklom}
else
begin
for j:=i-s downto 1 do
begin
if k<a[j] then continue else {esli eliment bol'she k, to
idem k sleduushimu}
begin
k:=k-a[j];
inc(h);b[h]:=a[j]; {sohronyaem na vsyakji sluchaji}
if k=0 then break; {esli k=0 vihodim iz cikla}
end;
end;
if k=0 then {proviryam esli k=0, to raspichativaem
posledovatel'nost', esli net
to posledovatel'nosti s dannim
naibol'shim chlenom izchrponi, perehodim k
sleduushimu}
begin
writeln;
for j:=1 to h do write(b[j],' ');f:=true;inc(s);
end else f:=false;
end; {konec dobavki}
until not f;
end;
repeat until keypressed;
end.
http://forum.pascal.net.ru/index.php?s=&showtopic=16110&view=findpost&p=94429
Хотя нет, там немного другое условие дробления ...
По той ссылке задача решена но немножко не так. При том массиве что там в программе( 12345 ) в ответе выводится 1->1,2->2,3->5. а по программе должно выводится 5 14 23
Решил сам программу до конца. Выкладываю код. Возможно кому-то понадобится в будущем.
uses crt;
var a:array[1..100] of integer;
a1,a2,a3:array[1..34] of integer;
prom,n,prom_n:integer;
n1,n2,n3:integer;
sum,nn:real;
i,k,j,m:integer;
begin
clrscr;
write('vvedite kolichestvo elementov massiva(<=100):');
readln(n);
for i:=1 to n do
begin
write('vvedite',i,'element massiva:');
readln(a[i]);
end;
{-------------}
for i:=2 to n do
begin
for j:=1 to i-1 do
begin
if (a[i]>a[j]) then
begin
prom:=a[i];
for k:=i-1 downto j do a[k+1]:=a[k];
a[j]:=prom;
end;
end;
end;
{sum:=0;
for i:1 to n do sum:=sum+a[i];
sum:=sum/3;}
nn:=n/3;
if (frac(nn)=0) then
begin
prom_n:=trunc(nn);
if((prom_n mod 2)=0) then
begin
n1:=trunc(prom_n/2);
n2:=trunc(prom_n/2);
{first array}
j:=1;
for i:=1 to n1 do
begin
a1[j]:=a[i];
j:=j+1;
a1[j]:=a[n-i+1];
j:=j+1;
end;
{second array}
j:=1;
for i:=n1+1 to n1+n2 do
begin
a2[j]:=a[i];
j:=j+1;
a2[j]:=a[n-i+1];
j:=j+1;
end;
{third array}
j:=1;
for i:=n1+n2+1 to n-n1-n2 do
begin
a3[j]:=a[i];
j:=j+1;
end;
n1:=prom_n;
n2:=prom_n;
n3:=prom_n;
end
else
begin
n1:=trunc(prom_n/2)+1;
n2:=trunc(prom_n/2)+1;
{first array}
j:=1;
for i:=1 to n1 do
begin
if(i<n1) then
begin
a1[j]:=a[i];
j:=j+1;
a1[j]:=a[n-i+1];
j:=j+1;
end
else
begin
a1[j]:=a[n-i+1];
j:=j+1;
end;
end;
{second array}
j:=1;
for i:=n1 to n1+n2-1 do
begin
if(i<(n1+n2-1)) then
begin
a2[j]:=a[i];
j:=j+1;
a2[j]:=a[n-i];
j:=j+1;
end
else
begin
a2[j]:=a[n-i];
j:=j+1;
end;
end;
{third array}
j:=1;
for i:=n1+n2 to n-n1-n2+1 do
begin
a3[j]:=a[n-i];
j:=j+1;
end;
n1:=prom_n;
n2:=prom_n;
n3:=n-n1-n2;
end;
end
else
begin
prom_n:=trunc(nn)+1;
if ((prom_n mod 2)=0) then
begin
n1:=trunc(prom_n/2);
n2:=trunc(prom_n/2);
{first array}
j:=1;
for i:=1 to n1 do
begin
a1[j]:=a[i];
j:=j+1;
a1[j]:=a[n-i+1];
j:=j+1;
end;
{second array}
j:=1;
for i:=n1+1 to n1+n2 do
begin
a2[j]:=a[i];
j:=j+1;
a2[j]:=a[n-i+1];
j:=j+1;
end;
{third array}
j:=1;
for i:=n1+n2+1 to n-n1-n2 do
begin
a3[j]:=a[i];
j:=j+1;
end;
n1:=prom_n;
n2:=prom_n;
n3:=n-n1-n2;
end
else
begin
if ((nn-trunc(nn))>0.5) then
begin
n1:=trunc(prom_n/2)+1;
n2:=trunc(prom_n/2)+1;
{first array}
j:=1;
for i:=1 to n1 do
begin
if(i<n1) then
begin
a1[j]:=a[i];
j:=j+1;
a1[j]:=a[n-i+1];
j:=j+1;
end
else
begin
a1[j]:=a[n-i+1];
j:=j+1;
end;
end;
{second array}
j:=1;
for i:=n1 to n1+n2-1 do
begin
if(i<(n1+n2-1)) then
begin
a2[j]:=a[i];
j:=j+1;
a2[j]:=a[n-i];
j:=j+1;
end
else
begin
a2[j]:=a[n-i];
j:=j+1;
end;
end;
{third array}
j:=1;
for i:=n1+n2 to n-n1-n2+1 do
begin
a3[j]:=a[n-i];
j:=j+1;
end;
n1:=prom_n;
n2:=prom_n;
n3:=n-n1-n2;
end
else
begin
n1:=trunc(prom_n/2)+1;
n2:=trunc(prom_n/2);
{first array}
j:=1;
for i:=1 to n1 do
begin
if (i<n1) then
begin
a1[j]:=a[i];
j:=j+1;
a1[j]:=a[n-i+1];
j:=j+1;
end
else
begin
a1[j]:=a[n-i+1];
j:=j+1;
end;
end;
{second array}
j:=1;
for i:=n1 to n1+n2-1 do
begin
a2[j]:=a[i];
j:=j+1;
a2[j]:=a[n-i];
j:=j+1;
end;
{third array}
j:=1;
for i:=n1+n2 to n-n1-n2 do
begin
a3[j]:=a[i];
j:=j+1;
end;
n1:=prom_n;
n2:=prom_n-1;
n3:=n-n1-n2;
end;
end;
end;
write('first array:');
for i:=1 to n1 do
write(a1[i],' ');
writeln(' ');
write('second array:');
for i:=1 to n2 do
write(a2[i],' ');
writeln(' ');
write('third array:');
for i:=1 to n3 do
write(a3[i],' ');
readln;
end.