求助!穷举!

hainanzlt99 2021-05-06 03:20:08


使用vb,命令按钮源码!
...全文
1964 点赞 收藏 30
写回复
30 条回复
milaoshu1020 05月10日
上一个代码i,j没有考虑0-9999的范围,应该增加范围限制: 增加限制之后的效果是大部分算例一分钟之内能出结果,而且解不会超限; 如有问题欢迎指出;

Option Explicit
 
Private Sub cmdStartCombine_Click()
    TextI = ""
    TextJ = ""
    TextK = ""
    TextResult = ""
     
    Dim a As Long
    a = TextA
     
    Dim b As Long
    b = TextB
     
    Dim c As Long
    c = TextC
     
    Dim d As Long
    d = TextD
     
    Dim datStartTime As Date
    datStartTime = Now
    
    ' 这三个是条件判断,根据三个公式变换而来,不符合任何一项都没有结果;
    If d * a < 93 And d * b < 930 And d * c < 9000 Then
        Dim i As Long
        For i = 0 To 9999
            ' 计算剩余时间;
            Dim datNowTime As Date
            datNowTime = Now
            
            Dim lngSecondUsed As Long
            lngSecondUsed = DateDiff("s", datStartTime, datNowTime)
            
            Dim lngSecondTotal As Long
            lngSecondTotal = lngSecondUsed * 10001 \ (i + 1)
            
            Dim lngSecondRemain As Long
            lngSecondRemain = lngSecondTotal - lngSecondUsed
            
            Dim intHours As Integer
            intHours = lngSecondRemain \ 3600
            
            Dim intMinutes As Integer
            intMinutes = lngSecondRemain \ 60 Mod 60
            
            Dim intSeconds As Integer
            intSeconds = lngSecondRemain Mod 60
            
            TextResult = i & " 剩余时间: " & intHours & ":" & intMinutes & ":" & intSeconds
            
            Dim lngLastSecondUsed As Long
            If lngSecondUsed > lngLastSecondUsed Then
                lngLastSecondUsed = lngSecondUsed
                
                ' 判断是否界面已退出;
                If Not Me.Visible Then
                    MsgBox "计算中断!"
                    Unload Me
                    Exit Sub
                End If
                    
                DoEvents
            End If
            
            ' 在i已确定,设k=0的情况下,用前两个公式计算j的范围;
            Dim jmax As Long
            jmax = (93 - d * a) * i / (d * b) ' 公式1忽略k,变形
             
            Dim jmin As Long
            jmin = d * a * i / (930 - d * b) ' 公式2忽略k,变形
            
            Dim j As Long
            For j = IIf(jmin < 0, 0, jmin) To IIf(jmax > 9999, 9999, jmax)
                ' 在i,j已经确定的情况下,用三个公式确定k值的范围;
                Dim kmax1 As Long ' 公式1变形
                kmax1 = (93 * i - d * a * i - d * b * j) / (d * c)
                
                Dim kmax2 As Long ' 公式2变形
                kmax2 = (930 * j - d * a * i - d * b * j) / (d * c)
    
                Dim kmax As Long
                kmax = IIf(kmax1 < kmax2, kmax1, kmax2)
                
                Dim kmin As Long ' 公式3变形
                kmin = (d * a * i + d * b * j) / (9000 - d * c)
                
                Dim k As Long
                For k = IIf(kmin < 0, 0, kmin) To IIf(kmax > 9999, 9999, kmax)
                    Dim temp As Long
                    temp = d * (a * i + b * j + c * k)
                     
                    If 93 * i > temp And 930 * j > temp And 9000 * k > temp Then
                        TextI = i
                        TextJ = j
                        TextK = k
                        TextResult = "组合完成."
                        Exit Sub
                    End If
                Next
            Next
            
        Next
    End If
    
    TextResult = "没有这种组合!"
     
