字符串数组特定的所有的组合

我在实际工作中用VB开发遇到如下算法问题, 可能是离开学校多年的缘故, 现在早就把大学的算法和数据结构忘得差不多了,请大家帮忙解答:

现有一个字符串数组,其中数组中元素各不相同,且已按升序顺序排列好(SQL语言中的ASC排序),
要求取得该数组满足以下条件的所有的组合,

条件1, 数组的正排和反排只能出现一次, 还是举个例子来说明比较容易明白,
       假设有个字符数组,有3个元素,分别为'A', 'B' 和'C'(各不相同,已排升序排好),
       如果要列出所有的组合,应该有3的阶乘(3!)共6种不同的组合:
       ABC,ACB,BAC,BCA,CAB,CBA
       现要求ABC和CBA只能出现其中一个, ACB和BCA, CAB和BAC同样只能出现其一个,
       可能最终的结果是ABC, ACB 与 CAB

条件2, 不能使用递归,
       因为如果数组的元素个数稍大的话,就会产生非常大的数据了,
       假如数组的元素个数为10, 就会产生10!/2 = 1814400种组合,存放这么大的组合,内存就可能会溢出了,
       实际工作中要求每得出一个组合就把该组合作为一个参数调用一个方法得到一个值,
       通过比较这个值来取得最佳的组合方式,

