2018元旦我的第一帖：网络最大流算法之VBA实现

aoe1981

Nick_Chen0622 发表于 2018-1-2 14:08
楼主，这个是图论的章节吗？我下载的附件运行不了，，，伤心

章节的话，不同的教材各不相同，算法确实是图论中的。

我用的是excel2013，其他版本情况不明。

aoe1981

　　以下是广度优先生成树的BFS核心代码：

1. 
   

复制代码

　　
        U(s) = 1: V(1) = s: B(1) = "": k = 1: i = 0
        Do '广度优先生成树（字典U保证标记U外新点，字典V保证扫描标号最小的点，遵循BFS）
            i = i + 1
            gd_ljd = Split(V_ljd(V(i) & "_ljd"), " ")
            For j = 1 To UBound(gd_ljd) '第一个为空格
                If Not (U.exists(gd_ljd(j))) Then '只选择不在U中的点
                    If A_f.exists(V(i) & "→" & gd_ljd(j) & "_f") Then '流出1：例：a→b
                        If A_f(V(i) & "→" & gd_ljd(j) & "_f") < A_c(V(i) & "→" & gd_ljd(j) & "_c") Then '流出U，f(α)<c(α)
                            k = k + 1: B(k) = B(i) & " " & V(i) & "→" & gd_ljd(j)
                            U(gd_ljd(j)) = k: V(k) = gd_ljd(j)
                            If gd_ljd(j) = t Then Exit Do '找到s-t点列后提前退出
                        End If
                    ElseIf A_f.exists(gd_ljd(j) & "←" & V(i) & "_f") Then '流出2：例：b←a
                        If A_f(gd_ljd(j) & "←" & V(i) & "_f") < A_c(gd_ljd(j) & "←" & V(i) & "_c") Then '流出U，f(α)<c(α)
                            k = k + 1: B(k) = B(i) & " " & V(i) & "→" & gd_ljd(j) '点列中统一成→表示正向弧
                            U(gd_ljd(j)) = k: V(k) = gd_ljd(j)
                            If gd_ljd(j) = t Then Exit Do '找到s-t点列后提前退出
                        End If
                    ElseIf A_f.exists(V(i) & "←" & gd_ljd(j) & "_f") Then '流入1：例：a←b
                        If A_f(V(i) & "←" & gd_ljd(j) & "_f") > 0 Then '流入U，f(α)>0
                            k = k + 1: B(k) = B(i) & " " & V(i) & "←" & gd_ljd(j)
                            U(gd_ljd(j)) = k: V(k) = gd_ljd(j)
                            If gd_ljd(j) = t Then Exit Do '找到s-t点列后提前退出
                        End If
                    ElseIf A_f.exists(gd_ljd(j) & "→" & V(i) & "_f") Then '流出2：例：b→a
                        If A_f(gd_ljd(j) & "→" & V(i) & "_f") > 0 Then '流入U，f(α)>0
                            k = k + 1: B(k) = B(i) & " " & V(i) & "←" & gd_ljd(j) '点列中统一成←表示反向弧
                            U(gd_ljd(j)) = k: V(k) = gd_ljd(j)
                            If gd_ljd(j) = t Then Exit Do '找到s-t点列后提前退出
                        End If
                    End If
                End If
            Next j
            If i = n Then Exit Do '扫描完所有点后退出do循环
        Loop
        bh = B.items: pd1 = 0　　

　　红色部分代码是完善后添加的。原图论教材中也有提到。我一开始也是做了这句的，但是由于位置放错了，而且自认为只需一句，当时始终出错，表现出来就是同样的图，同样的起点终点，当乱序边以后，最大流总是不一样。后来，我干脆取掉了，结果对了，便发布了最初的附件。

　　然而，经过进一步思考，以上结果正确也是由于偶然性。bh用来记录搜索到的所有点列，没有终点控制时，会遍历完，产生下面的结果（仅为举例）：
　　s-a
　　s-t
　　s-t-d
　　s-t-d-e
　　……
　　也就是说，此时的代码不认识终点，只知道遍历完所有点，以至于最长点列不一定是以t结束的。但我的代码会取出第一次遇到的含终点t的点列，而忽略其余。这就是偶然性。当图的阶、规模很大时，这样做很低效。因此，还是完善下，严格依据书中给出的算法来。

q8254733

我只想知道这个能干什么？

aoe1981

q8254733 发表于 2018-1-3 10:51
我只想知道这个能干什么？

这个……呃……一时语塞……至于实际应用我也未涉及，书中有“管道输油”的例子，也只是谈到而已……想来，管道形成有向图，且有流量，唯图论中的“网络”可以恰到好处地刻画、反映、模拟……

呵呵，实在是水平有限，不能回答此问题十之一二……

aoe1981

