隨機唯一對

Question

我有一個100個項目的列表。我想隨機將這些項目相互配對。這些配對必須是唯一的，所以共有4950種可能性（100選2）。

在所有4950對中，我想隨機選擇1000對。但他們關鍵的是，我希望每個項目（100個項目）的整體出現次數相同（此處爲20次）。

我試着用代碼實現這一點幾次。當我嘗試選擇較少的對時，它運行良好，但每次嘗試使用完整的1000對時，我都會陷入循環。

有沒有人有一種方法的想法？而如果我改變了我想選擇的配對數量（例如，1500而不是1000個隨機配對）呢？

我嘗試（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 

Answer 1

取一個列表，對其進行加密，並將每兩個元素標記爲一對。將這些配對添加到配對列表中。確保對列表進行排序。

加擾配對列表，並將每個配對添加到「分段」配對列表中。檢查它是否在成對的列表中。如果它在成對的列表中，爭奪並重新開始。如果您得到的整個列表沒有任何重複，請將暫存的對列表添加到對列表中，並開始本段。

由於這涉及到最終的非確定性步驟，我不確定它會有多慢，但它應該工作。

Answer 2

有一個數組appeared[]以跟蹤多少次每個項目已經出現了答案。假設每個元素必須出現k次。遍歷數組，並且當前元素的值小於k時，爲該元素選擇一個隨機對，該元素的出現次數也小於k次。添加該對來回答並增加兩者的外觀計數。

Answer 3

• 創建一個2維100 * 100矩陣布爾值，這些10K布爾的全是假的
• ，設置它們的1K爲真，有以下限制：
• 對角線應保持空
• 沒有行或列應該有20個以上的真值
• 最後，每行和每列應該有20個真值。

現在，存在X = Y對角對稱性。只需添加以下約束：

• 在對角的一側上的三角形應在上面的約束住空
• ，加入

Answer 4

&列應結合的行的限制/這老線索，但我正在尋找類似的東西，最後自己做了。

該算法不是100％隨機的（經過一段時間的累贅後，隨機試驗開始對錶格進行系統篩選:) - 無論如何 - 「足夠隨機」），但工作速度相當快，並返回所需的表格（不幸的是，並不總是，但是......）通常每隔兩秒鐘或三次使用（如果每個項目有你需要的配對數目，請在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