End Sub
下载地址: 链接:https://pan.baidu.com/s/1I_t1f5vfY8xxOyHQhM7CQA 提取码:jfoo 运行示例:
回复 点赞
对的 skr skr skr skr
回复 点赞
milaoshu1020 05月09日
经过思考,我尝试通过j,k的取值范围优化了一下代码; 通过三个公式变形可以得到j,k的取值范围: 93*i>d*(a*i+b*j+c*k) 93i>dai+dbj 93i-dai>dbj j<(93-da)i/db jmax=(93-d*a)*i/(d*b) 93i>dai+dbj+dck dck<93i-dai-dbj k<(93i-dai-dbj)/dc kmax1=(93*i-d*a*i-d*b*j)/(d*c) 930*j>d*(a*i+b*j+c*k) 930j>dai+dbj 930j-dbj>dai j(930-db)>dai j>dai/(930-db) jmin=d*a*i/(930-d*b) 930j>dai+dbj+dck dck<930j-dai-dbj k<(930j-dai-dbj)/dc kmax2=(930*j-d*a*i-d*b*j)/(d*c) 9000*k>d*(a*i+b*j+c*k) 9000k>dai+dbj+dck 9000k-dck>dai+dbj (9000-dc)k>dai+dbj k>(dai+dbj)/(9000-dc) kmin=(d*a*i+d*b*j)/(9000-d*c) 这三个条件是不等式成立的必要非充分条件: da<93 db<930 dc<9000 以下是经过优化的穷举算法,既保证了正确性,速度也有所提升(如该算法有错误或者有更好的算法欢迎指出):
Option Explicit
 
Private Sub cmdStartCombine_Click()
    TextI = ""
    TextJ = ""
    TextK = ""
    TextResult = ""
     
    Dim a As Long
    a = TextA
     
    Dim b As Long
    b = TextB
     
    Dim c As Long
    c = TextC
     
    Dim d As Long
    d = TextD
     
    Dim datStartTime As Date
    datStartTime = Now
    
    ' 这三个是条件判断,根据三个公式变换而来,不符合任何一项都没有结果;
    If d * a < 93 And d * b < 930 And d * c < 9000 Then
        Dim i As Long
        For i = 0 To 10000
            DoEvents
             
            ' 在i已确定,设k=0的情况下,用前两个公式计算j的范围;
            Dim jmax As Long
            jmax = (93 - d * a) * i / (d * b) ' 公式1忽略k,变形
             
            Dim jmin As Long
            jmin = d * a * i / (930 - d * b) ' 公式2忽略k,变形
            
            Dim j As Long
            For j = jmin To jmax
                ' 在i,j已经确定的情况下,用三个公式确定k值的范围;
                Dim kmax1 As Long ' 公式1变形
                kmax1 = (93 * i - d * a * i - d * b * j) / (d * c)
                
                Dim kmax2 As Long ' 公式2变形
                kmax2 = (930 * j - d * a * i - d * b * j) / (d * c)
    
                Dim kmax As Long
                kmax = IIf(kmax1 < kmax2, kmax1, kmax2)
                
                Dim kmin As Long ' 公式3变形
                kmin = (d * a * i + d * b * j) / (9000 - d * c)
                
                Dim k As Long
                For k = kmin To kmax
                    Dim temp As Long
                    temp = d * (a * i + b * j + c * k)
                     
                    If 93 * i > temp And 930 * j > temp And 9000 * k > temp Then
                        TextI = i
                        TextJ = j
                        TextK = k
                        TextResult = "组合完成."
                        Exit Sub
                    End If
                Next
            Next
            
            Dim datNowTime As Date
            datNowTime = Now
            
            Dim lngSecondUsed As Long
            lngSecondUsed = DateDiff("s", datStartTime, datNowTime)
            
            Dim lngSecondTotal As Long
            lngSecondTotal = lngSecondUsed * 10001 \ (i + 1)
            
            Dim lngSecondRemain As Long
            lngSecondRemain = lngSecondTotal - lngSecondUsed
            
            Dim intHours As Integer
            intHours = lngSecondRemain \ 3600
            
            Dim intMinutes As Integer
            intMinutes = lngSecondRemain \ 60 Mod 60
            
            Dim intSeconds As Integer
            intSeconds = lngSecondRemain Mod 60
            
            TextResult = i & " 剩余时间: " & intHours & ":" & intMinutes & ":" & intSeconds
            
            If Not Me.Visible Then
                MsgBox "计算中断!"
                Unload Me
                Exit Sub
            End If
        Next
    End If
    
    TextResult = "没有这种组合!"
     
