Algorithm 随机唯一对

我有一张100件物品的清单。我想把这些东西随机配对。这些配对必须是唯一的，因此总共有4950个可能性（100个选择2）

在所有4950对中，我想随机挑选1000对。但它们的关键是，我希望每个项目（100个项目中）总的显示次数相同（这里是20次）

我曾多次尝试用代码实现这一点。当我尝试选择较少数量的对时，效果很好，但每次我尝试使用完整的1000对时，我都会陷入一个循环

有人有办法吗？如果我更改希望选择的对数（例如，1500对而不是1000对随机对），该怎么办

我的尝试（用VBA编写）：

Dim City1（4951）作为整数
Dim City2（4951）为整数
将城市计数器（101）设置为整数
Dim PairCounter（4951）作为整数
作为整数的Dim i
作为整数的Dim j
将k变为整数
i=1
当我<101
城市计数器（i）=0
i=i+1
温德
i=1
而我<4951
配对计数（i）=0
i=i+1
温德
i=1
j=1
而j<101
k=j+1
而k<101
城市1（i）=j
城市2（i）=k
k=k+1
i=i+1
温德
j=j+1
温德
作为整数的Dim temp
i=1
当我<1001
温度=随机（14950）
而（（配对计数（温度）=1）或（城市计数（（城市1（温度）））=20）或（城市计数（（城市2（温度））=20））
温度=随机（14950）
温德
配对计数器（温度）=1
城市计数器（（城市1（温度））=（城市计数器（（城市1（温度）））+1）
城市计数器（（城市2（温度））=（城市计数器（（城市2（温度）））+1）
i=i+1
温德

有一个数组

出现[]

，它记录每个项目在答案中出现的次数。假设每个元素必须出现

k

次。迭代数组，当当前元素的

值小于
k
时，从该元素中选择一对出现次数小于
k
的随机对。将这对元素添加到答案中，并增加这两个元素的出现次数。
列出一个列表，将其置乱，并将每两个元素标记为一对。将这些对添加到对列表中。确保对列表进行了排序

将配对列表置乱，并将每个配对添加到“分段”配对列表中。检查它是否在配对列表中。如果它在配对列表中，则将其置乱并重新开始。如果您得到的是没有任何重复项的完整列表，请将暂存对列表添加到对列表中，然后重新开始此段落

由于这涉及到最后一个不确定的步骤，我不确定它会有多慢，但它应该可以工作。

创建一个二维100*100布尔矩阵，全部为False
在这些10K布尔值中，将其中1K设置为true，并具有以下约束：
对角线应保持为空
任何行或列的真值都不应超过20个
最后，每行和每列应该有20个真值

现在，这里是X=Y对角对称。只需添加以下约束：


对角线一侧的三角形应保持为空
在上述约束中，应合并/添加行和列的约束
这是一条古老的线索，但我一直在寻找类似的线索，最后我自己做了

该算法不是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

选项显式
Public generalmax%、oldgeneralmax%、generalmin%、allowediff%、i&
Public outtable（）为整数
常量最大对=100，上限=20
子生成\u随机\u唯一\u对（）
由Kaper 2015.02为stackoverflow.com/questions/14884975撰写
尺寸x%，y%，计数器%
随机化
ReDim输出表（1到maxpair+1，1到maxpair+1）
范围（“A1”）。调整大小（maxpair+1，maxpair+1）。ClearContent
AllowedIFF=1
做
i=i+1
如果计数器>（0.5*上限），则“尝试一些系统方法”
对于x=1至maxpair-1'左上角或'To 1 Step-1'右下角
对于y=x+1到maxpair
调用测试和填充（x、y、计数器）
下一个y
下一个x
如果计数器>0，则
AllowEdiff=AllowEdiff+1
计数器=0
如果结束
如果结束
“常用-随机模式
x=工作表函数.randbween（1，maxpair-1）
y=工作表函数.RandBetween（x+1，maxpair）
计数器=计数器+1
调用测试和填充（x、y、计数器）
如果计数器=0，则AllowEdiff=WorksheetFunction.Max（AllowEdiff，1）
如果i>（2.5*上限），则退出Do
循环直到generalmin=上限
范围（“A1”）。调整大小（maxpair+1，maxpair+1）。值=输出表
范围（“A1”）。值=一般最小值
Application.StatusBar=“”
端接头
子测试和填充（x%，y%，ByRef计数器%）
Dim temprowx%，temprowy%，tempcolx%，tempcoly%，tempmax%，j%
tempcolx=outtable（1，x+1）
tempcoly=表外（1，y+1）
temprowx=表外（x+1，1）
temprowy=outtable（y+1，1）
tempmax=1+工作表function.Max（tempcolx，tempcoly，temprowx，temprowy）
如果tempmax认为对2有效的值应为1000到。将我的尝试发布为编辑。随机计数器的计算范围似乎比您想要的范围小一个。它是否应该是随机的（14951）？这将确保所有项目的使用次数相同。但它无法确保存在唯一的对。好主意！谢谢！效率在这里不是一个真正的问题。这看起来像我尝试的——请参阅我最近的编辑。但是，当我运行代码时，我陷入了一个while循环。
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