Как создать все перестановки, начиная со списка слов

Question

У меня есть список из 10 слов, и мне нужно создать массив, содержащий все различные перестановки из этих слов, то есть [[1,2,3,4], [1,2,4,3], [1,4,2,3], ...].

Мне удалось заставить его работать через Javascript, но я действительно борюсь с VBA.

function perm(xs) {
  let ret = [];

  for (let i = 0; i < xs.length; i = i + 1) {
    let rest = perm(xs.slice(0, i).concat(xs.slice(i + 1)));

    if (!rest.length) {
      ret.push([xs[i]])
    } else {
      for (let j = 0; j < rest.length; j = j + 1) {
        ret.push([xs[i]].concat(rest[j]))
      }
    }
  }
  return ret;
}

Answer 1

Pᴇʜ и Tragamor интерпретируют ваш вопрос как запрос для всех перестановок из четырех слов. Я интерпретирую ваш вопрос как просьбу ко всем перестановкам из десяти слов. Их ответы соответствуют их интерпретации. Этот ответ соответствует моей интерпретации, хотя он должен возвращать все перестановки любого количества слов. Я полностью проверил свою рутину при создании всех перестановок от трех до девяти слов. Для десяти или более слов моя тестовая процедура занимает слишком много времени, чтобы быть жизнеспособной. Поскольку моя рутина работает до девяти слов включительно, я предполагаю, что она работает для больших чисел.

И Pᴇʜ, и Tragamor использовали рекурсию. Я считаю рекурсию очень полезной техникой, но для VBA, если не для других языков, это медленная техника. Я отказался от рекурсии.

С моей техникой подпрограмма Перестановки имеет два параметра: массив, Слова (содержащий десять слов) и Перестановки массива (в которых возвращаются 3628800 перестановок). Подпрограмма имеет массив PermCrnt, содержащий индексы десяти слов. Если нижняя граница слов равна 0, начальное значение PermCrnt:

0 1 2 3 4 5 6 7 8 9

Основной цикл подпрограммы Permutation использует индексы PermCrnt для вывода текущей перестановки в массив Permutations, а затем сбрасывает PermCrnt до следующей последовательности. Этот цикл продолжается до тех пор, пока перестановки в массиве не будут заполнены.

Код, который сбрасывает PermCrnt, смотрит справа на два индекса, которые не находятся в возрастающей последовательности. Эти индексы и все справа удалены из PermCrnt. Самый левый удаленный индекс заменяется следующим по порядку. Остальные индексы располагаются в порядке возрастания. Это дает:

                      First pair not in ascending sequence. Remove that
PermCrnt              pair and all to their right and re-sequence them.
0 1 2 3 4 5 6 7 8 9   “8 9”
0 1 2 3 4 5 6 7 9 8   “7 9”
0 1 2 3 4 5 6 8 7 9   “7 9”
0 1 2 3 4 5 6 8 9 7   “8 9”
0 1 2 3 4 5 6 9 7 8   “7 8”
0 1 2 3 4 5 6 9 8 7   “6 9”
0 1 2 3 4 5 7 6 8 9   “8 9”
0 1 2 3 4 5 7 6 9 8

Как видно, этот простой алгоритм циклически перебирает все возможные перестановки до:

9 8 7 6 5 4 3 2 1 0

Для десяти слов моя процедура занимает около 12 секунд, чтобы сгенерировать 36280000 перестановок.

Моя рутина, и ее тест ниже. Примечание: из-за того, как я тестировал PermWords, было удобно, чтобы Words был Вариантом. Вы можете изменить массив строк.

