有没有更有效的方法来计算阵列的功率集？

This is my current implementation using bits:

这是我目前使用位的实现：

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

Please ignore the abuse of Variants. Array_Push and Array_Size should be self-explanatory.

请忽略对Variants的滥用。 Array_Push和Array_Size应该是不言自明的。

Previously, I was generating a binary string for each combination, but that involved calling another function which wasn't very efficient.

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

Aside from using less Variants and moving external function calls inside, is there any way I can make this more efficient?

除了使用较少的Variants并在内部移动外部函数调用之外，有什么办法可以让它更高效吗？

EDIT: Here's a fully independent version.

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

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

And a test:

并测试：

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

2 个解决方案

#1

Since the number of subsets grows exponentially, no algorithm is truly efficient, although there is room for improvement in what you are doing:

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

ReDim Preserve, when used to extend an array by a single item, is inefficient since it involves creating a new array with 1 more space and then copying the old elements to the new array. It is better to pre-allocate enough space and then trim it down to size:

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

A test 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

#2

Using collections to build your sets is an option...

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

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

******* EDIT ********

*******编辑********

Apparently accessing collections through index is more intensive than enumerating through the items. Also; you can't use join directly as stated by @John Coleman but a single line function can be used in it's place.

显然通过索引访问集合比枚举项目更加密集。也;你不能像@John Coleman所说的那样直接使用join，但可以使用单行函数。

Hopefully the code below is a more optimal solution

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

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