[[20220119105630]] 『最短経路探索をしたいです。』(まる) >>BOT

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『最短経路探索をしたいです。』(まる)

最短経路探索をしたいです。

各アドレス(分岐点や行き止り点)に番号が付与されており、
アドレス間には距離が設定されています。
アドレスのStart-Goalを読み込むことで、
アドレス間の距離の合計を求めることを目標としています。

シート1にはアドレス間距離が記載されています。
A,B列は各アドレス番号、C列はアドレス間距離です。

	A列	B列	C列	
1	1	3	100	
2	2	3	100	
3	3	4	134	
4	4	20	20	
5	4	32	40	
6	5	32	46	
7	5	10	80	
8	5	330	150	
9	21	32	321	
…	…	…	…	

シート2には求めたいアドレスのStart-Goalが記載されています。
A,B列はアドレスのStart-Goal、C列は空欄です。

	A列	B列	C列	
1	1	20		
2	20	10		
3	10	330		
4	2	21		
5	21	2		
6	20	21		
7	1	20		
…	…	…	…	

最終的にはシート2のC列に、シート1のアドレス間距離の和を出力したいです。カッコ内は参考です。
1、7列目や4、5列目のようにすでに計算されているStart-Goalもでてきます。

	A列	B列	C列	
1	1	20	254 (1→3→4→20、100+134+20)
2	20	10	186 (20→4→32→5→10、20+40+46+80)
3	10	330	230 (10→5→330、80+150)
4	2	21	591 (2→3→4→32→21、100+134+40+321)
5	21	2	591 (2→3→4→32→21、100+134+40+321)
6	20	21	381 (20→4→32→21、20+40+321)
7	1	20	254 (1→3→4→20、100+134+20)
…	…	…	…	

今回は簡単な迷路ですが、実際は50回程度の足し算が必要になるほどの迷路の大きさになっており、Start-Goalの個数も100個を超えるため、
ある程度の速度がほしいです。

探索プログラムを組んだことがないのでご協力お願いします。

< 使用 Excel:Office365、使用 OS:Windows10 >


Sub main()
'作業用シートとしてSheet3を設置すること
    Dim dic As Object, c As Range, cc As Range, m As Long, n As Long, tot As Long, comm As String, totcomm As String
    Set dic = CreateObject("Scripting.dictionary")
    For Each c In Sheets("Sheet1").Range("A:A").SpecialCells(2)
        dic(c.Value & "→" & c.Offset(, 1).Value) = c.Offset(, 2).Value
        dic(c.Offset(, 1).Value & "→" & c.Value) = c.Offset(, 2).Value
    Next c
    Sheets("Sheet2").Range("C:D").ClearContents
    For Each cc In Sheets("Sheet2").Range("A:A").SpecialCells(2)
        Sheets("Sheet3").Cells.ClearContents
        For Each c In Sheets("Sheet1").Range("A:A").SpecialCells(2)
            If c.Value = cc.Value Then Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, 2).Value = Array(c.Value, c.Offset(, 1).Value)
            If c.Offset(, 1).Value = cc.Value Then Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, 2).Value = Array(c.Offset(, 1).Value, c.Value)
        Next c
        m = 2
        Do
            n = Sheets("Sheet3").Cells(m, Columns.Count).End(xlToLeft).Value
            If WorksheetFunction.CountA(Sheets("Sheet3").Rows(m)) = 0 Then cc.Offset(, 2).Value = "該当なし": Exit Do
            For Each c In Sheets("Sheet1").Range("A:A").SpecialCells(2)
                Set r = Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Offset(1)
                If c.Value = n Then
                    If WorksheetFunction.CountIf(Sheets("Sheet3").Rows(m), c.Offset(, 1).Value) = 0 Then
                        Sheets("Sheet3").Rows(m).EntireRow.Copy r
                        Sheets("Sheet3").Cells(r.Row, Columns.Count).End(xlToLeft).Offset(, 1).Value = c.Offset(, 1).Value
                    End If
                End If
                If c.Offset(, 1).Value = n Then
                    If WorksheetFunction.CountIf(Sheets("Sheet3").Rows(m), c.Value) = 0 Then
                        Sheets("Sheet3").Rows(m).EntireRow.Copy r
                        Sheets("Sheet3").Cells(r.Row, Columns.Count).End(xlToLeft).Offset(, 1).Value = c.Value
                    End If
                End If
            Next c
            Set r = Sheets("Sheet3").Cells.Find(cc.Offset(, 1).Value, , , xlWhole)
            If Not r Is Nothing Then
                comm = Join(Application.Transpose(Application.Transpose(r.EntireRow.Cells.SpecialCells(2))), "→")
                tot = 0
                totcomm = ""
                For i = 0 To UBound(Split(comm, "→")) - 1
                    tot = tot + dic(Split(comm, "→")(i) & "→" & Split(comm, "→")(i + 1))
                    totcomm = totcomm & "+" & dic(Split(comm, "→")(i) & "→" & Split(comm, "→")(i + 1))
                Next i
                cc.Offset(, 2).Value = tot
                cc.Offset(, 3).Value = comm & "、" & totcomm
                Exit Do
            End If
            DoEvents
            m = m + 1
        Loop
    Next cc
