[讨论]排列组合之最优算法

yijiboo

强啊 真是强 学习了

lby999

真是强 学习了

ubound

学习

sunya_0529

请教彭兄

前一段时间我也有了解过组合算法，资料上介绍得最多的是回溯和递归，这两种经典算法在解决此类问题上确实是很不错的思路。以前用Javascript写过一个另类的算法，在浏览器里测试的结果要比回溯和递归法快一点。

下面是这个另类算法的代码及思路，不知道为什么在Excel里速度比彭兄设计的两个算法慢多了，我猜是VB的字符串处理效率比较低下。不过我想这个算法可能有用其他技术实现的可能性，效率应该也可以有很大提升的，请彭兄指点一二，谢谢。

Sub yinshe()
 On Error Resume Next
 Dim i As Long, m%, n%, aa, str As String
 aa = Timer
 With Sheets("sheet1")
  m = .[A65536].End(xlUp)
  n = .[B1]
 End With
 str = Application.Rept("1", n) & Application.Rept("0", m - n) '生成模拟字符串
 Open "d:\peng.txt" For Output As #1
 Print #1, extract(str)
  Do
   If Right(str, 1) = 0 Then
    str = Left(str, InStrRev(str, "10") - 1) + Replace(Mid(str, InStrRev(str, "10")), "10", "01")
   ElseIf InStr(Mid(str, InStrRev(str, "10") + 2), "0") = 0 Then
    str = Left(str, InStrRev(str, "10") - 1) + Replace(Mid(str, InStrRev(str, "10")), "10", "01")
   Else
    str = Left(str, InStrRev(str, "10") - 1) + Replace(Mid(str, InStrRev(str, "10")), "10", "01")
    str = Left(str, InStrRev(str, "10")) & exchange(Mid(str, InStrRev(str, "10") + 1))
   End If
   Print #1, extract(str)
  Loop Until Mid(str, InStr(str, "1")) = Application.Rept("1", n)
 Close #1
 MsgBox "找到 " & Application.Combin(m, n) & " 个解! 花费" & Format(Timer - aa, "0.00" & "秒") & "保存在D:\peng.txt"
End Sub

Function extract(str As String) '提取“1”所在的位置信息
 Dim i%
 extract = ""
 For i = 1 To Len(str)
  If Mid(str, i, 1) = 1 Then
   extract = extract & i & " "
  End If
 Next
End Function

Function exchange(str As String)
 exchange = Mid(str, InStr(str, "1")) + Left(str, InStr(str, "1") - 1)
End Function

算法说明：
以7选4为例，共35组结果：

第一步，生成模拟字符串“1111000”，提取“1”在字符串中的位置就是“1 2 3 4”，即
1111000　1 2 3 4

第二步，从字符串右侧检索第一个“10”，找到后将其位置互换，模拟字符串变成“1110100”，提取“1”在字符串中的位置就是“1 2 3 5”
如此逐步替换，直到字符串最后一个字符不为“0”，即
1110100　1 2 3 5
1110010　1 2 3 6
1110001　1 2 3 7

第三步，当最后一个字符串为“1”时，首先执行第二步，即1101001，然后将最右侧所有连续的“1”插入到倒数第二“1”的后面，即
1101100　1 2 4 5

接下来重复第二步、第三步：
1101010  1 2 4 6
1101001  1 2 4 7
1100101
1100110  1 2 5 6
1100101  1 2 5 7
1100011  1 2 6 7
1010011
1011100  1 3 4 5
1011010  1 3 4 6
1011001  1 3 4 7
1010101
1010110  1 3 5 6
1010101  1 3 5 7
1010011  1 3 6 7
1001011
1001110  1 4 5 6
1001101  1 4 5 7
1001011  1 4 6 7
1000111  1 5 6 7
0100111
0111100  2 3 4 5
0111010  2 3 4 6
0111001  2 3 4 7
0110101
0110110  2 3 5 6
0110101  2 3 5 7
0110011  2 3 6 7
0101011
0101110  2 4 5 6
0101101  2 4 5 7
0101011  2 4 6 7
0100111  2 5 6 7
0010111
0011110  3 4 5 6
0011101  3 4 5 7
0011011  3 4 6 7
0010111  3 5 6 7