End Sub
下载地址: 链接:https://pan.baidu.com/s/1vXHYNAF_b0ISqiAhJBTONQ 提取码:xq3a 运行示例:
回复 点赞
milaoshu1020 05月09日
刚才推导的不够严谨,这里更正/补充一下: 93*i>d*(a*i+b*j+c*k) 93i>dai+dbj+dck 93i-dai-dck>dbj j<(93i-dai-dck)/db 可以看到,当k>0时j的取值范围比k=0时更小,所以k=0时j的范围包含了k>0时j的范围; 由此可知k=0的j是k>0时的j的超集,设k=0不会丢失j的有效取值范围; j<(93-da)i/db jmax=(93-d*a)*i/(d*b) 93i>dai+dbj+dck dck<93i-dai-dbj k<(93i-dai-dbj)/dc kmax1=(93*i-d*a*i-d*b*j)/(d*c) 930*j>d*(a*i+b*j+c*k) 930j>dai+dbj+dck 930j-dbj>dai+dck j(930-db)>dai+dck j>(dai+dck)/(930-db) 可以看到当k>0时j的取值范围比k=0时更小,所以k=0时j的范围包含了k>0时j的范围; 由此可知k=0的j是k>0时的j的超集,设k=0不会丢失j的有效取值; j>dai/(930-db) jmin=d*a*i/(930-d*b) 930j>dai+dbj+dck dck<930j-dai-dbj k<(930j-dai-dbj)/dc kmax2=(930*j-d*a*i-d*b*j)/(d*c) 9000*k>d*(a*i+b*j+c*k) 9000k>dai+dbj+dck 9000k-dck>dai+dbj (9000-dc)k>dai+dbj k>(dai+dbj)/(9000-dc) kmin=(d*a*i+d*b*j)/(9000-d*c)
回复 点赞
sonic_andy 05月09日
不错,顶一下;
回复 点赞
hainanzlt99 05月08日
引用 18 楼 脆皮大雪糕 的回复:
[quote=引用 17 楼 hainanzlt99 的回复:]速度好慢,每次运行都要2个小时!
用15楼的代码,最慢也就10分钟[/quote] 15楼代码没效!输入a27 b81 c54 d=2没结果。正常i=7 j=1 k=1能通过!
回复 点赞
milaoshu1020 05月08日
我自己找到了一个算例,推翻了我的这个算法,你们也可以算算看: a=1,b=1,c=4393,d=2; 看来还是穷尽枚举更稳妥;
回复 点赞
阿麦 05月08日
为什么要用穷举这种笨办法呢?这明明是一道几何题
回复 点赞
milaoshu1020 05月08日
根据大家的建议,我修改了一下代码,如有不对也请指出:
Option Explicit
 
Private Sub cmdStartCombine_Click()
    TextI = ""
    TextJ = ""
    TextK = ""
    TextResult = ""
     
    Dim a As Long
    a = TextA
     
    Dim b As Long
    b = TextB
     
    Dim c As Long
    c = TextC
     
    Dim d As Long
    d = TextD
     
    Dim i As Long
    For i = 1 To 9999
        DoEvents
        
        Dim j As Long
        For j = 1 To 9999
            Dim k As Long
            ' 为什么k从1到1,因为画截面图可以看出,如果k>1成立的话,k=1也必定成立,因为f(k)=9000*k
            ' 这个平面已经基本上立起来了,与k轴连成的棱锥体已经覆盖了指定范围内所有的i,j整数点,
            ' 那么k就没有必要循环那么多次了;
            For k = 1 To 1
                Dim temp As Long
                temp = d * (a * i + b * j + c * k)
                 
                If 93 * i > temp And 930 * j > temp And 9000 * k > temp Then
                    TextI = i
                    TextJ = j
                    TextK = k
                    TextResult = "组合完成."
                    Exit Sub
                End If
            Next
        Next
    Next
     
    TextResult = "没有这种组合!"
     
End Sub
这样修改以后,速度快了很多;
回复 点赞
舉杯邀明月 05月08日
引用 6 楼 milaoshu1020 的回复:
楼上可能没搞清楚什么叫穷举,不过如果你有更好的算法可以贴出来;