End Sub

(mm) 2022/01/19(水) 15:20


| 実際は50回程度の足し算が必要になるほどの迷路の大きさになっており、
| Start-Goalの個数も100個を超えるため、

その大きい場合の実例を出してもらうと取り組みやすいですね。

(γ) 2022/01/20(木) 07:50


 4   2   21  591 (2→3→4→32→21、100+134+40+321)
 5   21  2   591 (2→3→4→32→21、100+134+40+321)
 は、下記のようにならないんですか?
 4   2  21   595 (2→3→4→32→21、 100+134+40+321)
 5  21  2    595 (21→32→4→3→2、 321+40+134+100)

(γ) 2022/01/20(木) 08:11


 知的好奇心をくすぐられたので、書いてみました。
 前提は各データに抜け無しです。

 Sub sample()
     Dim ws1 As Worksheet
     Set ws1 = ThisWorkbook.Worksheets(1)

     Dim routeDic As Object
     Dim costDic As Object
     Set routeDic = CreateObject("Scripting.Dictionary")
     Set costDic = CreateObject("Scripting.Dictionary")

     Dim temp As Variant
     temp = ws1.Range("A1", ws1.Cells(ws1.Rows.Count, "C").End(xlUp)).Value

     Dim i As Long
     Dim val(2) As Long
     For i = LBound(temp, 1) To UBound(temp, 1)
         val(0) = temp(i, 1)
         val(1) = temp(i, 2)
         val(2) = temp(i, 3)
         If Not routeDic.Exists(val(0)) Then
             routeDic.Add val(0), CreateObject("Scripting.Dictionary")
         End If
         routeDic(val(0)).Add val(1), i
         If Not routeDic.Exists(val(1)) Then
             routeDic.Add val(1), CreateObject("Scripting.Dictionary")
         End If
         routeDic(val(1)).Add val(0), i
         costDic.Add i, val(2)
     Next
     Erase temp
     Set ws1 = Nothing

     Dim ws2 As Worksheet
     Set ws2 = ThisWorkbook.Worksheets(2)
     With ws2
         temp = .Range("A1").Resize(.Cells(.Rows.Count, "A").End(xlUp).Row, 4).Value
     End With

     Dim isGool As Boolean
     Dim cost As Long
     Dim passed() As Variant
     Dim route() As String
     Dim v As Variant
     For i = LBound(temp, 1) To UBound(temp, 1)
         cost = 0
         passed = Array()
         route = Split("")
         isGool = False
         MatchRoute routeDic, passed, route, temp(i, 1), temp(i, 2), isGool
         If isGool Then
             For Each v In passed
                 cost = cost + costDic(v)
             Next
             temp(i, 3) = cost
             temp(i, 4) = Join(route, "⇒")
         Else
             temp(i, 3) = CVErr(xlErrNA)
         End If
     Next
     ws2.Range("A1").Resize(UBound(temp, 1), UBound(temp, 2)).Value = temp
 End Sub
 Private Sub MatchRoute(srcRouteDic As Object, srcPassed() As Variant, srcRoute() As String, ByVal pos As Long, ByVal gool As Long, isGool As Boolean)
     Dim passed() As Variant
     Dim route() As String
     Dim v As Variant
     Dim doThrough As Boolean
     For Each v In srcRouteDic(pos).Keys
         If isGool Then Exit For
         doThrough = False
         If UBound(srcPassed) >= 0 Then
             With Application
                 If .IfError(.Match(srcRouteDic(pos)(v), srcPassed, 0), 0) > 0 Then doThrough = True
             End With
         End If
         If doThrough = False Then
             passed = srcPassed
             ReDim Preserve passed(UBound(passed) + 1)
             passed(UBound(passed)) = srcRouteDic(pos)(v)
             route = srcRoute
             ReDim Preserve route(UBound(route) + 1)
             route(UBound(route)) = pos
             If v = gool Then
                 ReDim Preserve route(UBound(route) + 1)
                 route(UBound(route)) = v
                 isGool = True
                 Exit For
             End If
             MatchRoute srcRouteDic, passed, route, v, gool, isGool
         End If
     Next
     If isGool Then
         srcPassed = passed
         srcRoute = route
     End If
 End Sub