Option Explicit
Sub CallPermutations()

  Dim ColOutCrnt As Long
  Dim Duration As Single
  Dim InxPerm As Long
  Dim InxWord As Long
  Dim Match As Boolean
  Dim MultiWords As Variant
  Dim NumWords As Long
  Dim NumPerms As Long
  Dim Permutations() As String
  Dim RowOutCrnt1 As Long
  Dim RowOutCrnt2 As Long
  Dim RowOutMax As Long
  Dim TimeStart As Single
  Dim Words As Variant

  Application.ScreenUpdating = False

  MultiWords = VBA.Array(VBA.Array("apple", "bear", "cat"), _
                         VBA.Array("apple", "bear", "cat", "dog"), _
                         VBA.Array("apple", "bear", "cat", "dog", "egg"), _
                         VBA.Array("apple", "bear", "cat", "dog", "egg", "fast"), _
                         VBA.Array("apple", "bear", "cat", "dog", "egg", "fast", _
                                   "game"), _
                         VBA.Array("apple", "bear", "cat", "dog", "egg", "fast", _
                                   "game", "house"), _
                         VBA.Array("apple", "bear", "cat", "dog", "egg", "fast", _
                                   "game", "house", "island"), _
                         VBA.Array("apple", "bear", "cat", "dog", "egg", "fast", _
                                   "game", "house", "island", "joy"))

  For Each Words In MultiWords

    TimeStart = Timer
    Call PermWords(Words, Permutations)
    Duration = Timer - TimeStart

    NumWords = UBound(Words) - LBound(Words) + 1
    NumPerms = UBound(Permutations, 1) - LBound(Permutations, 1) + 1

    Debug.Print "Generating " & PadL(NumPerms, 7) & _
                " permutations of " & PadL(NumWords, 2) & _
                " words took " & PadL(Format(Duration, "#,##0.000"), 9) & " seconds"

    If NumWords < 9 Then

     TimeStart = Timer
      For RowOutCrnt1 = LBound(Permutations, 1) To UBound(Permutations, 1) - 1
        For RowOutCrnt2 = RowOutCrnt1 + 1 To UBound(Permutations, 1)
          Match = True
          For ColOutCrnt = 1 To NumWords
            If Permutations(RowOutCrnt1, ColOutCrnt) <> _
               Permutations(RowOutCrnt2, ColOutCrnt) Then
              Match = False
              Exit For
            End If
          Next
          If Match Then
            Debug.Print
            Debug.Print "Row " & RowOutCrnt1 & " = " & "Row " & RowOutCrnt2
            Debug.Assert False
          Else
          End If
        Next
      Next

      Duration = Timer - TimeStart

      Debug.Print "Testing    " & PadL(NumPerms, 7) & _
                  " permutations of " & PadL(NumWords, 2) & _
                  " words took " & PadL(Format(Duration, "#,##0.000"), 9) & " seconds"
    End If

    DoEvents
  Next

End Sub
Sub PermWords(ByRef Words As Variant, ByRef Permutations() As String)

  ' On entry Words is a list of words created by Array, VBA.Array or
  ' by code that emulated Array or VBA.Array.
  ' On exit, Permutations will contain one row permutation of the words.

  ' Note: Array creates an array with a lower bound of zero or one depending
  ' on the Option Base statement while VBA.Array creates an array with a
  ' lower bound that is always zero.

  ' Permutations will be redim'ed as a two-dimensional array.  The first
  ' dimension will have bounds of one to number-of-permutations.  The second
  ' dimension will have bounds to match those of Words.

  ' If Words contains "one", "two" and "three", Permutations will contain:
  '   "one"   "two"   "three"
  '   "one"   "three" "two"
  '   "two"   "one"   "three"
  '   "two"   "three" "one"
  '   "three" "one"   "two"
  '   "three" "two"   "one"

  Dim InxPermCrnt As Long
  Dim InxToPlaceCrnt As Long
  Dim InxToPlaceMax As Long
  Dim InxToPlaceNext As Long
  Dim InxWord As Long
  Dim ValueNext As Long
  Dim NumPerms As Long
  Dim NumWords As Long
  Dim PermCrnt() As Long
  Dim RowPerms As Long
  Dim ToPlace() As Long

  ' Calculate number of words and number of permutations
  NumWords = UBound(Words) - LBound(Words) + 1
  NumPerms = Factorial(NumWords)

  ' Redim arrays to required size
  ReDim PermCrnt(LBound(Words) To UBound(Words))
  ReDim Permutations(1 To NumPerms, LBound(Words) To UBound(Words))
  ReDim ToPlace(1 To NumWords)

  RowPerms = 1    ' First row in Permutations

  ' Create initial sequence of words
  For InxWord = LBound(Words) To UBound(Words)
    PermCrnt(InxWord) = InxWord
  Next

  ' Loop until Permutations() is full
  Do While True
    ' Output current permutation to Permutations
    For InxPermCrnt = LBound(PermCrnt) To UBound(PermCrnt)
      InxWord = PermCrnt(InxPermCrnt)
      Permutations(RowPerms, InxPermCrnt) = Words(InxWord)
    Next
    RowPerms = RowPerms + 1
    If RowPerms > UBound(Permutations, 1) Then
      ' All permutations generated
      Exit Sub
    End If
    ' Generate next sequence
    ' Find first pair from right not in ascending sequence
    ' Copy this pair, and all to its right, to ToPlace()
    InxToPlaceMax = 1
    ToPlace(InxToPlaceMax) = PermCrnt(UBound(PermCrnt))
    For InxPermCrnt = UBound(PermCrnt) - 1 To LBound(PermCrnt) Step -1
      InxToPlaceMax = InxToPlaceMax + 1
      ToPlace(InxToPlaceMax) = PermCrnt(InxPermCrnt)
      If PermCrnt(InxPermCrnt) < PermCrnt(InxPermCrnt + 1) Then
        Exit For
      End If
    Next
    ' Elements InxPermCrnt to UBound(PermCrnt) of PermCrnt are to be
    ' resequenced.  PermCrnt(InxPermCrnt) will reference the next to place word
    ' in sequence.  Remaining elements will be the values from ToPlace() in
    ' ascending sequence.
    ' Find next value above value in PermCrnt(InxPermCrnt)
    ValueNext = -1
    InxToPlaceNext = -1
    For InxToPlaceCrnt = 1 To InxToPlaceMax
      If PermCrnt(InxPermCrnt) < ToPlace(InxToPlaceCrnt) Then
        ' ToPlace(InxToPlaceCrnt) is greater than PermCrnt(InxPermCrnt). It will
        ' be the next in sequence unless there is PermCrnt(X) such that
        ' PermCrnt(InxPermCrnt) < PermCrnt(X) < ToPlace(InxToPlaceCrnt)
        If InxToPlaceNext = -1 Then
          ' This is the first ToPlace entry found that is greater than
          ' PermCrnt(InxPermCrnt)
          ValueNext = ToPlace(InxToPlaceCrnt)
          InxToPlaceNext = InxToPlaceCrnt
        Else
          ' This is not the first ToPlace value greater than PermCrnt(InxPermCrnt)
          If ValueNext > ToPlace(InxToPlaceCrnt) Then
            ValueNext = ToPlace(InxToPlaceCrnt)
            InxToPlaceNext = InxToPlaceCrnt
          End If
        End If
      End If
    Next
    ' If stop here, next value in sequence not found
    Debug.Assert ValueNext <> PermCrnt(InxPermCrnt)
    ' Place next value in PermCrnt() and remove from ToPlace()
    PermCrnt(InxPermCrnt) = ValueNext
    ToPlace(InxToPlaceNext) = ToPlace(InxToPlaceMax)
    InxToPlaceMax = InxToPlaceMax - 1
    ' Move remaining values in ToPlace() to PermCrnt() in ascending sequence
    Do While InxToPlaceMax > 0
      InxPermCrnt = InxPermCrnt + 1  ' Next position within PermCrnt
      ' Find next value to place
      ValueNext = ToPlace(1)
      InxToPlaceNext = 1
      For InxToPlaceCrnt = 2 To InxToPlaceMax
        If ValueNext > ToPlace(InxToPlaceCrnt) Then
          ValueNext = ToPlace(InxToPlaceCrnt)
          InxToPlaceNext = InxToPlaceCrnt
        End If
      Next
      ' Place next value in PermCrnt() and remove from ToPlace()
      PermCrnt(InxPermCrnt) = ValueNext
      ToPlace(InxToPlaceNext) = ToPlace(InxToPlaceMax)
      InxToPlaceMax = InxToPlaceMax - 1
    Loop  ' until all values in ToPlace() copied to PermCrnt()
  Loop  ' until Permutations() is full