为了计算剩余时间,我又修改了一下代码:
……………………

经过对比,我发现如果程序中有大量循环,编译出来的程序运行速度是IDE环境中程序运行速度的将近9倍;
所以,编译出来的程序只需要运行1个多小时就能全部遍历完了;

“穷举”并不是一定要无条件的把所有组合都要“尝试一下”,
根据“限定条件”,合理的“砍掉肯定不可能的范围”、只尝试其它“有可能”的范围,
 也照样是属于“穷举”的范畴。

无条件的尝试全部的组合而不管它“是否有意义”,是最低效的处理方式。
当然,这种“最原始”算法是简单、最容易实现的代码,
首先实现这个“原始逻辑”,再在这个基础上进行算法优化,也是很好的办法。

正如你最初说的,“无结果的运行时间比较长,根据电脑配置情况可能要几个小时到几天”
就是“无条件穷举”的后果,而采用合理的“剪枝”配合其它技巧,
 就能实现“很短的时间”就排查完毕了。

回复 点赞
舉杯邀明月 05月08日
引用 23 楼 hainanzlt99 的回复:
[quote=引用 18 楼 脆皮大雪糕 的回复:][quote=引用 17 楼 hainanzlt99 的回复:]速度好慢,每次运行都要2个小时!


用15楼的代码,最慢也就10分钟[/quote]

15楼代码没效!输入a27 b81 c54 d=2没结果。正常i=7 j=1 k=1能通过![/quote]
你下载的不是15楼的代码吧!
我试了 脆皮大雪糕 在15楼贴的代码,没有问题的。
a=27, b=81, c=54, d=2
这组数,用我的代码会列出很多组合结果。

大家可以试试这组数据:
a=40, b=42, c=205, d=2

得出结果要运行多久?
(唯一结果:90,9,1)

还有一个“没有结果”的极限测试:
a=1, b=1, c=5000, d=2
(当然这只是一组简单的例子,类似的组合多得很)
上面不同的代码得出“没有这种组合”需要多久?
回复 点赞
舉杯邀明月 05月08日
借用米老鼠的程序界面,把我的代码写一下。


这段代码,可以记录多个符合的组合结果(当然“实在太多”时,只记录一部分)
并且,运行速度很快。
下载我的工程(后面有链接),编译后运行exe,效果尤为明显。
当然,“输入数据”的合法也,我也一样没有处理,
  因此在“开始组合”前一定要把a、b、c、d这四个参数输入合法数值!

代码如下:
Option Explicit

Private Declare Function GetTickCount Lib "Kernel32" () As Long

Private Type ResultList
ci As Integer
cj As Integer
ck As Integer
cu As Long
End Type

Private Const MAXITEM As Long = 5000 ' 记录5000个以内的结果
' 最多允许 32768个 ,但不宜太多(List控件太卡,用ListView控件可以考虑更多记录)

Private arrList() As ResultList
Private mlPoint As Long


Private Sub cmdStartCombine_Click()
Dim a&, b&, c&, d As Long
Dim i&, j&, k&, m As Long

Dim fA&, fB&, fC As Long
Dim uA&, uB&, uC As Long
Dim wA&, wB&, wC As Long

mlPoint = 0&
Call List1.Clear
TextI.Text = ""
TextJ.Text = ""
TextK.Text = ""
' TextResult.Text = ""
TextResult.Text = "正在处理中………"

a = TextA.Text
b = TextB.Text
c = TextC.Text
d = TextD.Text

' 穷举i和j和k, 需要同时满足:
' 93 *i > d*(a*i+b*j+c*k)
' 和 930 *j > d*(a*i+b*j+c*k)
' 和 9000 *k > d*(a*i+b*j+c*k)
fA = d * a
fB = d * b
fC = d * c