(tkit) 2022/01/20(木) 12:10


おもしろそうだったから書いてしまった(多分遅い)

Private PointList As Object
Private TimeOut As Long
Private result() As Variant
'実行メソッド
Public Sub Button_Click()

    Dim point_array As Variant: point_array = Sheet1.Range("A1:C9").Value
    Dim rout_array  As Variant: rout_array = Sheet2.Range("A1:B7").Value

    Set PointList = GetPointList(point_array)
    Dim i As Long, rout As Object
    For i = 1 To UBound(rout_array)
        TimeOut = 0
        Erase result
        Set rout = CreateObject("Scripting.Dictionary")
        rout.Add CStr(rout_array(i, 1)), CStr(rout_array(i, 1))
        Call subrout(rout_array(i, 1), "", rout_array(i, 2), 0, rout, TimeOut)
        Debug.Print i & vbTab & Join(result, vbTab)
    Next i
End Sub
'DictionaryObjectのディープコピー用関数
Private Function DicDeepCopy(ByVal dic As Object) As Object
    Dim rtn As Object: Set rtn = CreateObject("Scripting.Dictionary")
    Dim key As Variant
    For Each key In dic.Keys
        rtn.Add key, dic(key)
    Next key
    Set DicDeepCopy = rtn
End Function
'再起処理用メインルーチン
Private Function subrout(ByVal st As String, ByVal er As String, ByVal ed As String, ByVal bt As Long, ByVal rout As Object, ByVal tu As Long)
    Dim rsl As Collection: Set rsl = GetStRecords(st, er)
    If rsl.Count = 0 Then Exit Function

    Dim buf As Variant, t As Long, var As Variant, dic As Object
    For Each buf In rsl
        If buf(0) = st Then
            var = Array(buf(1), buf(0))
        Else
            var = Array(buf(0), buf(1))
        End If
        If buf(0) = ed Or buf(1) = ed Then
            If TimeOut = 0 Or TimeOut > bt + buf(2) Then
                TimeOut = bt + buf(2)
                result = Array(Join(rout.Items, "->") & "->" & var(0), bt + buf(2))
            End If
        Else
            If (TimeOut = 0 Or TimeOut > bt + buf(2)) And Not rout.Exists(var(0)) Then
                Set dic = DicDeepCopy(rout)
                dic.Add CStr(var(0)), CStr(var(0))
                Call subrout(var(0), var(1), ed, bt + buf(2), dic, TimeOut)
            End If
        End If
    Next buf
End Function
'通過ポイントのリスト作成
Private Function GetPointList(ByVal ary As Variant) As Object
    Dim rs As Object: Set rs = CreateObject("ADODB.Recordset")
    With rs
        With .Fields
            .Append "POINT1", 200, 255
            .Append "POINT2", 200, 255
            .Append "TIME", 14
        End With
        .Open
    End With

    Dim i As Long
    For i = 1 To UBound(ary, 1)
        rs.AddNew Array("POINT1", "POINT2", "TIME"), Array(ary(i, 1), ary(i, 2), ary(i, 3))
    Next i
    rs.Update

    Set GetPointList = rs