　　将我的生成距离树的算法一并从竞赛帖中整理至此。

　　链接：
　　http://club.excelhome.net/forum. ... 620&pid=9363570

　　附件：
　　

　　相关代码：

1. Option Explicit
   
2. Sub jlshu()
   
3.     Dim arr, brr, D_ljd As Object, B_jl As Object, t1$, t2$, i&, j&, k&, qd$, zd$, mbjl#, mblj$
   
4.     arr = Sheet2.Range("a1").CurrentRegion
   
5.     Set D_ljd = CreateObject("Scripting.Dictionary")
   
6.     Set B_jl = CreateObject("Scripting.Dictionary")
   
7.     For i = 2 To UBound(arr, 1) '将路径对应的距离，点的邻接表写入字典
   
8.         t1 = arr(i, 1): t2 = arr(i, 2)
   
9.         D_ljd(t1) = D_ljd(t1) & " " & t2 '点_邻接点
   
10.         D_ljd(t2) = D_ljd(t2) & " " & t1
    
11.         B_jl(t1 & "-" & t2) = arr(i, 3) '边_距离
    
12.         B_jl(t2 & "-" & t1) = arr(i, 3)
    
13.     Next i
    
14.     Dim D_jl As Object, D_lj As Object, U As Object, key1, key2, n&, gd, f_dian$, min_dian$, min_jl#, max_jl# '点的距离标记、路径标记、添加标记
    
15.     Set D_jl = CreateObject("Scripting.Dictionary")
    
16.     Set D_lj = CreateObject("Scripting.Dictionary")
    
17.     Set U = CreateObject("Scripting.Dictionary")
    
18.     key1 = D_ljd.keys: n = D_ljd.Count
    
19.     For i = 0 To n - 1 '初始化各点标记
    
20.         D_jl(key1(i)) = 0: D_lj(key1(i)) = key1(i)
    
21.     Next i
    
22.     max_jl = WorksheetFunction.Sum(B_jl.items) + 1: min_jl = max_jl
    
23.     qd = Sheet3.Range("a2").Value: zd = Sheet3.Range("b2").Value: U(qd) = 1 '首先添加根结点
    
24.     For i = 1 To n - 1 '至多添加其余n-1个点
    
25.         key1 = U.keys
    
26.         For j = 1 To U.Count '遍历U中每一点
    
27.             gd = Split(D_ljd(key1(j - 1)), " ")
    
28.             For k = 1 To UBound(gd) '扫描U中每一点的不属于U的邻接点
    
29.                 If Not (U.exists(gd(k))) Then
    
30.                     If D_jl(key1(j - 1)) + B_jl(key1(j - 1) & "-" & gd(k)) < min_jl Then '父点距离标记+路径距离
    
31.                         f_dian = key1(j - 1): min_dian = gd(k): min_jl = D_jl(key1(j - 1)) + B_jl(key1(j - 1) & "-" & gd(k)) '寻找最短距离的点
    
32.                     End If
    
33.                 End If
    
34.             Next k
    
35.         Next j
    
36.         D_jl(min_dian) = min_jl '更新最短距离点的距离数据
    
37.         D_lj(min_dian) = D_lj(f_dian) & "-" & min_dian '记录最短距离点的路径数据：最短距离点&"-"&父点路径标记
    
38.         U(min_dian) = 1 '添加最短距离点
    
39.         min_jl = max_jl '每比较完一轮将最小距离重置为距离和+1
    
40.     Next i
    
41.     ReDim brr(1 To n, 1 To 2)
    
42.     key1 = D_jl.items: key2 = D_lj.items
    
43.     For i = 1 To n
    
44.         brr(i, 1) = key1(i - 1): brr(i, 2) = key2(i - 1)
    
45.         gd = Split(key2(i - 1), "-")
    
46.         If gd(UBound(gd)) = zd Then mbjl = brr(i, 1): mblj = brr(i, 2)
    
47.     Next i
    
48.     Sheet3.Range("a4:b" & Rows.Count).ClearContents
    
49.     Sheet3.Range("a4").Resize(n, 2).Value = brr
    
50.     MsgBox "起点" & qd & "到终点" & zd & "的最短距离是：" & mbjl & "，最短路径是：" & mblj
    
51. End Sub

复制代码

　　也算是蹭热度。

aoe1981

　　将我的生成距离树的算法一并从竞赛帖中整理至此。

　　链接：
　　http://club.excelhome.net/forum. ... 1379620&pid=9363570

　　附件：
　　 假如你是无人驾驶车上的电脑，你想好了怎么走吗？_距离树_aoe1981.zip (164.92 KB, 下载次数: 6)

2018-1-3 20:31 上传

点击文件名下载附件

　　相关代码：

1. 
   

复制代码

　　

1. Option Explicit
   
2. Sub jlshu()
   
