巡回セールスマン問題の考え方を使って最短経路を求める方法について教えてください

質問

• 巡回セールスマン問題の考え方を使って、対象地の14の交差点を最短経路で一筆書きする方法について教えてください。
• プログラムを改良して、スタートが交差点1でゴールが交差点14の場合の最短経路と距離を表示する方法について教えてください。
• 建築の学生ですが、卒論の対象地の分析に巡回セールスマン問題の考え方を使いたいです。どのようにプログラムを変更すればよいか教えてください。

回答No.8

stomachman

Dim nPoint As Integer
Dim dist(20, 20)
Dim route(100) As Integer
Dim minRoute(100) As Integer
Dim visit(20) As Boolean
Dim minMove As Integer
Dim minDistance, minLast
Dim startPoint, goalPoint
Dim initialMinDistance
Dim pregoalpoints

Sub check()
getRoad
Range("minDistance").ClearContents 'just for fun
Range("route").ClearContents 'just for fun
showMinDistance 'just for fun
For j = 1 To nPoint
visit(j) = False
Next j
route(0) = startPoint
route(nPoint - 1) = goalPoint
visit(startPoint) = True
visit(goalPoint) = True
Call search(startPoint, 0, 0, pregoalpoints)
Call putResult
End Sub

Private Sub search(i, distance, move, pregoals)
For jj = i To i + nPoint - 2
j = (jj Mod nPoint) + 1
If (Not visit(j)) And (dist(i, j) > 0) Then
route(move + 1) = j
visit(j) = True
pregoals1 = pregoals
If dist(j, goalPoint) > 0 Then pregoals1 = pregoals - 1
If pregoals1 = 0 And move = nPoint - 3 Then
newDistance = distance + dist(i, j) + dist(j, goal)
If minDistance > newDistance Then
minDistance = newDistance
showMinDistance 'just for fun
For k = 0 To nPoint - 1
minRoute(k) = route(k)
Next k
End If
ElseIf minDistance > distance + dist(i, j) + minLast Then
Call search(j, distance + dist(i, j), move + 1, pregoals1)
End If
visit(j) = False
End If
Next jj
End Sub

Private Sub showMinDistance()
Range("minDistance") = minDistance
End Sub
Private Sub putResult()
If minDistance = initialMinDistance Then
Range("route").Cells(1, 1) = "Not Found"
Exit Sub
End If
showMinDistance
With Range("route")
For k = 0 To nPoint - 1
.Cells(k + 1, 1) = minRoute(k)
Next k
End With
End Sub
Private Sub getRoad()
startPoint = Range("start").Value
goalPoint = Range("goal").Value
nPoint = Range("points").Value
With Range("road")
For i = 1 To nPoint
For j = 1 To nPoint
dist(i, j) = .Cells(i, j).Value
Next j
dist(i, i) = 0
Next i
End With
minDistance = 0
For i = 1 To nPoint
For j = 1 To nPoint
minDistance = minDistance + dist(i, j)
Next j
Next i
pregoalpoints = 0
minLast = minDistance
For j = 1 To nPoint
If dist(j, goalPoint) > 0 Then
pregoalpoints = pregoalpoints + 1
If minLast > dist(j, goalPoint) Then minLast = dist(j, goalPoint)
End If
Next j
If dist(startPoint, goalPoint) > 0 Then pregoalpoints = pregoalpoints - 1
initialMinDistance = minDistance
End Sub

出発点に戻るround tripをやりたい場合には、出発点のコピー（つまり出発点から繋がっている全て交差点Xと、出発点とXの距離と同じ距離で繋がっている交差点）を新たに付け加え、これを到着点として実行すれば良いのです。