End Function
'フィルタかけてリスト内から検索
Private Function GetStRecords(ByVal st As String, ByVal er As String) As Collection
    With PointList
        .Filter = "(POINT1='" & st & "' AND POINT2<>'" & er & "') OR (POINT1<>'" & er & "' AND POINT2='" & st & "')"

        Dim rtn As New Collection
        If .RecordCount > 0 Then
            .MoveFirst
            Do Until .EOF
                rtn.Add Array(.Fields("POINT1").Value, .Fields("POINT2").Value, .Fields("TIME").Value)
                .MoveNext
            Loop
        End If
    End With

    Set GetStRecords = rtn
End Function
(モゲラ) 2022/01/20(木) 13:27

 せっかく書いたものが無駄にならないよう、このあたりで、
 標準的なダイクストラ法を使ったものを載せておきましょう。

 Option Explicit
 Rem   最短路検索

 Dim N       As Long           'nodeの数
 Const INF   As Long = 99999   '最大値
 Dim mat()   As Long           '隣接行列
 Dim v()     As Long           '確定フラグ
 Dim distance() As Long        '始点からnodeまでの距離
 Dim pointer()  As Long        '前のnodeへのポインタ
 Dim dic     As Object
 Dim dicR    As Object
 Dim ws      As Worksheet
 Dim wsOut   As Worksheet

 Sub main()
     Dim start&
     Dim i&, j&, k&
     Dim min&, p&
     Dim st$, ed$

     Set ws = Worksheets("Sheet1")
     Set wsOut = Worksheets("Sheet2")

     Set dic = CreateObject("Scripting.Dictionary")
     Set dicR = CreateObject("Scripting.Dictionary")

     Call setting    ' 重み付き隣接行列のセット

     For i = 1 To wsOut.[A1].CurrentRegion.Rows.Count
         st = CStr(wsOut.Cells(i, "A").Value)
         ed = CStr(wsOut.Cells(i, "B").Value)

         start = dic(st)
         For k = 1 To N
             distance(k) = INF
             v(k) = 0
         Next k

         distance(start) = 0
         pointer(start) = 0

         For j = 1 To N
             '最小のnodeを探す
             min = INF
             For k = 1 To N
                 If v(k) = 0 And distance(k) < min Then
                     p = k
                     min = distance(k)
                 End If
             Next k
             v(p) = 1                '最小のnodeを確定する
             If min = INF Then
                 MsgBox "適切なグラフでない"
                 Exit Sub
             End If

             For k = 1 To N
                 'pを経由してkに至る長さがそれまでの最短路より小さい時は更新する
                 If distance(p) + mat(p, k) < distance(k) Then
                     distance(k) = distance(p) + mat(p, k)
                     pointer(k) = p
                 End If
             Next k
         Next j

         wsOut.Cells(i, "C").Value = formatting(st, ed)  '出力のための形式整備
     Next
 End Sub

 Function setting()
     Dim s$
     Dim p&
     Dim e
     Dim j&, k&
     Dim st$, ed$

     ' node番号と 整数インデックスとの相互変換をdictionaryに保持
     For Each e In ws.[A1].CurrentRegion.Resize(, 2)
         s = e.Value
         If Not dic.Exists(s) Then
             p = p + 1
             dic(s) = p
             dicR(p) = s
         End If
     Next

     N = dic.Count                       'nodeの数
     ReDim mat(1 To N, 1 To N)           '隣接行列
     ReDim v(1 To N)                     '確定フラグ
     ReDim distance(1 To N)              'nodeまでの距離
     ReDim pointer(1 To N)               '前のnodeへのポインタ

     'いったん大きい数をセット
     For j = 1 To N
         For k = 1 To N
             mat(j, k) = INF
         Next
     Next
     '距離データを隣接行列に読み込む
     For Each e In ws.[A1].CurrentRegion.Resize(, 1)
         st = CStr(e.Value)
         ed = CStr(e.Offset(, 1).Value)
         mat(dic(st), dic(ed)) = e.Offset(, 2).Value
         mat(dic(ed), dic(st)) = e.Offset(, 2).Value  '無向グラフのため逆方向もセット
     Next
 End Function

 Function formatting(st As String, ed As String) As String
     Dim j As Long
     Dim p As Long
     Dim ary(), ary2(), ary3()
     Dim s1$, s2$, s3$
     Dim c As Long

     j = dic(ed)
     ' ------------  s1(距離合計)の作成
     s1 = distance(j)

     ' ------------ s2("1→3→4→20”部分)の作成
     c = 0
     ReDim Preserve ary(0 To c)
     ary(c) = j
     'pointerは終点から始点に向かうものなので、逆転させる必要
     p = j
     Do While pointer(p) <> 0
         c = c + 1
         ReDim Preserve ary(0 To c)
         ary(c) = pointer(p)
         p = pointer(p)
     Loop
     '----------------逆転したうえで、文字列化
     ReDim ary2(0 To UBound(ary))
     For j = 0 To UBound(ary)
         ary2(j) = dicR(ary(UBound(ary) - j))
     Next
     s2 = Join(ary2, "→")

     '----------------- s3("100+134+20") の作成
     ReDim ary3(0 To UBound(ary) - 1)
     For j = 0 To UBound(ary) - 1
         ary3(j) = mat(ary(UBound(ary) - j - 1), ary(UBound(ary) - j))
     Next
     s3 = Join(ary3, "+")

     formatting = s1 & " (" & s2 & "、 " & s3 & ")"
 End Function
 # 河西氏の著作を参考にさせていただきました。
