6 Değişik sayıyı 3 er adet kullanarak kümeler oluşturma.

[conari]

Arkadaşlar sorum biraz Delphiden bağımsız ama sonuçta bir programlama olduğu için burda yazdım.

Örnek 1 , 2 , 3 , 4 , 5 , 6 olarak 6 adet sayım var,
Bunlardan her seferinde 3 tanesine kullanarak kaç tane küme oluşturabilrim.
Yani
1,2,3 ===> bu bir küme
3,4,5 ===> bu bir küme
4,5,6 ===> bu da bir küme
1,5,6 ===< buda farklı bir küme bu şekilde ki sonuçları pratik olarak nasıl bulabilirim.
Sanırım OBEb veya OKEK ile çözüyoduk bu olayı ,
Teşekkürler.

[aslangeri]

s.a.
küme sayısını mı istiyorsunuz
yoksa elemanlarını mı?

[conari]

Elemanlı Kümeleri istiyorum.
yani Kümeler ve içerigi,
Yalnız,
1,2,3 bir küme ise

3,2,1 diye bir küme olmamalı

Teşekkürler

[mkysoft]

Sizin aradığınız kobinasyon. C de bulduğum bu kodu delhiye uyarlamıştım. İçinde hala orjinal C kodlaru duruyor. İptal edilmiş olarak tabi.

Kod: Tümünü seç

  R, Slen: Integer;

Kod: Tümünü seç

procedure TForm1.Kombinasyon;
var
  S2: string;
  Q, S:array of integer;
  i:integer;
begin
  setlength(S,0);
  S2 := '';
//    Writeln('');
//    Writeln('');
//    Write('P(N,R)  N=? : ');
//    ReadLn(S);
  setlength(S,6); //ana küme. siz 6 elamanlı demişsiniz
  for i:=1 to 6 do
    S[i]:=i;
  SLen := 6; // bu S deki elaman sayısı
  R := 3; //elde etmek istediğiniz küme büyüklüğü
  setlength(Q,0);
  P(Q, S);
end;

Kod: Tümünü seç

procedure TFrom1.P(var A: array of integer; B: array of integer);
var 
  J: Word;
  C,D:array of integer;
  i:integer;
begin
  { P(N,N) >>  R=Slen  }
  if Length(B) = SLen - R then
  begin
//Burada A dizisine istediğiniz siralama atanmış olacak. Buradan başka bir diziye atabilirsiniz.
//    Write(' {' + A + '} '); {Per++}
  end
  else
    for J := 0 to Length(B)-1 do
    begin
      setlength(C,length(B));
      for i:=0 to length(B)-1 do
        C[i]:=B[i];
      setlength(D,length(A)+1);
      for i:=0 to length(A)-1 do
        D[i]:=A[i];
      D[length(D)-1]:=C[J];
      for i:=J to length(C)-2 do
        C[i]:=C[i+1];
      setlength(C,length(C)-1);
      P(D, C);
    end;
end;

Kolay gelsin.

[conari]

Teşekkürler,
Yalnız bu kod da elemanları nerde tanımlıyorsunuz.
Ben 1,2,3,4,5,6 örneklerini misal vermiştim.

[mkysoft]

setlength(S,6); //ana küme. siz 6 elamanlı demişsiniz
for i:=1 to 6 do
S:=i;

[conari]

Kusura bakma ama kodu çözemedim,

[conari]

Örneklendireyim Tekrardan
1,2,3,4,5,6
bunlar 6 adet Edit e girilen bilgi.
Bu Altı Edit için 3 elemanlı kümeleri çıkaracağım.ve Memo içine yükleyeceğim.
Kafamdan yaptığım sonuçlar.(kombinasyon 20 çıkıyor ama ben 18 bulabildim kafadan)diğer 2 sini bulan varsa da yazsa iyi olur.

123 234
124 235
125 236
126 245
134 246
135 256
136 345
145 346
146 456

[TRSoft]

156 ve 356 yok senin listende

[conari]

Teşekkürler, @TR Soft;
Netten bir iki fonk. buldum biraz üzerinde çalıştım Verdiğin sayı kadar oluşabilecek kümeleri veriyor.Bundan yola çıkarak bir şeyler yapmaya çalılacağım.
edit in içine rakamları aralarına virgül koyarak giriyorum ve Listbox a atıyor.

Kod: Tümünü seç

procedure TForm1.Button1Click(Sender: TObject);
var
sbt,u,l:integer;
s1:string;
begin
listbox1.Clear;
say:=Esay(edit2.text);
for l:= 1 to floor(power(2,say))-1 do begin
altkume[l]:=trim(ikilige_cevir(l)); s1:='';
sbt:=say-length(altkume[l]);
for u:=length(altkume[l]) downto 1 do
if altkume[l][u]='1' then s1:=s1+eleman[sbt+u]+',';
altkume[l]:=s1;listbox1.Items.Add(s1);
end;//for
end;

function Esay(kume:string):integer;
var k:integer; s:string;
begin
kume:=trim(kume)+','; k:=1; say:=1;
repeat
if kume[k]<>',' then s:=s+kume[k] else
begin eleman[say]:=s;s:=''; inc(say); end;
inc(k);
until k>length(kume);
dec(say);
Esay:=say;
end;