3.     Dim arr, brr, D_ljd As Object, B_jl As Object, t1$, t2$, i&, j&, k&, qd$, zd$, mbjl#, mblj$
   
4.     arr = Sheet2.Range("a1").CurrentRegion
   
5.     Set D_ljd = CreateObject("Scripting.Dictionary")
   
6.     Set B_jl = CreateObject("Scripting.Dictionary")
   
7.     For i = 2 To UBound(arr, 1) '将路径对应的距离，点的邻接表写入字典
   
8.         t1 = arr(i, 1): t2 = arr(i, 2)
   
9.         D_ljd(t1) = D_ljd(t1) & " " & t2 '点_邻接点
   
10.         D_ljd(t2) = D_ljd(t2) & " " & t1
    
11.         B_jl(t1 & "-" & t2) = arr(i, 3) '边_距离
    
12.         B_jl(t2 & "-" & t1) = arr(i, 3)
    
13.     Next i
    
14.     Dim D_jl As Object, D_lj As Object, U As Object, key1, key2, n&, gd, f_dian$, min_dian$, min_jl#, max_jl# '点的距离标记、路径标记、添加标记
    
15.     Set D_jl = CreateObject("Scripting.Dictionary")
    
16.     Set D_lj = CreateObject("Scripting.Dictionary")
    
17.     Set U = CreateObject("Scripting.Dictionary")
    
18.     key1 = D_ljd.keys: n = D_ljd.Count
    
19.     For i = 0 To n - 1 '初始化各点标记
    
20.         D_jl(key1(i)) = 0: D_lj(key1(i)) = key1(i)
    
21.     Next i
    
22.     max_jl = WorksheetFunction.Sum(B_jl.items) + 1: min_jl = max_jl
    
23.     qd = Sheet3.Range("a2").Value: zd = Sheet3.Range("b2").Value: U(qd) = 1 '首先添加根结点
    
24.     For i = 1 To n - 1 '至多添加其余n-1个点
    
25.         key1 = U.keys
    
26.         For j = 1 To U.Count '遍历U中每一点
    
27.             gd = Split(D_ljd(key1(j - 1)), " ")
    
28.             For k = 1 To UBound(gd) '扫描U中每一点的不属于U的邻接点
    
29.                 If Not (U.exists(gd(k))) Then
    
30.                     If D_jl(key1(j - 1)) + B_jl(key1(j - 1) & "-" & gd(k)) < min_jl Then '父点距离标记+路径距离
    
31.                         f_dian = key1(j - 1): min_dian = gd(k): min_jl = D_jl(key1(j - 1)) + B_jl(key1(j - 1) & "-" & gd(k)) '寻找最短距离的点
    
32.                     End If
    
33.                 End If
    
34.             Next k
    
35.         Next j
    
36.         D_jl(min_dian) = min_jl '更新最短距离点的距离数据
    
37.         D_lj(min_dian) = D_lj(f_dian) & "-" & min_dian '记录最短距离点的路径数据：父点路径标记&"-"&最短距离点
    
38.         U(min_dian) = 1 '添加最短距离点
    
39.         min_jl = max_jl '每比较完一轮将最小距离重置为距离和+1
    
40.     Next i
    
41.     ReDim brr(1 To n, 1 To 2)
    
42.     key1 = D_jl.items: key2 = D_lj.items
    
43.     For i = 1 To n
    
44.         brr(i, 1) = key1(i - 1): brr(i, 2) = key2(i - 1)
    
45.         gd = Split(key2(i - 1), "-")
    
46.         If gd(UBound(gd)) = zd Then mbjl = brr(i, 1): mblj = brr(i, 2)
    
47.     Next i
    
48.     Sheet3.Range("a4:b" & Rows.Count).ClearContents
    
49.     Sheet3.Range("a4").Resize(n, 2).Value = brr
    
50.     MsgBox "起点" & qd & "到终点" & zd & "的最短距离是：" & mbjl & "，最短路径是：" & mblj
    
51. End Sub

复制代码

　　也算是蹭热度。

aoe1981

　　做着做着，忽然有一个想法：想把几种重要的树都做一遍。当然，这些都不是前所没有的东西，我只是把它当做练习或是业余时光的一种消遣，而且极是想用自己的原创思路，不是照抄别人的。
　　据我所知，这些树是：
　　1.广度优先生成树（已做，就在计算网络最大流的算法中，只是未加提取做成较为通用的版本）；
　　2.深度优先生成树；
　　3.距离树（结合竞赛区的题，已做，就在楼上）；
　　4.最小权生成树。
　　关于最小权生成数，有两种算法：贪婪算法和其改进prim算法，其实我是无所谓算法好坏的一个人，不太注重算法是否高效，也不太会注重，只是更加注重能否用VBA实现。呵呵呵……因此，这两种算法总是都想试一试的……