' Dim ww As Long
' ww = GetTickCount()
If (93& > fA) Then
For i = 1& To 10000&
DoEvents
uA = 93& * i
wA = fA * i
For j = 1& To 10000&
uB = 930& * j
wB = fB * j
m = wA + wB
If (uA < m) Then Exit For
If (uB > m) Then
For k = 1& To 10000&
uC = 9000& * k
wC = m + fC * k
If (uA <= wC) Then Exit For
If (uB <= wC) Then Exit For
If (uC <= wC) Then Exit For
arrList(mlPoint).ci = i
arrList(mlPoint).cj = j
arrList(mlPoint).ck = k
arrList(mlPoint).cu = wC
mlPoint = 1& + mlPoint

If (MAXITEM = mlPoint) Then
' 强制退出全部循环
i = 999999
j = 999999
Exit For
End If
Next ' Next k
End If

Next ' Next j

Next ' Next i
End If
' 显示结果列表:
If (0& = mlPoint) Then
' TextResult.Text = "没有这种组合!耗时" & GetTickCount() - ww & "mm"
TextResult.Text = "没有这种组合!"
Else
TextResult.Text = "组合完成。结果数:" & mlPoint
DoEvents
For i = 0& To mlPoint - 1&
List1.AddItem Format$(arrList(i).ci, "@@@@") _
& Format$(arrList(i).cj, " @@@@") _
& Format$(arrList(i).ck, " @@@@")
Next
End If
End Sub

Private Sub Form_Load()
' 事先分配好数据记录空间
ReDim arrList(MAXITEM - 1&)
End Sub

Private Sub List1_Click()
Dim strTemp As String
Dim i&, k As Long

If (0& = mlPoint) Then Exit Sub
i = List1.ListIndex
k = arrList(i).ci
strTemp = "i = " & k & " , 93 * i = " & (93& * k) & vbLf
k = arrList(i).cj
strTemp = strTemp & "j = " & k & " , 930 * j = " & (930& * k) & vbLf
k = arrList(i).ck
strTemp = strTemp & "k = " & k & " , 9000 * k = " & (9000& * k) & vbLf
strTemp = strTemp & "d*(a*i +b*j +c*k) = " & arrList(i).cu
Call MsgBox(strTemp, 64&, "结果信息")
End Sub


链 接: https://pan.baidu.com/s/1XYgy24do1pmymJ1vJnzdpw
提取码: aiar
我的界面也是基于 米老鼠的工程改的,
只是在“窗口右边”增加了1个列表框控件,
 用于展示多条结果,点击相应的结果条目可以显示详细信息。
回复 点赞
milaoshu1020 05月07日
现在才发现已经盖了好多楼,汗;
回复 点赞
milaoshu1020 05月07日
楼上可能没搞清楚什么叫穷举,不过如果你有更好的算法可以贴出来; 为了计算剩余时间,我又修改了一下代码:
Option Explicit

Private Sub cmdStartCombine_Click()
    TextI = ""
    TextJ = ""
    TextK = ""
    TextResult = ""
    
    Dim a As Long
    a = TextA
    
    Dim b As Long
    b = TextB
    
    Dim c As Long
    c = TextC
    
    Dim d As Long
    d = TextD
    
    Dim datStartTime As Date
    datStartTime = Now
    
    Dim i As Long
    For i = 0 To 10000
        DoEvents
        
        Dim j As Long
        For j = 0 To 10000
            Dim k As Long
            For k = 0 To 10000
                Dim temp As Long
                temp = d * (a * i + b * j + c * k)
                
                If 93 * i > temp And 930 * j > temp And 9000 * k > temp Then
                    TextI = i
                    TextJ = j
                    TextK = k
                    TextResult = "组合完成."
                    Exit Sub
                End If
            Next
        Next
        
        Dim datNowTime As Date
        datNowTime = Now
        
        Dim lngSecondUsed As Long
        lngSecondUsed = DateDiff("s", datStartTime, datNowTime)
        
        Dim lngSecondTotal As Long
        lngSecondTotal = lngSecondUsed * 10001 \ (i + 1)
        
        Dim lngSecondRemain As Long
        lngSecondRemain = lngSecondTotal - lngSecondUsed
        
        Dim intHours As Integer
        intHours = lngSecondRemain \ 3600
        
        Dim intMinutes As Integer
        intMinutes = lngSecondRemain \ 60 Mod 60
        
        Dim intSeconds As Integer
        intSeconds = lngSecondRemain Mod 60
        
        TextResult = "剩余时间: " & intHours & ":" & intMinutes & ":" & intSeconds
    Next
    
    TextResult = "没有这种组合!"
    
