有没有更高效的方法来计算一个数组的幂集？

Question

这是我当前使用位实现的代码：

Function Array_PowerSet(Self)
    Array_PowerSet = Array()
    PowerSetUpperBound = -1
    For Combination = 1 To 2 ^ (UBound(Self) - LBound(Self)) ' I don't want the null set
        Subset = Array()
        SubsetUpperBound = -1
        For NthBit = 0 To Int(WorksheetFunction.Log(Combination, 2))
            If Combination And 2 ^ NthBit Then
                SubsetUpperBound = SubsetUpperBound + 1
                ReDim Preserve Self(0 To SubsetUpperBound)
                Subset(SubsetUpperBound) = Self(NthBit)
            End If
        Next
        PowerSetUpperBound = PowerSetUpperBound + 1
        ReDim Preserve Array_PowerSet(0 To PowerSetUpperBound)
        Array_PowerSet(PowerSetUpperBound) = Subset
    Next
End Function

请忽略变量的滥用。Array_Push和Array_Size应该很容易理解。

之前，我为每个组合生成了一个二进制字符串，但这涉及到调用另一个函数，效率不是很高。

除了使用更少的变量并将外部函数调用移至内部，还有其他方法可以提高效率吗？

编辑：这里是完全独立的版本。

Function Array_PowerSet(Self As Variant) As Variant
    Dim PowerSet() As Variant, PowerSetIndex As Long, Size As Long, Combination As Long, NthBit As Long
    PowerSetIndex = -1: Size = UBound(Self) - LBound(Self) + 1
    ReDim PowerSet(0 To 2 ^ Size - 2) ' Don't want null set

    For Combination = 1 To 2 ^ Size - 1
        Dim Subset() As Variant, SubsetIndex As Long: SubsetIndex = -1

        For NthBit = 0 To Int(WorksheetFunction.Log(Combination, 2))
            If Combination And 2 ^ NthBit Then
                SubsetIndex = SubsetIndex + 1
                ReDim Preserve Subset(0 To SubsetIndex)
                Subset(SubsetIndex) = Self(NthBit)
            End If
        Next

        PowerSetIndex = PowerSetIndex + 1
        PowerSet(PowerSetIndex) = Subset
    Next

    Array_PowerSet = PowerSet
End Function

并进行测试：

Dim Input_() As Variant, Output_() As Variant, Subset As Variant, Value As Variant
Input_ = Array(1, 2, 3)
Output_ = Array_PowerSet(Input_)

For Each Subset In Output_
    Dim StringRep As String: StringRep = "{"

    For Each Value In Subset
        StringRep = StringRep & Value & ", "
    Next

    Debug.Print Left$(StringRep, Len(StringRep) - 2) & "}"
Next

- Hao Zhang

---

为什么不提供所有相关的代码并将其制作成一个 [mcve] 呢？Array_Push 可能是瓶颈（例如，如果它是 ReDim Preserve 的包装器以添加另一个元素，则非常低效，因为您会重复复制元素）。 - John Coleman

Array_Push和Array_Size应该是不言自明的。但如果你在编程论坛上寻求帮助，可能并非如此。 - Robin Mackenzie

更新了帖子。 - Hao Zhang

Answer 1

由于子集数量呈指数级增长，没有算法是真正高效的，尽管在你所做的事情中还有改进的空间：

ReDim Preserve用于通过单个项目扩展数组时效率低下，因为它涉及创建一个具有1个更多空间的新数组，然后将旧元素复制到新数组中。最好预先分配足够的空间，然后将其削减到所需大小：

Function PowerSet(Items As Variant) As Variant
    'assumes that Items is a 0-based array
    'returns a 0-based jagged array of subsets of Items
    'where each subset is a 0-based array

    Dim PS As Variant
    Dim i As Long, j As Long, k As Long, n As Long
    Dim subset As Variant

    n = 1 + UBound(Items) 'cardinality of the base set
    ReDim PS(0 To 2 ^ n - 2)
    For i = 1 To 2 ^ n - 1
        subset = Array()
        ReDim subset(0 To n - 1)
        k = -1 'will be highest used index of the subset
        For j = 0 To n - 1
            If i And 2 ^ j Then
                k = k + 1
                subset(k) = Items(j)
            End If
        Next j
        ReDim Preserve subset(0 To k)
        PS(i - 1) = subset
    Next i
    PowerSet = PS
