組み合わせ。前回の続きです。ごめんなさい。

うみ 2005-07-13 03:31:06 No: 16342

https://www.petitmonte.com/bbs/answers?question_id=3010
で一度[解決]にしたのですが、プログラムが理解できなくて応用ができませんでした。
前回は5個の中から2個を選ぶ組み合わせをしました。
これを一般的にn個の中からm個選ぶ組み合わせを全て表示するようにできないでしょうか?

具体的に私がやりたいことは、

a=10.3
b=69.97
c=53.55
d=0.3125
e=0.0363
f=0.0393
g=0.1843
h=14.4
i=4.019
j=65.63
k=42.87
l=13.58
m=26.61
n=5.737
o=19.02
p=0.7183
q=100
の17個の中から任意に3つ取り出す組み合わせを全て表示し、かつそれぞれの組み合わせの積を出したい。できれば3つじゃなくて4、5つもできる用にしたいです。

よろしくお願いします。

ろむ 2005-07-13 17:55:39 No: 16343

これってなんかの宿題ですか?
もしそうなら、ご自分でやられた方が良いのではないでしょうか?

うみ 2005-07-13 21:44:19 No: 16344

いえ、宿題ではないです。
大学の実験で・・・
a〜qまでの値は、それぞれフィルターの透過率(%)を表しています。これらのフィルターを適当に組み合わせることによって、任意の透過率を作りたいと考えています。例えばaとbを組み合わせると,a*b*(1/100)=7.2(%)となります。このように色々な組み合わせを自分(紙上で計算)で出したのですが、限界があります(17_C_3=680通りなので)。

それで、そのプログラムを作るためのヒントを得たくて、前回質問しましたが、プログラムが理解できず応用できませんでした。
一応、前回のプログラムで、17個の中から2つ取り出す組み合わせが出せたので、Edit1.textにabcdefghijklmnopqと入れて、Memoに出てきた結果をコピーしてExcelに貼り付け、a〜qを全て値に置換し積を出しました。これだと結構めんどくさかった。またもっと多くの組み合わせを考えたいです。

とりあえずビール…じゃなくて…17_C_ 2005-07-13 23:12:46 No: 16345

pＣq は押して知るべし。一般解あるかな？

var
  sName: array[1..17]of string =
   ('a','b','c','d','e','f','g','h','i','j','k','l','m','n','o','p','q');
  fData: array[1..17]of Double =
   (10.3, 69.97, 53.55, 0.3125, 0.0363, 0.0393, 0.1843, 14.4,
  4.019, 65.63, 42.87, 13.58, 26.61, 5.737, 19.02, 0.7183, 100);

procedure TForm1.Button1Click(Sender: TObject);
var
  i, j, k, Cnt: Integer;
begin
  Memo1.Font.Name := 'ＭＳゴシック';
  Memo1.Font.Size := 10;
  Cnt := 0;
  for i:=Low(fData) to High(fData)-2 do begin
   for j:=i+1 to High(fData) do begin
    for k:=j+1 to High(fData) do begin
     inc(Cnt);
     Memo1.Lines.Add(sName[i]+'＋'+sName[j]+'＋'+sName[k]+'＝'+FloatToStr(fData[i]+fData[j]+fData[k]));
    end;
   end;
  end;
  Memo1.Lines.Add('組み合わせの数は '+IntToStr(Cnt)+' 通り');
end;

ウオレス 2005-07-13 23:23:10 No: 16346

「C言語による最新アルゴリズム事典」から移植。

とりあえずビール…じゃなくて…17_C_3さんのに比べると酷く技巧的で何が何やらわかりません。

x and -x っていうのはnクイーン問題とかでも使われていたテクニック（１が立っている右端のbitを得る）っていうのは分かるんですが・・・

Const N =17;
Const K =3;

(***********************************************************
組合せの生成
***********************************************************)

function first( n :Longword) :Longword;
begin
first := ((1 shl n) - 1);
end;