判断右侧4位全部为“1”的话，结束
0001111  4 5 6 7

[此贴子已经被作者于2007-12-6 16:18:39编辑过]

彭希仁

QUOTE:

以下是引用sunya_0529在2007-12-6 16:09:16的发言：

请教彭兄

前一段时间我也有了解过组合算法，资料上介绍得最多的是回溯和递归，这两种经典算法在解决此类问题上确实是很不错的思路。以前用Javascript写过一个另类的算法，在浏览器里测试的结果要比回溯和递归法快一点。

下面是这个另类算法的代码及思路，不知道为什么在Excel里速度比彭兄设计的两个算法慢多了，我猜是VB的字符串处理效率比较低下。不过我想这个算法可能有用其他技术实现的可能性，效率应该也可以有很大提升的，请彭兄指点一二，谢谢。

Sub yinshe()
 On Error Resume Next
 Dim i As Long, m%, n%, aa, str As String
 aa = Timer
 With Sheets("sheet1")
  m = .[A65536].End(xlUp)
  n = .[B1]
 End With
 str = Application.Rept("1", n) & Application.Rept("0", m - n) '生成模拟字符串
 Open "d:\peng.txt" For Output As #1
 Print #1, extract(str)
  Do
   If Right(str, 1) = 0 Then
    str = Left(str, InStrRev(str, "10") - 1) + Replace(Mid(str, InStrRev(str, "10")), "10", "01")
   ElseIf InStr(Mid(str, InStrRev(str, "10") + 2), "0") = 0 Then
    str = Left(str, InStrRev(str, "10") - 1) + Replace(Mid(str, InStrRev(str, "10")), "10", "01")
   Else
    str = Left(str, InStrRev(str, "10") - 1) + Replace(Mid(str, InStrRev(str, "10")), "10", "01")
    str = Left(str, InStrRev(str, "10")) & exchange(Mid(str, InStrRev(str, "10") + 1))
   End If
   Print #1, extract(str)
  Loop Until Mid(str, InStr(str, "1")) = Application.Rept("1", n)
 Close #1
 MsgBox "找到 " & Application.Combin(m, n) & " 个解! 花费" & Format(Timer - aa, "0.00" & "秒") & "保存在D:\peng.txt"
End Sub

Function extract(str As String) '提取“1”所在的位置信息
 Dim i%
 extract = ""
 For i = 1 To Len(str)
  If Mid(str, i, 1) = 1 Then
   extract = extract & i & " "
  End If
 Next
End Function

Function exchange(str As String)
 exchange = Mid(str, InStr(str, "1")) + Left(str, InStr(str, "1") - 1)
End Function

算法说明：
以7选4为例，共35组结果：

第一步，生成模拟字符串“1111000”，提取“1”在字符串中的位置就是“1 2 3 4”，即
1111000　1 2 3 4

第二步，从字符串右侧检索第一个“10”，找到后将其位置互换，模拟字符串变成“1110100”，提取“1”在字符串中的位置就是“1 2 3 5”
如此逐步替换，直到字符串最后一个字符不为“0”，即
1110100　1 2 3 5
1110010　1 2 3 6
1110001　1 2 3 7

第三步，当最后一个字符串为“1”时，首先执行第二步，即1101001，然后将最右侧所有连续的“1”插入到倒数第二“1”的后面，即
1101100　1 2 4 5

接下来重复第二步、第三步：
1101010  1 2 4 6
1101001  1 2 4 7
1100101
1100110  1 2 5 6
1100101  1 2 5 7
1100011  1 2 6 7
1010011
1011100  1 3 4 5
1011010  1 3 4 6
1011001  1 3 4 7
1010101
1010110  1 3 5 6
1010101  1 3 5 7
1010011  1 3 6 7
1001011
1001110  1 4 5 6
1001101  1 4 5 7
1001011  1 4 6 7
1000111  1 5 6 7
0100111
0111100  2 3 4 5
0111010  2 3 4 6
0111001  2 3 4 7
0110101
0110110  2 3 5 6
0110101  2 3 5 7
0110011  2 3 6 7
0101011
0101110  2 4 5 6
0101101  2 4 5 7
0101011  2 4 6 7
0100111  2 5 6 7
0010111
0011110  3 4 5 6
0011101  3 4 5 7
0011011  3 4 6 7
0010111  3 5 6 7