End Sub
Function Factorial(ByVal Num As Long)

  ' Return Fsctorial Num

  '  6Jun19  Coded

  Dim Answer As Long
  Dim I As Long

  Answer = 1
  For I = 1 To Num
    Answer = Answer * I
  Next I
  Factorial = Answer

End Function
Public Function PadL(ByVal Str As String, ByVal PadLen As Long, _
                     Optional ByVal PadChr As String = " ") As String

  ' Pad Str with leading PadChr to give a total length of PadLen
  ' If the length of Str exceeds PadLen, Str will not be truncated

  '   Sep15 Coded
  ' 20Dec15 Added code so overlength strings are not truncated
  ' 10Jun16 Added PadChr so could pad with characters other than space

  If Len(Str) >= PadLen Then
    ' Do not truncate over length strings
    PadL = Str
  Else
    PadL = Right$(String(PadLen, PadChr) & Str, PadLen)
  End If

End Function
Public Function PadR(ByVal Str As String, ByVal PadLen As Long, _
                     Optional ByVal PadChr As String = " ") As String

  ' Pad Str with trailing PadChr to give a total length of PadLen
  ' If the length of Str exceeds PadLen, Str will not be truncated

  '   Nov15 Coded
  ' 15Sep16 Added PadChr so could pad with characters other than space

  If Len(Str) >= PadLen Then
    ' Do not truncate over length strings
    PadR = Str
  Else
    PadR = Left$(Str & String(PadLen, PadChr), PadLen)
  End If

End Function

Answer 2

Без повторения и выбора всегда 4 слова

Option Explicit

