随机唯一对

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