(γ) 2022/01/20(木) 14:42

 私が提示したコードは、最小距離を求めていなく、コード上最初に
 到達したものを出しているだけです。
 実用するのであれば、他の方のコードを参照してください。

 改修も出来ますが、必要は無いかな、と。

 >標準的なダイクストラ法を使ったものを載せておきましょう。
 アルゴリズムを知る知らないで、設計時間や結果の信頼性に大きな差が
 出てしまいますね。
 γさん、勉強になりました。

(tkit) 2022/01/20(木) 16:00


皆様ありがとうございます。

mmさん
先に上げた事例をmmさんのコードで実施後、
自身の巨大迷路で確認してみましたが、4時間経ってもゴールできていませんでした。
17000回くらい計算していました。
小さめの迷路であれば1つあたり十数秒でゴールできることは確認できています。
ありがとうございます。

γさん (以前も問題解決にご協力いただいており、感謝しております)
・巨大迷路の事例提示は準備します。少々時間がかかるかもしれません…。
・スタートとゴールが逆転しているので本来は計算も逆になりますが、
 最終的にほしいのは合計値なので、無駄な計算を省けるのであれば省きたいなという思いがありました。
 すでに計算している、道のりや逆転している道のりは、計算結果を参照すれば良いかなと。

tkitさん、モゲラさん
コードの提供ありがとうございます。
しらみつぶしに行けば、ゴールまでたどり着けるかなと思ってみたはいいものの、
コードにすることの難しさがありました。
(まる) 2022/01/20(木) 18:57


質問者さんへ

後学のために、それぞれ提示してあるコードで、
処理時間を教えてください。
サンプル迷路1つで構いません。
(tkit) 2022/01/21(金) 08:11


 tkitさん、コメントありがとうございました。

 以下、質問者さんへ。

 今更ですが、そもそもこの話は、どんなことが背景になっているんでしょうか。
 そのあたりを少し説明されたほうが回答者も実感が湧いて取り組めます。

 例えば、
 ・各節点は営業所で、
 ・距離は営業所間の距離を示していて、
 配送センターが各営業所を巡回して配送していく際の、
 もしくは、余裕のある営業所が別の営業所に融通する際の、
 最短距離を概略掴みたいのです、とかなんとか言った話が欲しいですね。

 なお、提示された例は余り適切な例ではなかったですね。今更ですが。
 A列     B列     C列     
 1       3       100     
 2       3       100     
 3       4       134     
 4       20      20      
 4       32      40      
 5       32      46      
 5       10      80      
 5       330     150     
 21      32      321     
 これだと
           2   20    21   10 
           |    |     |    |
      1 -- 3 -- 4 -- 32 -- 5  -- 330   
 というグラフと同型になり、
 どの2つのnodeも、単一のパスでしかつながっていませんので、
 最短も何もないじゃないですか。
 最短路ということを考える余地のないケースです。
 まあ、現実には、そうした前提に近い状況なのかもしれませんが。  

 (そうした前提のもとで提案されたコードを現実のものに適用すると、
   場合によっては、閉路を何度も巡ってしまうこともあり得ます。)

 例えば、以下のような例であれば、     
 A列     B列     C列
 1       2       4
 1       3       3
 2       3       1
 2       4       1
 2       5       5
 4       5       3
 3       6       2
 5       6       1
 5       7       2
 6       7       4
 最短路という話が出てくる簡単な例になっているでしょう。
 いかがでしたでしょうか。