function nextset(x :Longword ):Longword;
var
smallest, ripple, new_smallest, ones :Longword ;
begin

  smallest := x and -x;
  ripple   := x + smallest;
  new_smallest := ripple and -ripple;
  ones     := ((new_smallest div smallest)  shr  1) - 1;
  Result   := (ripple or ones) ;
end;

procedure printset(s : Longword );
var
  i :Integer;
  St:AnsiString;
begin
  St := '';

  i := 1;
  while( i <= N) do  begin
    if ((s and 1) <> 0 )then  St := St + Format(' %d', [i]) ;
    s  := s  shr  1;
    Inc(i);
  end;

Form1.Memo1.Lines.Add(St);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
i :Integer;
x,dbg : Longword ;

begin

  i := 1;
  x := first(K);
  dbg := (not first(N));

  while(  (x and  dbg ) = 0 )do
  begin
    Form1.Memo1.Lines.Add(Format(' %4d:', [i]));

    printset(x);
    x := nextset(x);
    Inc(i);
    dbg := (not first(N)) ;
  end;
end;

和×積○ 2005-07-13 23:26:08 No: 16347

>Memo1.Lines.Add(sName[i]+'＋'+sName[j]+'＋'+sName[k]+'＝'+FloatToStr(fData[i]+fData[j]+fData[k]));
アッ、組み合わせの和じゃなくて積か(^^ゞ
Memo1.Lines.Add(sName[i]+'×'+sName[j]+'×'+sName[k]+'＝'+FloatToStr(fData[i]*fData[j]*fData[k]));

メラトニン 2005-07-14 03:19:59 No: 16348

なはっ、乗り遅れてしまった…
以前私が示したのは2通りのみの抽出です。
n通りは凄く難しいんです。
ですが、ウオレスさんが示してくれましたね、スゴイッス。
レスが無いところをみると自分のプログラムに応用できてないと思ったので一応一部改変をしてみました、改悪かな？

(***********************************************************
組合せの生成
***********************************************************)
function first( n :Longword) :Longword;
begin
first := ((1 shl n) - 1);
end;

function nextset(x :Longword ):Longword;
var
    smallest, ripple, new_smallest, ones :Longword ;
begin
    smallest := x and -x;
    ripple   := x + smallest;
    new_smallest := ripple and -ripple;
    ones     := ((new_smallest div smallest)  shr  1) - 1;
    Result   := (ripple or ones) ;
end;

procedure printset(s : Longword; var No: array of integer);
var
  i,p :Integer;
  St:AnsiString;
begin
  St := '';
  p := 0;
  i := 1;
    while( i <= N) do  begin
        if ((s and 1) <> 0 )then
        begin
          //  St := St + Format(' %d', [i]) ;
          No[p]:=i;
          inc(p);
        end;
        s  := s  shr  1;
      Inc(i);
    end;
  //Form1.Memo1.Lines.Add(St);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Data : array of Double;
  No   : array of Integer;
  Combination : Integer;
  Ans    : Double;
  AnsStr : string;

  requiestValue : Double; //期待値
  closestValue  : Double; //それに最も近い値
  closestStr    : String;

  i,p    : integer;
  x,dbg  : Longword ;
begin
  Memo1.Clear;
//Memo2に改行区切りデータがあるとする
  SetLength(Data,Memo2.Lines.Count);
  for i:=0 to Length(Data)-1 do
    Data[i]:= StrToFloat(Memo2.Lines[i]);
//Edit1に目的とする値を入れる 45% なら 45
  requiestValue:= StrToFloat(Edit1.Text);

closestValue:=0;
//1通りから4通りまでまとめて計算
for Combination := 1 to 4 do
begin
  SetLength(No,Combination);
  i := 1;
  x := first(Combination);
  dbg := (not first(Length(Data)));
  while(  (x and  dbg ) = 0 )do
  begin
    printset(x,No);
      //計算処理
      Ans:=1;
      AnsStr:='';
      for p:= 0 to Combination-1 do
      begin
        Ans:=Ans * Data[No[p]-1];
        AnsStr :=AnsStr + inttostr(No[p]) + ',';
      end;
      Ans := Ans / 100;
      if Abs(requiestValue - Ans) < Abs(requiestValue - closestValue) then
      begin
        closestValue:= Ans;
        closestStr  := AnsStr + ' =' + Format('%3.2f',[Ans]) + '%';
      end;
      AnsStr := AnsStr + ' =' + Format('%3.2f',[Ans]) + '%';

      Memo1.Lines.Add(AnsStr);   //これが無ければもっと高速
      //計算処理ここまで
    x := nextset(x);
    Inc(i);
    dbg := (not first(Length(Data))) ;
  end;
end;
Showmessage(closestStr);
end;

メラトニン 2005-07-14 03:24:10 No: 16349

ミスあります、ちょっとお待ちください。

うみ 2005-07-15 17:40:43 No: 16350

皆さんありがとうございます。レス遅れてごめんなさい。
【とりあえずビール…じゃなくて…17_C_3】さんの方法で、現在ほしいデータは得ることができました。今の僕のDelphiスキルでも考えればできていたかもしれませんね。簡単なようで難しい発想でした。ありがとうございます。
【ウオレス】さん【メラニン】さんもありがとうございます。
ウオレスさんのは実行したらほしいデータを得ることができました。最初から全然わかりません・・・。空いてる時間をみつけて自分で調べてみます。それでもわからなかったら、また質問させていただきます。

メラニンさんの実行できませんでした。待ってます^^

メラトニン 2005-07-15 18:16:41 No: 16351

書き込めないんです。。。
書き込みチェック

メラトニン 2005-07-15 18:19:00 No: 16352

やっと書き込めました。
2005/07/13(水) 18:24:10以降急に書き込めなくなっちゃって…
アク禁解除？
(***********************************************************
組合せの生成
***********************************************************)
function first( n :Longword) :Longword;
begin
first := ((1 shl n) - 1);
end;

procedure printset(s : Longword; ItemCount:Integer; var No: array of integer);
var
  i,p :Integer;
  St:AnsiString;
begin
  St := '';
  p := 0;
  i := 1;
    while( i <= ItemCount) do  begin
        if ((s and 1) <> 0 )then
        begin
          //  St := St + Format(' %d', [i]) ;
          No[p]:=i;
          inc(p);
        end;
        s  := s  shr  1;
      Inc(i);
    end;
  //Form1.Memo1.Lines.Add(St);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Data : array of Double;
  No   : array of Integer;
  Combination : Integer;
  Ans    : Double;
  AnsStr : string;

  requiestValue : Double; //期待値
  closestValue  : Double; //それに最も近い値
  closestStr    : String;

closestValue:=0;
//1通りから4通りまでまとめて計算
for Combination := 1 to 4 do
begin
  SetLength(No,Combination);
  i := 1;
  x := first(Combination);
  dbg := (not first(Length(Data)));
  while(  (x and  dbg ) = 0 )do
  begin
    printset(x,Length(Data),No);
      //計算処理
      Ans:=1;
      AnsStr:='';
      for p:= 0 to Combination-1 do
      begin
        Ans:=Ans * Data[No[p]-1];
        AnsStr :=AnsStr + inttostr(No[p]) + ',';
      end;
      Ans := Ans / 100;
      if Abs(requiestValue - Ans) < Abs(requiestValue - closestValue) then
      begin
        closestValue:= Ans;
        closestStr  := AnsStr + ' =' + Format('%3.2f',[Ans]) + '%';
      end;
      AnsStr := AnsStr + ' =' + Format('%3.2f',[Ans]) + '%';

      //Memo1.Lines.Add(AnsStr);   //これが無ければもっと高速
      //計算処理ここまで
    x := nextset(x);
    Inc(i);
    dbg := (not first(Length(Data))) ;
  end;
end;
Showmessage(closestStr);
end;