разделение одномерного массива в Паскале

Тема в разделе "Delphi - FAQ", создана пользователем DenisM, 22 апр 2007.

Статус темы:
Закрыта.
  1. DenisM

    DenisM Гость

    помогите пожалуйста со следующей задачей в Паскале: Разделить одномерный массив на 3 части, которые по возможности имеют минимальное расхождение сумм. Например: исходный массив - 1 2 3 4 5 6, полученые массивы - 6 1, 5 2, 3 4. Необязательно чтоб в полученном массиве было одинаковое количество чисел.
    Я попробывал что-то сделать но у меня получается не так как надо
    Код (Text):
    uses crt;

    const
    n = 5;

    type
    TArray = array [1..n] of Integer;

    TResult = record
    a, b: Integer;
    end;

    function Part(const arr: TArray; const _from, _to: Integer): Integer;
    var
    s, i: Integer;
    begin
    s := 0;
    for i := _from to _to do
    inc(s, arr[i]);
    Part := s;
    end;

    procedure GetParts(const arr: TArray; var R: TResult);
    var
    a, b, delta, min: Integer;
    begin

    min := MaxInt;

    for a := 1 to n - 2 do
    for b := a + 1 to n - 1 do begin

    DELTA :=
    abs ( Part(arr, b + 1, n) - Part(arr, a + 1, b) ) +
    abs ( Part(arr, b + 1, n) - Part(arr, 1, a) ) +
    abs ( Part(arr, a + 1, b) - Part(arr, 1, a));

    if DELTA < min then begin
    min := DELTA;
    R.a := a;
    R.b := b;
    end;
    end;
    end;

    const
    X: TArray = (1, 2, 3, 4, 5);
    var
    R: TResult;
    begin
    clrscr;

    GetParts(X, R);

    writeln('1->', R.a, ', ', R.a + 1, '->', R.b, ', ', R.b + 1, '->', n);

    readln;
    end.
     
  2. pinhead

    pinhead Гость

    Я так понимаю, что количество элементов массива должно быть чётным, если да то программу я написал. Выложить исходники?
     
  3. grigsoft

    grigsoft Well-Known Member

    Регистрация:
    15 ноя 2005
    Сообщения:
    735
    Симпатии:
    0
    Интересная задача, жаль что пропустил.
    Для: pinhead - требования к четности тут нет. Алгоритм расскажи вкратце
     
  4. DenisM

    DenisM Гость

    если тебя не затруднит выложи пожалуйста исходники. За это время придумал новый алгоритм но который не могу реализовать. Вот он: 1) Создаем три пустых массива
    2) Инициализируем результирующие массивы произвольным образом. К примеру: в первый массив - первый элемент входных данных, во второй массив - второй элемент, в третий - все остальные элементы.
    3) ------ Начало очередной итерации ------
    4) Вычисляем сумму элементов каждого массива (назовем сумму элементов массива "весом", чтобы много не писать).
    5) Находим массивы с максимальным и минимальным весом.
    6) Вычисляем разницу в весе между массивами с минимальным и максимальным весом (delta).
    7) Если delta = 0 - завершаем работу. Мы добились идеального варианта решения - разница между суммами массивов равна нулю.
    8) Если это не первая итерация и delta данной итерации равна delta предыдущей итерации - завершаем работу.
    9) Проходим по элементам более "тяжелого" массива и находим среди них такой, значение которого максимально близко к половине значения delta. Т.е. элемент x должен удовлетворять условию: |x*2-delta| - минимальное значение среди всех элементов данного массива. Для чего это нужно: мы пытаемся найти вариант "переброса" элемента из более "тяжелого" массива в более "легкий" с тем, чтобы уменьшить разницу в весе между ними. На данном этапе перебрасывать не надо - только нашли значение.
    10) Рассматриваем 3 возможных варианта:
    a) |x*2 - delta| < delta (т.е. случай, когда "перебросив" элемент из одного массива в другой мы уменьшаем разницу в весе между ними). В этом случае мы удаляем x из более тяжелого массива и добавляем его в более легкий, после чего возвращаемся к шагу (4) - начинаем следующую итерацию.
    B) |x*2 - delta| > delta. Ничего не можем поделать, сортировать дальше не получается. Завершаем работу алгоритма.
    c) |x*2 - delta| = delta. Самый интересный случай. Фактически, x=delta. В данной ситуации следует перенести x из одного массива в другой (аналогично (10.a)) и попробовать еще раз выполнить пункты 8-10. При этом следует помнить, что массивы поменяются местами (т.е. самый легкий станет самым тяжелым и наоборот). Если опять попадаем в (10.c) - завершаем выполнение алгоритма, иначе - см. (10.a) и (10.B).
    12) Завершение работы: имеем 3 массива, более-менее удовлетворяющих условиям задачи :)

    Возможно у кого то есть идеи ? Заранее благодарен
     
  5. grigsoft

    grigsoft Well-Known Member

    Регистрация:
    15 ноя 2005
    Сообщения:
    735
    Симпатии:
    0
    Так а что мешает реализовать? Оптимальное решение, конечно не найдешь, да и улучшать есть куда - например в 10б пытаться включить средний массив в поиск. Вообще, мне так кажется, что настоящее решение тут ищется исключительно полным перебором только, а перебор здесь 3^n. Но для школьных задач размерности до 15 - вполне решабельно B)
    Почитай, например, про рюкзак, например: http://alglib.sources.ru/articles/perebor.php
    http://forum.sources.ru/index.php?showtopic=9394&st=0
     
  6. DenisM

    DenisM Гость

    Спасибо grigsoft за ссылки. Нашел прогу похожею на мою. Не пойму только как ее переделать чтоб выводилось значение в три массива
    Код (Text):
    uses crt;
    var
    a,b:array[1..100] of integer;
    n:byte;
    sum:integer;
    f:boolean;
    i,j,k,h,s: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;
    writeln('Vvedite sum');
    readln(sum);
    {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.                                     {vot i vse vrode}
    Можешь что нибудь подсказать. Возможно это не так уж и сложно но так как я учу Паскаль мало времени у меня не хватает на это мозгов
     
  7. grigsoft

    grigsoft Well-Known Member

    Регистрация:
    15 ноя 2005
    Сообщения:
    735
    Симпатии:
    0
    Тут из последовательности выбирается набор для указанной суммы. В твоем случае, если использовать такой подход, можно посчитать общую сумму S и подбирать элементы с суммой S\3.
    Но я бы попробовал играться с генетическими алгоритмами.
     
  8. DenisM

    DenisM Гость

    на счет генетических алгоритмов мало что понял поэтому попробывал реализовать первый способ (подсчитал сумму и поделил на три). Еще в программу перед основным циклом включил пузырьковую сортировку так как в основном цикле нужно чтоб числа были отсортированы. Не понял только как сделать чтоб выводились только 3 массива которые бы включали все введенные числа
    Код (Text):
    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.                                     {vot i vse vrode}
     
  9. grigsoft

    grigsoft Well-Known Member

    Регистрация:
    15 ноя 2005
    Сообщения:
    735
    Симпатии:
    0
    Ну как - прогнать алгоритм 2 раза, каждый раз убирая (обнуляя?) элементы включенные в набор, после чего включить оставшиеся в 3й набор.

    Сам я с ГА не работал, но звучат они забавно. В твоем случае любое решение описывается как N чисел 0\1\2 - назначение элементов наборам.
    1. Генерятся, например, N базовых элементов - случайных решений
    2. Из текущего множества решений выбирается, например, N/4 лучших для размножения :) , остальные удаляются.
    3. Размножение (со случайно выбранными элементами):
    а. скрещивание: 2 решения обмениваются одним или несколькими позициями
    б. мутация: в решении случайным образом меняется 1 или несколько позиций
    4. Все полученные решения (старые и новые) образуют новый пул, с которым мы переходим к шагу 2.

    Останавливается когда достигнуто оптимальное решение или лучшее решение не изменяется на достаточно большом количестве итераций.
    Надо будет попробовать в свободное время :(
     
  10. DenisM

    DenisM Гость

    Для: pinhead Все таки можешь выложить исходники той программы которую ты написал. Заранее благодарен
     
  11. pinhead

    pinhead Гость

    Простите за долгий простой в ответе, он появилась неотложная (срочная очень) работа. В программе нашёл ошибку, поэтому не вышлю.
    Для grigsoft: идея проги в следующем
    1) составляем вспомогательный массив состоящий из сумм одномерного массива, он будет двумерный [1..n, 1..n] симметричный относительно главной диагонали, поэтому будем работать только с верхней треугольной матрицей!
    пример: для массива 1,2,3,4,5,6
    Получаем: массив
    2,3,4,5,6,7
    3,4,5,6,7,8
    4,5,6,7,8,9
    5,6,7,8,9,10
    6,7,8,9,10,11
    7,8,9,10,11,12
    рабочий массив:
    3,4,5,6,7
    ,5,6,7,8
    ,7,8,9
    ,9,10
    ,11
    2) i=2, RazbrSumm = 0, n=6.
    а)В рабочем массиве берём итый элемент первой строки, вычеркиваем первую, итую строку и итый столбец раб. массива и составляем массив (одномерный) из сомой верхней не вычеркнутой строки раб матрицы
    б) сравниваем все элементы (разность по модулю должна быть ровна RazbrSumm), находим первый, вычёркиваем соотв. строки и столбцы, и т. д.
    Иначе i=2+1 и на пункт а)
    Если после прохода по всей верхней строке не получился массив состоящий из n/2 то RazbrSumm=RazbrSumm+1 i=2 и на пункт а)
    Приведу код который написал:
    Код (Text):
    uses
    crt;

    const
    n = 8;

    var
    ArrayOfValues: array[1..n] of integer;
    count: word;

    procedure Error;
    begin
    clrscr;
    textcolor(red);
    write('Произведён не верный ввод данных!!!');
    readln;
    halt
    end;

    procedure VvodArray;
    var
    i: byte;
    begin
    ClrScr;
    write(Количество элементов (чётное) массива (не более ',n,' штук|->');
    readln(count);
    if (count mod 2) <> 0 then Error;
    if count > n then Error;
    if count = 2 then
    begin
    write(ArrayOfValues[1], ' ', ArrayOfValues[2]);
    readln;
    halt
    end;
    ClrScr;
    for i:= 1 to count do
    begin
    write('Элемент № ',i, ' массива|->');
    readln(ArrayOfValues[i])
    end;
    ClrScr
    end;


    procedure FindGroups;
    var
    ResultArray: array[1..n] of integer;
    HelpArray: array[1..n, 1..n] of integer;

    procedure CreateHelpArray;
    var
    i, j: word;
    begin
    for i:= 1 to count - 1 do
    begin
    for j:= i + 1 to count do
    begin
    HelpArray[i, j]:= ArrayOfValues[i] + ArrayOfValues[j];
    {       write(HelpArray[i, j], ' ')}
    end;
    writeln
    end
    end;

    function IsNotGroopFound(RazbrSumm: byte): Boolean;
    var
    TempArray, TempArray1: array[1..n] of integer;
    i, j: word;
    begin
    IsNotGroopFound:= True;
    for i:= 2 to count do
    TempArray[i]:= HelpArray[1, i];
    for j:= 1 to count - i - 1 do
    {Эта функция должна искать пары элементов матрици HelpArray с расхождением сумм (по модулю) равному RazbrSumm. Если не нашла то возвращается значение Правда, иначе Ложь}
    end;

    var
    i: byte;
    begin
    ClrScr;
    CreateHelpArray;
    { i:= 0;
    while IsNotGroopFound(i) do
    Inc(i)
    }end;

    begin
    VvodArray;
    FindGroups;
    readln
    end.
     
  12. DenisM

    DenisM Гость

    Написал программу по новому. Работает по условию правильно. Выкладываю код. Возможно кому-нибудь понадобится в будущем
    Код (Text):
    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.
     
Загрузка...
Похожие Темы - разделение одномерного массива
  1. erhe
    Ответов:
    22
    Просмотров:
    1.265
  2. alekssgor
    Ответов:
    1
    Просмотров:
    1.785
  3. Omh
    Ответов:
    32
    Просмотров:
    7.259
  4. dog2552
    Ответов:
    2
    Просмотров:
    1.144
Статус темы:
Закрыта.

Поделиться этой страницей