(γ) 2022/01/21(金) 21:16


 こんにちは。

 | γさん (以前も問題解決にご協力いただいており、感謝しております)
 | ・巨大迷路の事例提示は準備します。少々時間がかかるかもしれません…。
 ということですが、特段の作成作業をしていただく必要はありません。

 | 先に上げた事例をmmさんのコードで実施後、
 | 自身の巨大迷路で確認してみましたが、4時間経ってもゴールできていませんでした。
 ということでしたので、現状のもので結構です。
 もちろん、何か固有名詞があって支障があるのであれば、
 適当に置換したり、数字にでも変換してもらえばと思います。
 基本的には、その4時間経ってもゴールしなかった例をそのまま提示ください。

 なお、ご指摘があったように提示されたものの評価をしてもらえばありがたい。
(γ) 2022/01/25(火) 17:21

こんばんは。
遅くなって申し訳ないです。

・背景について
 こちらはある製品の電気回路を数字で示しています。
 各終点はスイッチやランプなどの負荷に該当し、各節点は電気回路の分岐にあたります。
 算出したい距離は各回路の長さに相当します。
 シート2において、同一のStart-Goalが複数回出てくるのはそのためです。
 
 数字で示された回路図が.txt形式で得られますが、
 目で追うのも大変であるためどうにかしたいと考えていました。
 通常の図面もありますが、計算回数が膨大であることと、その分ミスもあるため自動化したいなと。

・最短について

           2   20    21   10 
           |    |     |    |
      1 -- 3 -- 4 -- 32 -- 5  -- 330   
 上記マップにおいて、1→20の経路をたどる際に人が見れば1-3-4-20とたどれると思いますが、
 書き方によっては1-3-2-3-4-20のように2をわざわざ通ることも考えられると思い最短としました。
 回路図であるため、基本的にはループするような図面にはなっていません。
 このへんも前提を詳細に記載していれば誤解を生みませんでしたね。

・処理時間について
 4時間経ってもゴールできなかったのは、私の処理させたマップにミスが会ったからでした。すみません。
 mmさん:1529秒
 tkitさん:0.97秒
 モゲラさん:11.6秒
 γさん:0.02秒

使用したマップは以下です。

シート1
1 300 55
1 301 115
2 300 100
3 302 89
4 305 150
5 329 164
6 326 99
7 331 115
8 332 91
9 371 65
10 336 133
11 336 134
12 372 40
13 340 80
14 343 160
15 343 90
16 345 130
17 345 75
18 310 168
19 348 111
20 348 95
21 348 143
22 350 169
23 302 150
25 354 89
26 352 144
27 352 127
28 359 75
29 359 91
30 359 168
31 362 185
32 362 102
33 361 60
34 310 100
36 364 217
37 364 184
38 368 70
38 369 133
39 319 80
40 320 110
41 320 80
42 320 115
43 320 115
44 322 80
46 324 103
47 324 96
48 365 85
49 365 93
50 348 154
55 320 182
300 410 115
301 300 60
301 303 114
302 301 64
303 302 50
304 303 72
304 307 730
305 304 45
305 325 135
305 395 96
306 53 106
306 305 45
306 333 69
307 306 40
307 309 115
308 307 78
308 344 70
309 308 45
309 311 110
310 309 70
310 361 165
310 397 150
311 373 80
312 311 118
312 315 258
313 312 40
313 400 90
314 400 59
315 314 45
315 317 80
316 315 40
317 316 30
318 317 90
319 318 40
320 319 108
320 391 115
320 404 180
321 320 50
321 323 75
322 321 40
323 322 35
324 323 40
325 326 40
325 327 190
327 326 150
328 327 190
328 330 156
329 328 40
329 330 116
330 7 170
330 331 60
332 331 85
333 334 40
333 335 145
334 335 100
335 336 40
336 9 160
336 371 100
337 334 95
337 339 180
338 12 135
338 337 140
339 338 40
339 341 125
340 339 40
341 340 85
342 341 68
343 342 40
344 345 40
347 310 120
347 349 130
348 347 60
348 392 150
349 348 70
349 351 90
350 349 50
351 350 40
352 351 40
352 353 250
352 399 110
353 354 40
353 355 140
354 355 102
354 398 130
355 24 80
359 399 40
360 310 120
361 360 40
362 361 50
363 313 80
364 363 40
365 366 40
366 306 100
368 369 60
369 314 150
372 338 100
373 310 10
374 305 130
374 375 40
374 395 30
375 51 95
375 52 85
376 377 110
377 384 80
377 393 90
377 403 180
378 377 80
379 377 100
380 377 90
381 377 95
383 377 170
385 384 230
386 384 155
387 384 50
388 387 40
389 388 80
318 388 50