End Function

一项测试功能：

Sub test()
    Dim stuff As Variant, subsets As Variant
    Dim i As Long

    stuff = Array("a", "b", "c", "d")
    subsets = PowerSet(stuff)
    For i = LBound(subsets) To UBound(subsets)
        Cells(i + 1, 1).Value = "{" & Join(subsets(i), ",") & "}"
    Next i
End Sub

- John Coleman

---

ArrayList是否对于这项任务更好？在返回之前，我只需调用它们的ToArray方法即可。 - Hao Zhang

@HaoZhang 进行基准测试并查看结果。使用ArrayLists肯定更优雅，但是使用外部库会有一定的开销。我的直觉是它既不会帮助太多，也不会造成太大的影响。ArrayList代码无法在Mac的VBA中移植，但对于大多数Excel VBA用户来说，这并不是问题。 - John Coleman

Answer 2

使用集合来构建您的集合是一种选择...

Function Generator()
    Dim Arr() As Variant: Arr = Array(1, 2, 3, 4)
    Dim PSCol As Collection: Set PSCol = PowerSetCol(Arr)
    Dim SubSet As Collection, SubSetStr As String

    For i = 1 To PSCol.Count
        Set SubSet = PSCol.Item(i)
        SubSetStr = "{"
        For j = 1 To SubSet.Count
            SubSetStr = SubSetStr & SubSet.Item(j) & IIf(j = SubSet.Count, "", ", ")
        Next j
        SubSetStr = SubSetStr & "}"
        Debug.Print SubSetStr
    Next i
End Function

Function PowerSetCol(Arr As Variant) As Collection

    Dim n As Long, i As Long
    Dim Temp As New Collection, SubSet As Collection

    For i = 1 To 2 ^ (UBound(Arr) + 1) - 1
        Set SubSet = New Collection
        For n = 0 To UBound(Arr)
            If i And 2 ^ n Then SubSet.Add Arr(n)
        Next n
        Temp.Add SubSet
    Next i
    Set PowerSetCol = Temp
End Function

据称，通过索引访问集合比逐个枚举项更加繁琐。此外，正如@John Coleman所述，您不能直接使用join，但可以使用单行函数代替。

希望下面的代码是一种更优化的解决方案

Function Generator()
    Dim Arr() As Variant: Arr = Array(1, 2, 3, 4)
    Dim PSColl As Collection: Set PSColl = PowerSetColl(Arr)

    Dim Str As String, Coll As Collection, Item As Variant
    For Each Coll In PSColl
        Str = ""
        For Each Item In Coll
            Str = strJoin(", ", Str, CStr(Item))
        Next Item
        Debug.Print "{" & Str & "}"
    Next Coll
End Function

Function PowerSetColl(Arr As Variant) As Collection
    Dim Temp As New Collection, SubSet As Collection
    Dim n As Long, i As Long

    For i = 1 To 2 ^ (UBound(Arr) + 1) - 1
        Set SubSet = New Collection
        For n = 0 To UBound(Arr)
            If i And 2 ^ n Then SubSet.Add Arr(n)
        Next n
        Temp.Add SubSet
    Next i
    Set PowerSetColl = Temp
End Function

Function strJoin(Delimiter As String, Optional Str1 As String, Optional Str2 As String) As String
    strJoin = IIf(IsMissing(Str1) Or Str1 = "", Str2, IIf(IsMissing(Str2) Or Str2 = "", Str1, Str1 & Delimiter & Str2))
End Function

- Tragamor

---

集合对于这个任务是一个自然的选择(+1)。遗憾的是，没有一种内置方法可以将它们转换为数组，也没有一种方法可以直接在它们上使用Join()函数。 - John Coleman