End Sub
下载地址: 链接:https://pan.baidu.com/s/1nJ2qPQpAQU2X6AA8WkTIWg 提取码:1p1t 运行示例: 经过对比,我发现如果程序中有大量循环,编译出来的程序运行速度是IDE环境中程序运行速度的将近9倍; 所以,编译出来的程序只需要运行1个多小时就能全部遍历完了;
回复 点赞
脆皮大雪糕 05月07日
循环部分做改动,逐层进行判定,如果在i和j确定的情况下已经不满足判定条件,后面就没必要再继续计算了,从而对没有组合的情况大幅减少循环次数,提高判定速度。 我这biu的就出来了,你们试试。 此外,i,j,k我从1开始,从0 开始没意义,保证不符合判定,而且变成特例影响后续逻辑。

Private Sub cmdStartCombine_Click()
    TextI = ""
    TextJ = ""
    TextK = ""
    TextResult = ""
    
    Dim a As Long
    a = Val(TextA)
    
    Dim b As Long
    b = Val(TextB)
    
    Dim c As Long
    c = Val(TextC)
    
    Dim d As Long
    d = Val(TextD)
    
    Dim temp As Long
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim tmp_adi As Long
    Dim tmp_bdj As Long
    
    For i = 1 To 10000
        '在这一层循环里,j和k 都是1,对判定条件2和3影响很小,暂不理会后面再算
        '所以93*i<adi的话后面别算了,退出循环。而且等式左右i可以约掉
        If 93 <= a * d Then Exit For '
        
        '前面的过滤门槛过了,就为下一层做准备
        tmp_adi = a * d * i
        
        For j = 1 To 10000
            DoEvents
            '这一层,i是定值,adi是定值,上一层里算好了,k是1对判定条件3影响很小,暂不考虑,所以只要判定前两个不满足就别再进第三层了
            tmp_bdj = b * d * j
            temp = tmp_adi + tmp_bdj
            If 93 * i < temp Or 930 * j < temp Then Exit For
            
            For k = 1 To 10000
                '到了这层就三个判定逐个来了,但是 adi和bdj是定值在上一层已经算好了,这下再算一下cdk就可以了
                temp = tmp_adi + tmp_bdj + c * d * k
                '任何一个判定不满足就退出这层
                If 93 * i <= temp Or 930 * j <= temp Or 9000 * k <= temp Then Exit For
                
                '层层把关都过了,那么就是你想要的
                TextI = i
                TextJ = j
                TextK = k
                TextResult = "组合完成."
                Exit Sub
            Next
        Next
    Next
    
    TextResult = "没有这种组合!"
    
End Sub
回复 点赞
不懂别说哎 05月07日
如果不换算法的话下面的代码比你写的快那么一点: Private Sub cmdStartCombine_Click() Dim a As Long, b As Long, c As Long, d As Long, i As Long, j As Long, k As Long, temp As Long TextI = "": TextJ = "": TextK = "": TextResult = "" a = TextA: b = TextB: c = TextC: d = TextD For i = 0 To 10000 For j = 0 To 10000 For k = 0 To 10000 temp = d * (a * i + b * j + c * k) If 93 * i > temp And 930 * j > temp And 9000 * k > temp Then TextI = i: TextJ = j: TextK = k: TextResult = "组合完成.": Exit Sub Next k Next j DoEvents Next i TextResult = "没有这种组合!" End Sub
回复 点赞
kevinvolvo 05月07日
路过,挣个积分帮顶!!!!
回复 点赞
Cool body 05月07日
哈哈哈哈哈哈我去饿
回复 点赞
脆皮大雪糕 05月07日
引用 17 楼 hainanzlt99 的回复:
速度好慢,每次运行都要2个小时!
用15楼的代码,最慢也就10分钟
回复 点赞
hainanzlt99 05月07日
速度好慢,每次运行都要2个小时!
回复 点赞
发动态
发帖子
资源
创建于2007-09-28

818

社区成员

6515

社区内容

VB 资源
社区公告
暂无公告