判断右侧4位全部为“1”的话，结束
0001111  4 5 6 7

你这种算法和我一般算法思路是一致.慢就慢在字附串处理上,

0101101  2 4 5 7
0101011  2 4 6 7

后面的2467

和前面的24是重复的,可利用上,这样就可以省去1半字附串处理时间.

彭希仁

  ReDim arr1(1 To z + 1) As Long   '存地址

1 2 4 6
里面存储的就是这样的值.

    ReDim arr2(1 To z + 1)   '存组合

sunya_0529

多谢指教，数组的存取确实比字符串操作的速度快多了，获益匪浅

[此贴子已经被作者于2007-12-7 16:37:40编辑过]

ysheung02

首先先谢谢了

下载用了之后 好象没有全排列

比如 6选3  输出的TXT里只有 123 124 125 126。。。。。。

而没有132 142 152 162 143 这些

兰州人

好好研究一下。

彭希仁

Public ar(1 To 65536, 1 To 1), r As Long, c As Long

Sub pengxi()
    aa = Timer
    Dim x%
    Dim i%
    Dim j%
    Dim jj As Long
    a = [A65536].End(xlUp).Row + 1
    arr = Range("A1:A" & a)
    c = 1
    r = 0
    z = Cells(1, 2)
    ReDim arr1(1 To z + 1) As Long   '存地址
    ReDim arr2(1 To z + 1)   '存组合
    '   ReDim ar(1 To 65536, 1 To 1)
    For i = z To 1 Step -1    '初始化
        arr1(i) = i
        arr2(i) = arr2(i + 1) & " " & arr(i, 1)
    Next i
    arr1(z + 1) = 1000
    Sheets.Add
    Do
        r = r + 1
        ar(r, c) = arr2(1)
        If r = 65536 Then
            r = 0
            Cells(1, c).Resize(65536, 1) = ar
            c = c + 1
        End If

        For i = 1 To z
            If arr1(i + 1) - arr1(i) > 1 Then Exit For
        Next i

        arr1(i) = arr1(i) + 1
        arr2(i) = arr2(i + 1) & " " & arr(arr1(i), 1)

        For j = i - 1 To 1 Step -1
            arr1(j) = j
            arr2(j) = arr2(j + 1) & " " & arr(j, 1)
        Next j
    Loop While arr1(z) < a
    Cells(1, c).Resize(r, 1) = ar
    MsgBox "找到 " & (c - 1) * 65536 + r & " 个解! 花费" & Timer - aa & "秒"
End Sub
'递归算法

Sub peng()
Dim z As Long
    aa = Timer
    r = 0
    c = 1
    z = Cells(1, 2)
    arr = Range("A1:A" & [A65536].End(xlUp).Row)
    Sheets.Add
    Call xi("", arr, 1, 0, z)
    Cells(1, c).Resize(r, 1) = ar
    MsgBox "找到 " & (c - 1) * 65536 + r & " 个解! 花费" & Timer - aa & "秒"
End Sub

Sub xi(a, arr, x As Long, y As Long, z As Long)
    If y = z Then
        r = r + 1
        ar(r, c) = a
        If r = 65536 Then
            r = 0
            Cells(1, c + 1).Resize(65536, 1) = ar
            c = c + 1
        End If
        Exit Sub
    End If
    If x = UBound(arr) + 1 Then Exit Sub
    If y + UBound(arr) - x + 1 < z Then Exit Sub
    Call xi(a & " " & arr(x, 1), arr, x + 1, y + 1, z)  '字附串和数字的处理速度是相差很大的
    Call xi(a, arr, x + 1, y, z)
End Sub

从工作表输出