シート2
372 375
373 376
374 377
374 377
374 1
375 378
375 379
399 380
310 381
360 300
1 300
1 301
1 301
2 300
3 302
4 377
5 374

(まる) 2022/01/25(火) 21:18


 お疲れ様でした。

 ところで、提示された元データは、
 ・146のnode
 ・167のedge
 を持った無向グラフということになります。

 この146個のnodeどうしのすべてについて、
 その間の最短経路を計算する方法も知られています。
 Floyd-Warshall法と呼ばれるものらしいです。
 参考までに実装してみました。

 【準備】
 ・Sheet1シートのA:C列にグラフデータを置き、
 ・Sheet2シートを用意し、
 ・下記のコードを標準モジュールにコピーペイストしてください。

 【出力】
 ・main2プロシージャを実行すると、
   Sheet2の
     [G1].Resize(147,147)  に 各node間の最短距離
     [EY1].Resize(147,147) に 各node間の最短経路の長さ
     [KQ1].Resize(147,147) に 各node間の最短経路のパス
  を出力します。
  結果の精査はしていませんが、たぶんいけているのではと思います。
  最長のパスは25個でした。
  25パスのものは何個かありますが、例えば下記。
    46 -> 324 -> 323 -> 321 -> 320 -> 319 -> 318 -> 317 -> 316 -> 315 -> 314 -> 400 -> 
    313 -> 312 -> 311 -> 309 -> 307 -> 306 -> 305 -> 325 -> 327 -> 328 -> 330 -> 331 -> 332 -> 8

  処理時間は0.38秒でした。

 ■参考までにコードを示します。

 Option Explicit
 Rem Floyd-Warshall法による全対最短経路(all pairs shortest paths)

 Dim N       As Long
 Const INF   As Long = 99999    '最大値
 Dim dic     As Object
 Dim dicR    As Object
 Dim dist()  As Long
 Dim nextNode()
 Dim route() As String
 Dim pathLength() As Long

 Dim ws      As Worksheet
 Dim wsOut   As Worksheet

 Sub main2()
     ' Floyd_Warshallアルゴリズムによる全対最短経路
     '(各node間の最短経路をすべて求めること)の算定です。
     Dim t
     t = Timer

     Set ws = Worksheets("Sheet1")       '■必要に応じて修正
     Set wsOut = Worksheets("Sheet2")    '■必要に応じて修正

     Dim i&, j&, k&

     Call setting2    '前提の設定

     ReDim nextNode(1 To N, 1 To N)
     For i = 1 To N
         For j = 1 To N
             nextNode(i, j) = IIf(j <> i, j, 0)
         Next
     Next
     For k = 1 To N
         For i = 1 To N
             For j = 1 To N
                 If dist(i, k) + dist(k, j) < dist(i, j) Then
                     dist(i, j) = dist(i, k) + dist(k, j)
                     nextNode(i, j) = nextNode(i, k)
                 End If
             Next
         Next
     Next

     '最短経路文字列、最短経路の長さの算出
      Call make_route(nextNode)

     '結果表示(各node間の(1)最短距離と、(2)最短経路の長さ、(3)最短経路をシートに表示)
     wsOut.Cells(1, 8).Resize(500, 3 * (N + 2)).ClearContents

     '最短距離
     wsOut.Cells(1, 8).Resize(1, N) = dic.keys
     wsOut.Cells(2, 7).Resize(N, 1) = Application.Transpose(dic.keys)
     wsOut.Cells(2, 8).Resize(N, N) = dist
     wsOut.Cells(1, 8).Resize(1, N).EntireColumn.AutoFit

     '最短経路のedgeの長さ
     wsOut.Cells(1, 8 + N + 2).Resize(1, N) = dic.keys
     wsOut.Cells(2, 8 + N + 1).Resize(N, 1) = Application.Transpose(dic.keys)
     wsOut.Cells(2, 8 + N + 2).Resize(N, N) = pathLength
     wsOut.Cells(1, 8 + N + 2).Resize(1, N).EntireColumn.AutoFit

     '最短経路
     wsOut.Cells(1, 8 + 2 * (N + 2)).Resize(1, N) = dic.keys
     wsOut.Cells(2, 8 + 2 * (N + 2) - 1).Resize(N, 1) = Application.Transpose(dic.keys)
     wsOut.Cells(2, 8 + 2 * (N + 2)).Resize(N, N) = route
     wsOut.Cells(1, 8 + 2 * (N + 2)).Resize(1, N).EntireColumn.AutoFit

     Debug.Print Timer - t; "Floyd-Warshall"
 End Sub

 Function setting2()
     Dim s$, st$, ed$
     Dim p&, j&, k&
     Dim e

     Set dic = CreateObject("Scripting.Dictionary")
     Set dicR = CreateObject("Scripting.Dictionary")

     ' node番号と 整数インデックスとの相互変換をdictionaryに保持
     For Each e In ws.[A1].CurrentRegion.Resize(, 2)
         s = e.Value
         If Not dic.Exists(s) Then
             p = p + 1
             dic(s) = p
             dicR(p) = s
         End If
     Next

     N = dic.Count                       'nodeの数
     ReDim dist(1 To N, 1 To N)           '隣接行列

     'いったん大きい数をセット
     For j = 1 To N
         For k = 1 To N
             dist(j, k) = INF
         Next
     Next
     For j = 1 To N
         dist(j, j) = 0
     Next

     '隣接行列distの作成
     For Each e In ws.[A1].CurrentRegion.Resize(, 1)
         st = CStr(e.Value)
         ed = CStr(e.Offset(, 1).Value)
         dist(dic(st), dic(ed)) = e.Offset(, 2).Value
         dist(dic(ed), dic(st)) = e.Offset(, 2).Value  '無向グラフのため逆方向もセット
     Next
 End Function
 Function make_route(nextNode)
     Dim i&, j&, k&, u&
     Dim path As String
     ' iからj への route の作成
     ReDim route(1 To N, 1 To N) As String
     ReDim pathLength(1 To N, 1 To N) As Long
     For i = 1 To N
         For j = 1 To N
             If i <> j Then
                 u = i
                 path = dicR(i)
                 Do
                     u = nextNode(u, j)
                     path = path & " -> " & dicR(u)
                     If u = j Then
                         Exit Do
                     End If
                 Loop
                 route(i, j) = path
                 pathLength(i, j) = (Len(path) - Len(Replace(path, "->", ""))) / 2
             End If
         Next
     Next
 End Function

 遊びで、GraphVizにグラフを書かせてみました。
 結構きれいなグラフになりました。
 指定した2点間のパスに色を付けるといいかな、などと思いました。
(γ) 2022/01/25(火) 22:47

Floyd-Warshall法をコードにしていただき、ありがとうございました。

指定したノード間をどの回路が通過しているか、
などといった情報を出力することにも利用できそうだなとも思いました。

正確さに関してはまだ確認が取れていませんが、
みなさまからいただいた知恵をもとに実装したいと思います。
(まる) 2022/01/31(月) 18:10


実行時間というよりも、まずは結果の正しさでしょうからね。
もう実行済みかと思っていました。
(γ) 2022/01/31(月) 19:10

まあ、確かに工業製品の製作なので、
見知らぬ人が書いたコードをそのまま使うわけには
いかないかもしれませんね。
何かあっても、あなたが責任を負わないといけなくなりますしね。
 
仮に既存のアルゴリズムを使うだけであっても、
関係者に与える信用というのも大事でしょうから、
それなりにお金を掛けてみてはどうですか?
 
そういう意味では、こうしたところで質問すること自体が
余り良い選択ではなかったでしょう。

(γ) 2022/01/31(月) 20:52


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.