Версия для печати темы

Автор: DarkWishmaster 18.04.2011 2:14

Надо методом перебора. Я сделал, только они повторяются:
1 3 5 - 5 3 1
Может у вас есть алгоритм для этой задачи?
Я думал сохранить результаты в массиве, т.е если числа вектора не повторяются с теми что из массива то добавляем в массив, но это не эфективно, думаю есть более простой метод.
Спасибо.

Автор: Lapp 18.04.2011 9:42

Цитата(DarkWishmaster @ 17.04.2011 23:14)

Автор: volvo 18.04.2011 19:26

Автор: DarkWishmaster 18.04.2011 20:38

Забыл сказать что все числа должны быть разными (т.е варианты типа 3 3 9 не печатать)
Вот моя идея:
например для n=9, k=3
создаем вектор: 1 2 3
Теперь увеличиваем 3 пока сума вектора не будет N
1 2 4
1 2 5
1 2 6 -> решение
теперь идем к переведущему числу, уже к 2 и увеличиваем его на 1 единицу:
и опять последний увеличиваем:
1 3 4
1 3 5 -> решение
увиличиваем 3
так как 1 4 5 больше N
то идем к первому элементу и увеличиваем его
2 3 4 ->решение
теперь уже ничего увеличивать нельзя, так как сума будет больше N
Вот что я пробовал сделать :

Uses Crt;
var  a:array[0..10] of integer; n,q,i:integer;
   function Suma:boolean;  //смотрим суму вектора, если равна N значит ответ TRUE
   var S,i:integer;
   begin
     S:=0;
     for i:=1 to q do
     S:=S+a[i];
     Suma:=(S=n);
   end;
   procedure Print; 
   var i:integer;
   begin
    for i:=1 to q do
     write(a[i],' ');
   { readln;}
   end;
  procedure BackTr(k:integer);
  var i:integer;
     begin
     if q=k-1 then  Print  //но тут ещё if Suma then Print надо поставить
      else  begin
       i:=a[k-1]+1; 
         while  not Suma do begin
         a[k]:=i;
         BackTr(k+1);
         inc(i);
       end;
      end;
    end;
 Begin ClrScr;
 readln(n,q);
 BackTr(1);
 readln;
 end. 

Автор: volvo 18.04.2011 20:48

Автор: DarkWishmaster 18.04.2011 21:20

Цитата(volvo @ 18.04.2011 16:48)

Автор: volvo 18.04.2011 21:25

Заодно попробуй вот это (набирал прямо здесь, так что может чего где забыл, поправь если что) :

var
  q : integer;
  n : integer;

  arr : array[1 .. 10] of integer;

procedure p(start, count : integer);
var i, s : integer;
begin
  if count > q then
  begin
    s := 0;
    for i := 1 to q do s := s + arr[i];
    if s = n then
    begin
      for i := 1 to q do write(arr[i]:3);
      writeln;
    end;
  end
  else
  begin
    for i := start + 1 to n do // Вот основная идея: чтоб решения и слагаемые не повторялись
    begin
      arr[count] := i;
      p(arr[count], count + 1); // рекурсия присутствует
    end;
  end;
end;

begin
  n := 9;
  q := 3;
  p(0, 1);
end.

Автор: DarkWishmaster 18.04.2011 21:46

Спасибо, volvo, только что закончил, вот без рекурсии
только пока работает только с макс. с K=3

Uses Crt;
var n,q,i:integer; a:array[1..3] of integer; flag:boolean;
  function Ok:boolean; //смотрим если можем продолжать добовлять
  var i,S:integer;
  begin
  S:=0;
     for i:=a[1] to q+a[1]-1 do
     S:=S+i;
     if S<n  then Ok:=True
     else ok:=False;
  end;
   function Suma:boolean; 
    var i,S:integer;
    begin
      S:=0;
      for i:=1 to q do
      S:=S+a[i];
     Suma:=(S>=N);
    end;
  procedure Print;
    var i:integer;
    begin
     for i:=1 to q do
      write(a[i],' ');
     writeln;
    end;
  begin     CLrSCr;
        readln(n,q);
        for i:=1 to q do
        a[i]:=i;  
             repeat
             flag:=false; //флаг ставим на 0
             while not Suma do begin
             a[i]:=a[i]+1;
             flag:=true;    // флаг 1
             end;
       if flag=false then dec(i) 
                                else Print;
        if Ok then
        begin
        if flag=false then begin
        dec(i);
        a[i]:=a[i]+1;
        repeat
            inc(i);
            a[i]:=a[i-1]+1;
         until i=q end
           else begin
           dec(i);
           a[i]:=a[i]+1;
           inc(i);
           a[i]:=a[i-1]+1;
          end;
         if  (OK=False) and (Suma) then Print;
         end;
      until OK=False;
Readln;
end.

Автор: Lapp 19.04.2011 8:11

Цитата(volvo @ 18.04.2011 16:26)

Цитата(volvo @ 18.04.2011 16:26)

const
  m=1000;
var
  a: array[1..m]of integer;
  k,n,q: integer;

procedure Split(j,n: integer);
var
  i: integer;
begin
  if (n=0)and(k=q) then begin
    for i:=1 to k do Write(a[i]:4);
    WriteLn
  end
  else for i:=j to n do begin
    Inc(k);
    a[k]:=i;
    Split(i+1,n-i);
    Dec(k)
  end
end;

begin
  Write('n = ');
  ReadLn(n);
  Write('q = ');
  ReadLn(q);
  k:=0;
  Split(1,n);
  ReadLn
end.

Автор: volvo 19.04.2011 14:46

-1

Автор: Lapp 19.04.2011 15:50

Цитата(volvo @ 19.04.2011 11:46)

Я не игнорировал пост. Зашел, посмотрел. Кстати, на мысль воспользоваться поиском меня навел именно твой пост. Но извиняться перед всей Вселенной за то, что может быть кто-то где-то когда-то уже писал подобную программу, или программу, которую можно минимальными усилиями преобразовать к нужному функционалу - не собираюсь.

Запомни этот пост. И потом, если вдруг у тебя начнут появляться минусы, я буду давать тебе на него ссылку. Если, конечно, ты не воспользуешься раньше возможностью чистки своего рейтинга, что уже было. Хочешь - напомню, где? Я, как видишь, этим не пользуюсь.

И, на будущее: я не влазил ни в одно твое обсуждение (по крайней мере, не приводил там СВОЙ код, максимум - давал наводящие замечания). Ты - залез везде, где только можно. Везде, где бы я не ответил - ты потом ТОЖЕ ПОБЫВАЛ, и оставил свою версию программы. Ну что ж...

Автор: Lapp 22.04.2011 8:50

Тема разделена, остаток перенесен сюда: http://forum.pascal.net.ru/index.php?showtopic=28251&hl=

Автор: ta bort gäddhä 29.09.2021 10:28

My family all the time say that I am killing my time here at net, but I know I am getting familiarity daily by reading such good articles or reviews. ta bort gäddhäng med laser juakee.sewomabest.com/map21.php