Public Sub Permutations()
    Dim Words() As Variant
    Words = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10)

    Dim p1 As Long, p2 As Long, p3 As Long, p4 As Long
    For p1 = LBound(Words) To UBound(Words)
        For p2 = LBound(Words) To UBound(Words)
            If p2 <> p1 Then
                For p3 = LBound(Words) To UBound(Words)
                    If p3 <> p1 And p3 <> p2 Then
                        For p4 = LBound(Words) To UBound(Words)
                            If p4 <> p1 And p4 <> p2 And p4 <> p3 Then
                                Debug.Print Words(p1); Words(p2); Words(p3); Words(p4)
                            End If
                        Next p4
                    End If
                Next p3
            End If
        Next p2
    Next p1
End Sub

Вывод будет выглядеть примерно так:

 1  2  3  4 
 1  2  3  5 
 1  2  3  6 
 1  2  3  7 
 1  2  3  8 
 1  2  3  9 
 1  2  3  10 
 1  2  4  3 
 1  2  4  5 
 1  2  4  6 
 1  2  4  7 
 1  2  4  8 
…
10  9  8  7 

В качестве альтернативы напишите рекурсивную функцию.

---

Поместитьвсе в массив

Option Explicit

Public Sub PermutationsToArray()
    Dim Words() As Variant
    Words = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10)

    Dim WordsCount As Long
    WordsCount = UBound(Words) - LBound(Words) + 1

    Dim OutputCount As Long
    OutputCount = WordsCount * (WordsCount - 1) * (WordsCount - 2) * (WordsCount - 3)

    ReDim OutputArray(0 To OutputCount - 1, 0 To 3) As Variant

    Dim iCount As Long

    Dim p1 As Long, p2 As Long, p3 As Long, p4 As Long
    For p1 = LBound(Words) To UBound(Words)
        For p2 = LBound(Words) To UBound(Words)
            If p2 <> p1 Then
                For p3 = LBound(Words) To UBound(Words)
                    If p3 <> p1 And p3 <> p2 Then
                        For p4 = LBound(Words) To UBound(Words)
                            If p4 <> p1 And p4 <> p2 And p4 <> p3 Then
                                OutputArray(iCount, 0) = Words(p1)
                                OutputArray(iCount, 1) = Words(p2)
                                OutputArray(iCount, 2) = Words(p3)
                                OutputArray(iCount, 3) = Words(p4)
                                iCount = iCount + 1
                            End If
                        Next p4
                    End If
                Next p3
            End If
        Next p2
    Next p1
End Sub

Answer 3

Я считаю, что с массивами может быть немного неудобно работать, поэтому этот рекурсивный алгоритм использует сгенерированную символьную маску в качестве входных данных для вычислений перестановки, а затем копирует соответствующие элементы из исходного массива в выходной массив.

Вы могли бы вместо этого создать 1D-массив карты символов и использовать его вместо 2D-массива, если у вас возникнут проблемы с большими массивами данных

Время для расчета и загрузки массива для 10 слов: 12,62 секунды

Dim StartTime As Single

Sub TestMain()
    StartTime = Timer

    Dim InArr() As Variant, OutArr() As Variant
    InArr = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J")

    Dim i As Long, j As Long, xStr As String

    i = UBound(InArr) - LBound(InArr)
    ReDim OutArr(i, Fact(i + 1) - 1)

    For i = 0 To UBound(InArr) - LBound(InArr)
        xStr = xStr & Chr(i + 65)
    Next i
    Call GetPermutations(InArr, OutArr, xStr)

    Debug.Print Timer - StartTime

    Exit Sub

    ' Readout
    For j = 0 To UBound(OutArr, 2)
        xStr = ""
        For i = 0 To UBound(OutArr, 1)
            xStr = xStr & OutArr(i, j)
        Next i
        Debug.Print xStr
    Next j
End Sub

Function GetPermutations(ByRef InArr() As Variant, ByRef OutArr() As Variant, S2 As String, Optional S1 As String, Optional xRow As Long)
    If IsMissing(S1) Then S1 = ""
    If IsMissing(xRow) Then xRow = 0

    If Len(S2) < 2 Then
        ' "S1 & S2" would be the character map for this iteration
        Call LoadArray(InArr, OutArr, S1 & S2, xRow)
        xRow = xRow + 1
    Else
        Dim i As Integer: For i = 1 To Len(S2)
            Call GetPermutations(InArr, OutArr, Left(S2, i - 1) + Right(S2, Len(S2) - i), S1 + Mid(S2, i, 1), xRow)
        Next i
    End If
End Function

Function LoadArray(ByRef InArr() As Variant, ByRef OutArr() As Variant, Order As String, xRow As Long)
    Dim i As Integer: For i = 1 To Len(Order)
        OutArr(i - 1, xRow) = InArr(Asc(Mid(Order, i, 1)) - 65)
    Next i
End Function

Function Fact(i As Integer) As Long
    Fact = 1: For j = 1 To i: Fact = Fact * j: Next j
End Function