function ikilige_Cevir(sayi:integer):string;
var kal,topkal:string;
begin
repeat
kal:=trim(inttostr( sayi mod 2));
topkal:=kal+topkal; sayi:=sayi div 2;
until sayi=0;
ikilige_Cevir:=topkal;
end;

[/code]

[bluekid]

C deki hali de benden olsun

Kod: Tümünü seç

	int Dizi[6]={1,2,3,4,5,6};
	int i,j,k,l=0;
	for(i=0;i<6;i++)
	  for(j=i+1;j<6;j++)
	    for(k=j+1;k<6;k++){
	      	printf("%d-%d-%d\n",Dizi[i],Dizi[j],Dizi[k]);
            l++;
	    }
	printf("Toplam Kombinasyon %d\n",l);

[t-hex]

Eleman sayısı 32'den az olan kümelerin tüm alt kümelerini bulmak için basit bir algoritma var.

Örnek kümemiz sorudaki gibi 6 elemanlı olsun. Bildiğiniz gibi her sayının ikilik sistemde bir yazımı vardır.

1'den başlayıp 2^6'ya kadar olan tüm sayıların ikilik sistemdeki yazımları şu şekilde olur

0 = 000000
1 = 000001
2 = 000010
3 = 000011
4 = 000100
5 = 000101
6 = 000110
7 = 000111
8 = 001000
..
.
.
63 = 1111111

ikilik sistemde 1' olan basamağın konumuna karşılık gelen elemanları birleştirerek alt kümeler oluşturabiliriz.

0 için {}
1 için {1}
2 için {2}
3 için {1,2}
4 için {3}
5 için {1,3}
6 için {2,3}
..
..
63 için {1,2,3,4,5,6}

sadece üç biti 1 olan sayılar için olan alt kümeleri seçerekte yapılabilir demek istiyorum da anlatamıyorum heralde...

Kod: Tümünü seç

var
  i,j,c : integer;
  s : string;
begin
  for i := 1 to 64 do begin
    c := 0;
    s := '';
    for j := 0 to 5 do
      if i and (1 shl j) <> 0 then  begin
        s := s + ' ' +inttostr(j+1);
        inc(c);
      end;
   if (c = 3) then // bu koşulu kaldırırsanızda tüm alt kümeleri görürsünüz.
     writeln(s);
  end;

[conari]

@t-hex Teşekkürler
Yalnız hep for döngüsünde takılmışımdır.

Bu Kodu benim Edit olayına ve Memo atma döngüsü içine koyarak yazabilirmisin.?

Fazla olmaz isem

[mrmarman]

Selam

- İç içe fonksiyonla çözmeyi de ben göstereyim...

- Bir TEdit koyduk, adı Edit1 buna aşağıdaki şekilde virgüllerle ayırarak rakamları girdik.

- Sonucu Bir TListBox içinde görüyoruz ama parametre TStrings olduduğundan özgürce Memo da kullanabilirsin ComboBox veya CheckListBox vs.vs.vs. de kullanabilirsin.

Kod: Tümünü seç

  Edit1.Text := '1,2,3,4,5,6';

- Aşağıdaki procedure çalışınca, bu virgüllerden rakamlar ayrılarak diziye alınıyor. Dizi dinamik bir dizidir. Virgülle ayrılmış eleman kadar genişler veya daralır.

Kod: Tümünü seç

Procedure Kume( Kaynak:String; ElemanSay:Integer; Liste:TStrings );
Var
  Dizi : Array of Integer;

  procedure IcIceDongu(Num:byte; Toplam:byte; Sart:boolean; S:String);
  begin
    if Sart then
    begin
      If s <> '' then s := Format('%s-%.2d', [s, Dizi[num]])
                 else s := Format('%.2d', [Dizi[num]]);
    end;
    if Toplam = ElemanSay then begin
      Liste.Add(s);
      exit;
    end;
    if num = High(Dizi) then exit;

    IcIceDongu(Num+1, Toplam+1, True,  s);
    IcIceDongu(Num+1, Toplam,   False, s);
  end;

var
  s : string;
begin
  SetLength(Dizi, 1);
  Liste.Clear;
  s := '';
  // Rakamları string parse edip Diziye alıyoruz...
  Kaynak := Trim(Kaynak) + ',';
  While Kaynak <> '' do begin
    SetLength(Dizi, High(Dizi)+2);
    Dizi[High(Dizi)] := StrToInt( Copy(Kaynak, 1, Pos(',', Kaynak)-1));
    Delete( Kaynak, 1, Pos(',', Kaynak) );
  end;
  IcIceDongu(0, 0, false, s); // Tetikliyoruz...
  Form1.Caption := Format('''%d'' Elemanlı Grup Sayısı : %d',[ElemanSay, Liste.Count]);
end;

Bu da kullanımı...

Kod: Tümünü seç

procedure TForm1.Button1Click(Sender: TObject);
begin
  Kume( Edit1.Text, 3, ListBox1.Items );
  // veya ListBox1.Items yerine senin için Memo1.Lines diyebilirsin.
end;

- Başarılar..

[conari]

@Muharrem Bey teşekkür başka bir formül ile Listbox daki uzunluk koşulu bana uygun olanları MEmo ya atarak işimi çözdüm. ama senin ki daha kısa gibi inceleyeceğim.
Sağol..