看来有点复杂,希望有兴趣的朋友帮忙一起想想! 谢谢! --------------------编程问答-------------------- dim StrArry() as string '假设这个就是那个数组
dim ResultArry() as string'假设这个就是结果，我把它存数组里了
k=0
for i=0 to (ubound(StrArry)/2 +1)
    for j=i to ubound(StrArry）
      ResultArry(k) =ResultArry(k) & StrArry(j)
    next
    for j=0 to i
     ResultArry(k) =ResultArry(k) & StrArry(j)
    next
next
--------------------编程问答-------------------- 好像可以，有点晕！ --------------------编程问答-------------------- To 小雨,
谢谢你的响应,但还是不行,以你方法运行字符串数组"A","B","C"会返回一个字符串"ABCABCABCABC"
四组ABC,不是我想要的结果, --------------------编程问答--------------------

引用楼主 liangqinglin 的回复:

条件2, 不能使用递归

为什么不能用递归？我比较喜欢用递归。 --------------------编程问答--------------------



Option Explicit



'全排列个数

Function GetPermNum(ByVal M As Long) As Long

    Dim i As Long

    For i = M - 1 To 1 Step -1

        M = M * i

    Next

    GetPermNum = M

End Function



'进位

Sub PermCarry(Index() As Long, Length As Long)

    

    Dim bolExist() As Boolean

    Dim Idx As Long

    Dim i As Long

    

    ReDim bolExist(Length)

    For i = 0 To Length

        bolExist(Index(i)) = True

    Next

    

    Idx = Length

    Do

        bolExist(Index(Idx)) = False

        Index(Idx) = Index(Idx) + 1

        If Index(Idx) > Length Then

            bolExist(Index(Idx) - 1) = False

            Index(Idx) = 0

            Idx = Idx - 1

        Else

            If Not bolExist(Index(Idx)) Then

                bolExist(Index(Idx)) = True

                Exit Do

            Else

                Index(Idx) = 0

                Idx = Idx - 1

            End If

        End If

    Loop

    Do While Idx < Length

        Idx = Idx + 1

        Do While bolExist(Index(Idx))

            Index(Idx) = Index(Idx) + 1

        Loop

        bolExist(Index(Idx)) = True

    Loop

    

End Sub



Function GetResultItem(arr As Variant, Index() As Long) As Variant

    Dim i As Long

    ReDim tmp(UBound(Index))

    

    For i = 0 To UBound(tmp)

        tmp(i) = arr(Index(i))

    Next

    GetResultItem = Join(tmp)

End Function



Sub GetResult(arr As Variant, Result As Variant)

    

    Dim i As Long

    Dim n As Long, Length As Long

    Dim Index() As Long

    

    Length = UBound(arr)

    ReDim Index(Length)

    For i = 0 To Length

        Index(i) = i

    Next

    

    n = GetPermNum(Length + 1) / 2 - 1

    ReDim Result(n)

    

    For i = 0 To n

        Result(i) = GetResultItem(arr, Index)

        PermCarry Index, Length

        'DoEvents

    Next

    

End Sub





Private Sub Command1_Click()

    Dim arr, Result

    

    arr = Array("A", "B", "C")

    GetResult arr, Result

    Debug.Print Join(Result, vbCrLf)

End Sub

--------------------编程问答-------------------- 上面有问题...想想 --------------------编程问答-------------------- 写的比较累，这个机器的F8键居然坏了...

用了字典判断重复，筧10位我的机器死机了，7位8位还行，算个思路，代码要优化，算抛砖引玉吧...





'全排列个数

Function GetPermNum(ByVal M As Long) As Long

    Dim i As Long

    For i = M - 1 To 1 Step -1

        M = M * i

    Next

    GetPermNum = M

End Function



'进位

Sub PermCarry(Index() As Long, Length As Long)

    

    Dim bolExist() As Boolean

    Dim Idx As Long

    Dim i As Long

    

    ReDim bolExist(Length)

    For i = 0 To Length

        bolExist(Index(i)) = True

    Next

    

    Idx = Length

    Do

        bolExist(Index(Idx)) = False

100:

        Index(Idx) = Index(Idx) + 1

        If Index(Idx) > Length Then

            Index(Idx) = 0

            Idx = Idx - 1

        Else

            If Not bolExist(Index(Idx)) Then

                bolExist(Index(Idx)) = True

                Exit Do

            Else

                GoTo 100

            End If

        End If

    Loop

    Do While Idx < Length

        Idx = Idx + 1

        Do While bolExist(Index(Idx))

            Index(Idx) = Index(Idx) + 1

        Loop

        bolExist(Index(Idx)) = True

    Loop

    

End Sub



Function GetResultItem(arr As Variant, Index() As Long, dic As Dictionary, res As String) As Boolean

    

    Dim i As Long

    ReDim tmp(UBound(Index))

    

    For i = 0 To UBound(tmp)

        tmp(i) = arr(Index(i))

    Next

    res = Join(tmp)

    If dic.Exists(StrReverse(res)) Then

        GetResultItem = False

    Else

        dic.Add res, 0

        GetResultItem = True

    End If

End Function





Sub GetResult(arr As Variant, Result As Variant)

    

    Dim i As Long

    Dim n As Long, Length As Long

    Dim Index() As Long

    Dim Idx As Long

    Dim dic As Dictionary

    Dim res As String

    

    Length = UBound(arr)

    ReDim Index(Length)

    For i = 0 To Length

        Index(i) = i

    Next

    

    n = GetPermNum(Length + 1)

    ReDim Result(n \ 2 - 1)

    

    Set dic = New Dictionary

    GetResultItem arr, Index, dic, res

    Result(0) = res

    For i = 1 To n - 1

        PermCarry Index, Length

        If GetResultItem(arr, Index, dic, res) Then

            Idx = Idx + 1

            Result(Idx) = res

        End If

        'DoEvents

    Next

    Set dic = Nothing

End Sub





Private Sub Command1_Click()

    Dim arr, Result

    

    arr = Array("A", "B", "C", "D")

    GetResult arr, Result

    Debug.Print Join(Result, vbCrLf)

    

End Sub

--------------------编程问答-------------------- To vbman2003:
Thanks a lot! 不胜感激！我先研读一下你的代码， --------------------编程问答-------------------- 判断重复很简单：
既然用于排列的素各不相同，那么所有的排列都是不同的。
对任意一个排列字符串 S1，反转后得到字符串 S2，那么 {S1, S2} 就是一对正排和反排，我们只要取其中一个（比如字符串值小的一个）就得到结果了。
伪码如下

Dim S1 As String, S2 As String

For ...

    S1 = 生成下个排列()

    S2 = StrReverse()

    If S1 < S2 Then 输出结果(S1)

Next

举例来说：
当生成排列 S1 = "ACB" 时，S2 = "BCA"，S1 < S2，则输出 "ACB"
当生成排列 S1 = "BCA" 时，S2 = "ACB"，S1 > S2，则不输出
这样正反排列 {"ACB", "BCA"} 只输出了 "ACB" --------------------编程问答-------------------- 这个问题我想问来着，希望哪位高人提供更有效的方法。
--------------------编程问答--------------------

引用 9 楼 tiger_zhao 的回复:

判断重复很简单：
既然用于排列的素各不相同，那么所有的排列都是不同的。
对任意一个排列字符串 S1，反转后得到字符串 S2，那么 {S1, S2} 就是一对正排和反排，我们只要取其中一个（比如字符串值小的一个）就得到结果了。
伪码如下
VB codeDim S1AsString, S2AsStringFor ...
S1= 生成下个排列()
S2=StrReverse()If S1< S2Then 输出结果(S1)Next
举例来说：
当生成排列 S1 = "ACB" 时，S2 = "BCA"，S1 < S2，则输出 "ACB"
当生成排列 S1 = "BCA" 时，S2 = "ACB"，S1 > S2，则不输出
这样正反排列 {"ACB", "BCA"} 只输出了 "ACB"

好方法...
--------------------编程问答-------------------- 按Tiger_Zhao的方法简单改下上面的代码:



Option Explicit



'全排列个数

Function GetPermNum(ByVal M As Long) As Long

    Dim i As Long

    For i = M - 1 To 1 Step -1

        M = M * i

    Next

    GetPermNum = M

End Function



'进位

Sub PermCarry(Index() As Long, Length As Long)

    

    Dim bolExist() As Boolean

    Dim Idx As Long

    Dim i As Long

    

    ReDim bolExist(Length)

    For i = 0 To Length

        bolExist(Index(i)) = True

    Next

    

    Idx = Length

    Do

        bolExist(Index(Idx)) = False

100:

        Index(Idx) = Index(Idx) + 1

        If Index(Idx) > Length Then

            Index(Idx) = 0

            Idx = Idx - 1

        Else

            If Not bolExist(Index(Idx)) Then

                bolExist(Index(Idx)) = True

                Exit Do

            Else

                GoTo 100

            End If

        End If

    Loop

    Do While Idx < Length

        Idx = Idx + 1

        Do While bolExist(Index(Idx))

            Index(Idx) = Index(Idx) + 1

        Loop

        bolExist(Index(Idx)) = True

    Loop

    

End Sub



Function GetResultItem(arr As Variant, Index() As Long, res As String) As Boolean

    

    Dim i As Long

    ReDim tmp(UBound(Index))

    

    For i = 0 To UBound(tmp)

        tmp(i) = arr(Index(i))

    Next

    res = Join(tmp)

    GetResultItem = StrReverse(res) > res



End Function





Sub GetResult(arr As Variant, Result As Variant)

    

    Dim i As Long

    Dim n As Long, Length As Long

    Dim Index() As Long

    Dim Idx As Long

    Dim res As String

    

    Length = UBound(arr)

    ReDim Index(Length)

    For i = 0 To Length

        Index(i) = i

    Next

    

    n = GetPermNum(Length + 1)

    ReDim Result(n \ 2 - 1)

    GetResultItem arr, Index, res

    Result(0) = res

    For i = 1 To n - 1

        PermCarry Index, Length

        If GetResultItem(arr, Index, res) Then

            Idx = Idx + 1

            Result(Idx) = res

        End If

        'DoEvents

    Next

    

End Sub





Private Sub Command1_Click()

    Dim arr, Result

    

    arr = Array("A", "B", "C", "D")

    GetResult arr, Result

    Debug.Print Join(Result, vbCrLf)

    

End Sub

--------------------编程问答-------------------- 好象干脆去PermCarry中用老鸟的方法判断更好....今天太忙,有空想想... --------------------编程问答-------------------- 这个帖子值得推荐 --------------------编程问答-------------------- 再次感谢大家跟贴,VBman2003的方法是可以得到正确的结果,但同时需要指出的是程序并没有节省了时间,
具体就是假设一个数组有4个元素,所有的组合是4!=24,VBMan2003是遍历的所有的元素,而只取其中一半的元素,理论上更好方法是只需遍历一半,即4!/2 = 12次就能得出结果, --------------------编程问答-------------------- 因为不同元素的所有组合是非常庞大的,如10!=3628800,再大一点就更不能想象了,如果若能找到最优的结果,会对整个算法节省足足一半的时间的, --------------------编程问答-------------------- VBMan2003所提出的方案有点很好的地方就是每一次遍历的结果可能存放到一个临时的数组里,因为在实际业务中,需要对每次遍历的结果进行某些验证,从而决定是否进行下一次遍历, --------------------编程问答-------------------- 我是来学习的 --------------------编程问答-------------------- 你还是先担心结果数组的空间吧：
12! = 479001600
一半 = 239500800
12 个字符 BStr 需要 30 字节，再加 4 字节字符串指针（数组成员）共 34 字节
总计 = 239500800 * 34 = 8143027200 > 4G --------------------编程问答-------------------- 老鸟算漏了。实际上，不需要存储真正的字符串，而只需其序号的合并串。如果是 12 个元素的话，4-bit足矣。

另外，也不必一次全部算出。可以将各个循环计数器的值存储起来，表示一种排列，就可以得到当前的结果。之多在存一个结果最佳值，供比较更新。 --------------------编程问答-------------------- 看17楼，楼主正在期待数组呢。 --------------------编程问答-------------------- 楼主16楼的想法要颠覆我上面算法的整个思路....
我保存为数组只是为了整体输出看结果,按实际需要,你可以在GetResultItem中直接一个个输出处理

下面代码稍稍优化了一下上面的计算,看似用了一半的循环,实际上都放在carry这个过程中去了(包含了重复判断),整体思路中换汤没换药:



Option Explicit



'全排列个数

Function GetPermNum(ByVal M As Long) As Long

    Dim i As Long

    For i = M - 1 To 1 Step -1

        M = M * i

    Next

    GetPermNum = M

End Function



'进位

Sub PermCarry(Index() As Long, Length As Long)



100:

    Dim bolExist() As Boolean

    Dim Idx As Long

    Dim i As Long

    

    ReDim bolExist(Length)

    For i = 0 To Length - 1

        bolExist(Index(i)) = True

    Next

    

    Idx = Length

    Do

        Index(Idx) = Index(Idx) + 1

        If Index(Idx) > Length Then

            Idx = Idx - 1

            bolExist(Index(Idx)) = False

        Else

            If Not bolExist(Index(Idx)) Then

                bolExist(Index(Idx)) = True

                Exit Do

            End If

        End If

    Loop

    Do While Idx < Length

        Idx = Idx + 1

        Index(Idx) = 0

        Do While bolExist(Index(Idx))

            Index(Idx) = Index(Idx) + 1

        Loop

        bolExist(Index(Idx)) = True

    Loop

    If ((Index(Length) - 1) < Index(0)) Then GoTo 100

   

End Sub



Function GetResultItem(arr As Variant, Index() As Long) As String

    

    Dim i As Long

    ReDim tmp(UBound(Index))

    For i = 0 To UBound(tmp)

        tmp(i) = arr(Index(i))

    Next

    GetResultItem = Join(tmp)

    

End Function





Sub GetResult(arr As Variant, Result As Variant)

    

    Dim i As Long

    Dim n As Long, Length As Long

    Dim Index() As Long

    

    Length = UBound(arr)

    ReDim Index(Length)

    For i = 0 To Length

        Index(i) = i

    Next

    

    n = GetPermNum(Length + 1) \ 2 - 1

    ReDim Result(n)

    

    Result(0) = GetResultItem(arr, Index)

    For i = 1 To n

        PermCarry Index, Length

        Result(i) = GetResultItem(arr, Index)

        'DoEvents

    Next

    

End Sub





Private Sub Command1_Click()

    

    Dim arr, Result

    

    arr = Array("A", "B", "C", "D", "E")

    GetResult arr, Result

    Debug.Print Join(Result, vbCrLf)

    

End Sub

--------------------编程问答-------------------- 如果数据不变还是建立索引吧 --------------------编程问答-------------------- 开了一夜空调，闷的慌，关了空调又热的睡不着...突然想到这个问题，干脆起来优化一下：



Option Explicit



'全排列个数

Function GetPermNum(ByVal M As Long) As Long

    Dim i As Long

    For i = M - 1 To 1 Step -1

        M = M * i

    Next

    GetPermNum = M

End Function



'进位

Sub PermCarry(Index() As Long, Length As Long, bolExist() As Boolean)

    'Index:要排列的数组的下标，Length数组最大下标，bolExist标志当前使用的下标

    Dim Idx As Long

    Do

        Idx = Length

        bolExist(Index(Idx)) = False

        Do

            Index(Idx) = Index(Idx) + 1

            If Index(Idx) > Length Then

                Idx = Idx - 1

                bolExist(Index(Idx)) = False

            Else

                If Not bolExist(Index(Idx)) Then

                    bolExist(Index(Idx)) = True

                    Exit Do

                End If

            End If

        Loop

        Do While Idx < Length

            Idx = Idx + 1

            Index(Idx) = 0

            Do While bolExist(Index(Idx))

                Index(Idx) = Index(Idx) + 1

            Loop

            bolExist(Index(Idx)) = True

        Loop

    Loop While ((Index(Length) - 1) < Index(0))

   

End Sub



'输出单个排列的结果

Function GetResultItem(arr As Variant, Index() As Long) As String

    

    Dim i As Long

    ReDim tmp(UBound(Index))

    For i = 0 To UBound(tmp)

        tmp(i) = arr(Index(i))

    Next

    GetResultItem = Join(tmp)

    

End Function



Sub GetResult(arr As Variant, Result As Variant)

    

    Dim i As Long

    Dim n As Long, Length As Long

    Dim Index() As Long

    Dim bolExist() As Boolean

    

    Length = UBound(arr)

    ReDim Index(Length)

    ReDim bolExist(Length)

    For i = 0 To Length

        Index(i) = i

        bolExist(i) = True

    Next

    

    n = GetPermNum(Length + 1) \ 2 - 1

    ReDim Result(n)

    Result(0) = GetResultItem(arr, Index)

    For i = 1 To n

        PermCarry Index, Length, bolExist

        Result(i) = GetResultItem(arr, Index)

        'DoEvents

    Next

    

End Sub





Private Sub Command1_Click()

    

    Dim arr, Result

    arr = Array("A", "B", "C", "D", "E")

    GetResult arr, Result

    Debug.Print Join(Result, vbCrLf)

    

End Sub

我这个思路只能这个效果了，思路就比如5个数全排列，若循环的话就是从12345-54321，carry过程就是逢5进1去掉重复的值......我觉得楼主的想法理想化了，一半循环也是要历遍，节省一半时间万不可能的吧... --------------------编程问答-------------------- 纠下一上面说的,这个算法没有完全遍历.... --------------------编程问答-------------------- 楼主的想法是否不太对头，如果仅仅是比较值的话，根本不用判断abc与cba，如果你的估值函数是F(),你只要注意写函数的时候，让F("ABC")=F("CBA")，那么就简单遍历所有组合，用比较法就可以得到最佳值。

补充：VB ,  基础类