Nick_Chen0622

aoe1981 发表于 2018-1-3 16:38
　　将我的生成距离树的算法一并从竞赛帖中整理至此。

　　链接：

这，心细一看，突然发现以前我帖子里面的CAD画的图居然可以成为蓝老师的竞赛题突然感觉好荣幸，哈哈哈，，，
不过我也是很low了，我解不出来，当时发帖子也想得到类似的解答，，不过今天看了楼主的代码，突然发现高手如云，只是楼主，您的代码好多个D_lj,key1, key2, n&, gd, f_dian$, min_dian$, min_jl#, max_jl#等等，看多了就会晕，毕竟不是我自己写的代码，哈哈，，，虽然楼主给了很多注解，，，，给楼主一个大拇哥，，，太牛了

Nick_Chen0622

aoe1981 发表于 2018-1-3 16:38
　　将我的生成距离树的算法一并从竞赛帖中整理至此。

　　链接：

楼主，不好意思，我还是有几个疑问：
1.D_ljd(t1) = D_ljd(t1) & " " & t2
        D_ljd(t2) = D_ljd(t2) & " " & t1
        B_jl(t1 & "-" & t2) = arr(i, 3)
        B_jl(t2 & "-" & t1) = arr(i, 3)
我能够看明白B_jl是录入距离，可是D_LJD录入点的代码我闹不懂，我不明白您是如何想到以这样的形式录入点的
2.For i = 1 To n - 1 '&Ouml;&Aacute;&para;à&Igrave;í&frac14;&Oacute;&AElig;&auml;&Oacute;àn-1&cedil;&ouml;&micro;&atilde;
        key1 = U.keys
        For j = 1 To U.Count '±é&Agrave;úU&Ouml;&ETH;&Atilde;&iquest;&Ograve;&raquo;&micro;&atilde;
            gd = Split(D_ljd(key1(j - 1)), " ")
            For k = 1 To UBound(gd) '&Eacute;¨&Atilde;èU&Ouml;&ETH;&Atilde;&iquest;&Ograve;&raquo;&micro;&atilde;&micro;&Auml;&sup2;&raquo;&Ecirc;&ocirc;&Oacute;&Uacute;U&micro;&Auml;&Aacute;&Uacute;&frac12;&Oacute;&micro;&atilde;
                If Not (U.exists(gd(k))) Then
                    If D_jl(key1(j - 1)) + B_jl(key1(j - 1) & "-" & gd(k)) < min_jl Then '&cedil;&cedil;&micro;&atilde;&frac34;à&Agrave;&euml;±ê&frac14;&Ccedil;+&Acirc;·&frac34;&para;&frac34;à&Agrave;&euml;
                        f_dian = key1(j - 1): min_dian = gd(k): min_jl = D_jl(key1(j - 1)) + B_jl(key1(j - 1) & "-" & gd(k)) '&Ntilde;°&Otilde;&Ograve;×&icirc;&para;&Igrave;&frac34;à&Agrave;&euml;&micro;&Auml;&micro;&atilde;
                    End If
                End If
            Next k
        Next j
这一段代码是不是遍历树的节点，我想问的是，如何去遍历一棵树的节点，这个点我一直没搞懂，所以希望您如果可以的话能给我解答一下，非常感谢。

3.我能否将您的代码改成我输入好几个不一样的节点，然后它可以一次计算出长度，并输出在表中。
我之前的帖子有个好心的老师给出了答案，可是，它的代码不如您的好懂

aoe1981

Nick_Chen0622 发表于 2018-1-3 21:51
楼主，不好意思，我还是有几个疑问：
1.D_ljd(t1) = D_ljd(t1) & " " & t2
        D_ljd(t2) = D_ljd ...

　　疑问１参照自香川大师录入点的邻接表的办法，因为a-b从左到右可录为a的邻接点b，从右到左可录为b的邻接点a，这样做不是效率更高吗？
　　疑问２如何遍历图中所有点？学会图的广度搜索与深度搜索后就会明白很多。这个距离树的点的遍历倒和所谓广度、深度关系不大，是借助了字典U做集合，每次扫描U中所有点的不属于U的邻接点，满足条件的添加进U。所依赖的具体实现手段自然还是邻接表。理解我的代码中的三层循环分别循环的是什么就清楚了：最外层是n-1个未添加的点的循环（因为根结点已添加），中层是循环U中所有点，内层是循环U中具体一点的所有邻接点。每次都比较最短距离的点添加进U。
　　疑问３请注意我的代码依赖的输入数据为一堆边的起止点、距离，以及出发点（根结点），至于到达点（终点）对于距离树而言是不必要的，只是与竞赛题联系罢了。

　　呵呵，我也是一个初学者。共勉。