Случайные уникальные пары

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 раз. Перейдем к массиву, и если текущий элемент имеет значение appeared меньше k, выберите для него случайную пару, которая также оказалась менее k раз. Добавьте эту пару, чтобы ответить и увеличить количество просмотров для обоих.

Answer 3

• создать 2-мерную 100 * 100 матрица булевы, все ложные
• этих 10K булевы, установите 1K из них правда, со следующими ограничениями:
• диагональ должна оставаться пустой
• ни одна строка или столбец не должна иметь более 20 истинных значений
• В конце каждая строка и столбец должны иметь 20 значений True.

Теперь существует диагональная симметрия X = Y. Просто добавьте следующие ограничения:

• треугольник на одной стороне диагонали должна оставаться пустой
• в указанных выше ограничений, ограничения для строк & столбцы должны быть объединены/добавлен

Answer 4

Это но я искал что-то подобное, и, наконец, сделал это сам.

Алгоритм не является случайным 100% (после того, как он «устал» с неуспешными случайными испытаниями, начинает систематический показ таблицы :) - в любом случае для меня - «достаточно случайный»), но работает достаточно быстро и возвращает требуемую таблицу (неудовлетворенность не всегда, но ...) обычно каждую секунду или третье использование (смотрите в А1, если для каждого элемента есть ваше количество пар). Вот код VBA для работы в среде Excel. Выход направлен на текущий лист, начиная с ячейки 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