1

100アイテムのリストがあります。これらのアイテムをランダムにペアリングしたいと思います。これらのペアは一意である必要があるため、合計で4950の可能性（100は2を選択）があります。

4950ペアすべてのうち、1000ペアをランダムに選択したいと思います。しかし、重要なのは、（100個のアイテムのうちの）各アイテムが全体的に同じ回数（ここでは20回）表示されるようにすることです。

私はこれをコードで数回実装しようとしました。そして、選択したペアの数を減らして試してみるとうまくいきましたが、1000ペアをすべて試してみるたびに、ループに陥ります。

誰かがアプローチのアイデアを持っていますか？また、選択したいペアの数を変更した場合はどうなりますか（たとえば、1000のランダムペアではなく1500）？

私の試み（VBAで書かれています）：

Dim City1(4951) As Integer
Dim City2(4951) As Integer

Dim CityCounter(101) As Integer
Dim PairCounter(4951) As Integer

Dim i As Integer 
Dim j As Integer
Dim k As Integer
i = 1

While i < 101
    CityCounter(i) = 0
    i = i + 1
Wend

i = 1
While i < 4951
    PairCounter(i) = 0
    i = i + 1
Wend

i = 1
j = 1

While j < 101

    k = j + 1

    While k < 101
        City1(i) = j
        City2(i) = k

        k = k + 1
        i = i + 1       
    Wend

    j = j + 1

Wend

Dim temp As Integer

i = 1
While i < 1001

    temp = Random(1,4950)

    While ((PairCounter(temp) = 1) Or (CityCounter( (City1(temp)) ) = 20) Or (CityCounter( (City2(temp)) ) = 20))
        temp = Random(1,4950)
    Wend

    PairCounter(temp) = 1
    CityCounter( (City1(temp)) ) = (CityCounter( (City1(temp)) ) + 1)
    CityCounter( (City2(temp)) ) = (CityCounter( (City2(temp)) ) + 1)
    i = i + 1

Wend
4

4 に答える 4

1

リストを取り、それをスクランブルし、2つの要素ごとにペアとしてマークを付けます。これらのペアをペアのリストに追加します。ペアのリストがソートされていることを確認します。

ペアのリストをスクランブルし、各ペアを「ステージングされた」ペアリストに追加します。ペアのリストにあるかどうかを確認します。ペアのリストにある場合は、スクランブルして最初からやり直します。重複のないリスト全体を取得する場合は、ステージングされたペアリストをペアリストに追加して、この段落を最初からやり直してください。

これには最終的に非決定的なステップが含まれるため、どれだけ遅くなるかはわかりませんが、機能するはずです。

于 2013-02-14T22:21:02.587 に答える
1

これは古いスレッドですが、私は似たようなものを探していて、最終的に自分でそれを行いました。

アルゴリズムは100％ランダムではありません（ランダムな試行が失敗して少し「疲れた」後、テーブルの体系的なスクリーニングを開始します:)-とにかく私にとっては-「十分にランダム」）、適度に高速に動作し、必要なテーブルを返します（残念ながら常にではありません） 、しかし...）通常は2回目または3回目ごとに使用します（各アイテムに必要なペアの数がある場合は、A1を調べてください）。これがExcel環境で実行されるVBAコードです。出力は、A1セルから始まる現在のシートに送られます。

Option Explicit
Public generalmax%, oldgeneralmax%, generalmin%, alloweddiff%, i&
Public outtable() As Integer
Const maxpair = 100, upperlimit = 20


Sub generate_random_unique_pairs()
'by Kaper 2015.02 for stackoverflow.com/questions/14884975
Dim x%, y%, counter%
Randomize
ReDim outtable(1 To maxpair + 1, 1 To maxpair + 1)
Range("A1").Resize(maxpair + 1, maxpair + 1).ClearContents
alloweddiff = 1
Do
  i = i + 1
  If counter > (0.5 * upperlimit) Then 'try some systematic approach
    For x = 1 To maxpair - 1 ' top-left or:' To 1 Step -1 ' bottom-right
      For y = x + 1 To maxpair
        Call test_and_fill(x, y, counter)
      Next y
    Next x
    If counter > 0 Then
      alloweddiff = alloweddiff + 1
      counter = 0
    End If
  End If
  ' mostly used - random mode
  x = WorksheetFunction.RandBetween(1, maxpair - 1)
  y = WorksheetFunction.RandBetween(x + 1, maxpair)
  counter = counter + 1
  Call test_and_fill(x, y, counter)
  If counter = 0 Then alloweddiff = WorksheetFunction.Max(alloweddiff, 1)
  If i > (2.5 * upperlimit) Then Exit Do
Loop Until generalmin = upperlimit
Range("A1").Resize(maxpair + 1, maxpair + 1).Value = outtable
Range("A1").Value = generalmin
Application.StatusBar = ""
End Sub

Sub test_and_fill(x%, y%, ByRef counter%)
Dim temprowx%, temprowy%, tempcolx%, tempcoly%, tempmax%, j%
tempcolx = outtable(1, x + 1)
tempcoly = outtable(1, y + 1)
temprowx = outtable(x + 1, 1)
temprowy = outtable(y + 1, 1)
tempmax = 1+ WorksheetFunction.Max(tempcolx, tempcoly, temprowx, temprowy)
If tempmax <= (generalmin + alloweddiff) And tempmax <= upperlimit And outtable(y + 1, x + 1) = 0 Then
  counter = 0
  outtable(y + 1, x + 1) = 1
  outtable(x + 1, y + 1) = 1
  outtable(x + 1, 1) = 1 + outtable(x + 1, 1)
  outtable(y + 1, 1) = 1 + outtable(y + 1, 1)
  outtable(1, x + 1) = 1 + outtable(1, x + 1)
  outtable(1, y + 1) = 1 + outtable(1, y + 1)
  generalmax = WorksheetFunction.Max(generalmax, outtable(x + 1, 1), outtable(y + 1, 1), outtable(1, x + 1), outtable(1, y + 1))
  generalmin = outtable(x + 1, 1)
  For j = 1 To maxpair
    If outtable(j + 1, 1) < generalmin Then generalmin = outtable(j + 1, 1)
    If outtable(1, j + 1) < generalmin Then generalmin = outtable(1, j + 1)
  Next j
  If generalmax > oldgeneralmax Then
    oldgeneralmax = generalmax
    Application.StatusBar = "Working on pairs " & generalmax & "Total progress (non-linear): " & Format(1# * generalmax / upperlimit, "0%")
  End If
  alloweddiff = alloweddiff - 1
  i = 0
End If
End Sub
于 2015-02-17T14:50:21.700 に答える
0

appeared[]各項目がすでに回答に表示された回数を追跡する配列を用意します。各要素が出現する必要があるとしましょうk。配列を反復処理し、現在の要素のappeared値が。未満でkある間、出現回数が少ない要素からランダムなペアを選択しますk。そのペアを追加して回答し、両方の出現数を増やします。

于 2013-02-14T22:20:35.533 に答える
0
  • ブール値の2次元100*100行列を作成します。すべてFalseです。
  • これらの10Kブール値のうち、次の制約を使用して、それらの1Kをtrueに設定します。
  • 対角線は空のままにする必要があります
  • 行または列に20を超える真の値を含めることはできません
  • 最後に、すべての行と列に20個のTrue値が必要です。

ここで、X=Yの対角対称性があります。次の制約を追加するだけです。

  • 対角線の片側の三角形は空のままにする必要があります
  • 上記の制約では、行と列の制限を組み合わせたり追加したりする必要があります
于 2013-02-14T22:55:36.317 に答える