OKWAVEのAI「あい」が美容・健康の悩みに最適な回答をご提案!
-PR-
解決
済み

巡回セールスマン問題の考え方を使って・・・。

  • すぐに回答を!
  • 質問No.171752
  • 閲覧数401
  • ありがとう数11
  • 気になる数0
  • 回答数12
  • コメント数0

お礼率 73% (231/315)

以前、この場で巡回セールスマン問題の考え方を使って、ということで質問に答えていただきました。その節はありがとうございました。
建築の学生なのですが、卒論の対象地の一つの分析として次のようなことを行っております。

対象地に14の交差点があって
「14の交差点全てを一筆書きで、最短経路で通過したい。」
ということをやるようになってます。
これに関して数人の方の協力でプログラムを組んでもらいました。
 
現在のプログラムはスタートのみ固定して、14それぞれ最短経路を探索し、ルートと最短距離を表示します。

今度はこれを、スタートとゴールともに固定して
「スタートが交差点1で、ゴールが交差点14のとき
 ルートは・・。最短距離は何m。」

というふうに表示させたいのですが、プログラムに関して私はまったく素人でどのように変更すればよいかわかりません。
そこで、どのように改良すればよいか教えていただけないでしょうか。
よろしくお願いします。
通報する
  • 回答数12
  • 気になる
    質問をブックマークします。
    マイページでまとめて確認できます。

質問者が選んだベストアンサー

  • 回答No.12
レベル14

ベストアンサー率 57% (1014/1775)

No.11訂正です。名前がだぶっちゃってますね。

> routeに沿った各交差点間の距離の表示をしたいのなら、routeのたとえば
> 右隣に20行1列のエリア"road"を作り、関数putResultの末尾に
> With Range("road")

この"road"は全部別の名前、例えば"length"に訂正!!

(ひとりで10回以上回答してしまった。アホですね。)
お礼コメント
nintai

お礼率 73% (231/315)

stomachmanさん本当にありがとうございました。

卒論の作業でお礼をするのが遅くなってしまいました。
投稿日時 - 2001-11-28 11:28:01
-PR-
-PR-

その他の回答 (全11件)

  • 回答No.4
レベル14

ベストアンサー率 57% (1014/1775)

おっとと、見落とし。 今度の問題では、スタートとゴールも指定するのでした。単に最短経路を求めるのではなく、他の全部の交差点も通過しなくちゃいけなくて、しかも一度通った道は通らない。こういう条件ですね。 めんどくさいから、一応テストした上でまるごとupします。ちょっと待っててね。
おっとと、見落とし。
今度の問題では、スタートとゴールも指定するのでした。単に最短経路を求めるのではなく、他の全部の交差点も通過しなくちゃいけなくて、しかも一度通った道は通らない。こういう条件ですね。

めんどくさいから、一応テストした上でまるごとupします。ちょっと待っててね。

  • 回答No.3
レベル14

ベストアンサー率 57% (1014/1775)

文法エラーのことですか。だったら、 Range("route")と .Cells(1, 1)の間にスペースが挟まっているせいです。スペースを消せば良いはず。
文法エラーのことですか。だったら、
Range("route")と .Cells(1, 1)の間にスペースが挟まっているせいです。スペースを消せば良いはず。
  • 回答No.2
レベル14

ベストアンサー率 57% (1014/1775)

交差点を通る一筆書きでしたか。使わない道があっても良いのですね。 だとすれば、「片道を通ると、その帰り道も使えなくなる」という条件を入れてやるだけです。 つまり、No.147691の回答No.4のプログラムを少し手直しするだけです。 まず関数Private Sub search(i, distance, move) の中で available(i, j) = False となっている部分を ...続きを読む
交差点を通る一筆書きでしたか。使わない道があっても良いのですね。
だとすれば、「片道を通ると、その帰り道も使えなくなる」という条件を入れてやるだけです。

つまり、No.147691の回答No.4のプログラムを少し手直しするだけです。
まず関数Private Sub search(i, distance, move) の中で
available(i, j) = False
となっている部分を
available(i, j) = False : available(j,i) = False
に、変え、また
available(i, j) = True
となっている部分を
available(i, j) = True : available(j,i) = True
に変えます。

それからね、解がない場合があり得ますから、プログラムの先頭に
グローバル変数
Dim intialMinDistance
を付け加え、関数Private Sub getRoad() の最後に
intialMinDistance=minDistance
End Sub
として、初期値を記録しておきます。そうして、Private Sub putResult() において、最初に
if minDistance = initialMinDistance then
Range("route") .Cells(1, 1) = "Not Found"
exit sub
end if
を追加して、解が無かったことを表示させます。

あとは一緒。No.147691より探索はずっと早く終わるでしょう。
今回はテストしてません。
お礼コメント
nintai

お礼率 73% (231/315)

いつも本当にありがとうございます。
以下のところでエラーが出ます。
Range("route") .Cells(1, 1) = "Not Found"

特におかしな事はした覚えがないのですが。
身近な人にも聞いてますが、もしも原因にお気づきになったら教えてくれると大変うれしいのですが・・

ありがとうございます。
投稿日時 - 2001-11-22 12:20:31
  • 回答No.1
レベル13

ベストアンサー率 61% (647/1050)

    一体、どういうプログラムを組んでおられるのか、また、「以前、この場で巡回セールスマン問題の考え方を使って、ということで質問」というのも、どういう質問かわかりませんので、考えようがないのですが、何か考えてみます。     まず、どういうプログラムを作ってもらったかによって、回答は当然変化します、というより、プログラムが分からないと答えようがないとも言えます。そこで、どういう解法プログラムなのか ...続きを読む
 
  一体、どういうプログラムを組んでおられるのか、また、「以前、この場で巡回セールスマン問題の考え方を使って、ということで質問」というのも、どういう質問かわかりませんので、考えようがないのですが、何か考えてみます。
 
  まず、どういうプログラムを作ってもらったかによって、回答は当然変化します、というより、プログラムが分からないと答えようがないとも言えます。そこで、どういう解法プログラムなのかを想定で考えてみます。
 
  問題はグラフ問題です。従って、基本データとして、交差点とそのあいだを繋ぐ道路の接続状態と、距離のデータが入っているはずです。どういう形で入れているのか分かりませんが、14の交差点について、その交差点の次に続く交差点は何か、そこまでの距離は幾らかというのが情報として入っているのだと思います。14の交差点について、一回のステップ情報だけで十分です。帰路の情報は、繋がる相手の交差点の側にも情報として入っているからです。これでグラフの構造が記述されるでしょう。
 
  そこで、一筆書きで最短距離というのは、恐らく、或る出発点を選ぶと、まず、そこから分岐する交差点へと分岐し、更に、次の交差点へと分岐するという形で、あらゆる可能性を試行しているのだと思えます。その場合、通過した交差点へともう一度進もうとする選択=分岐は、ふるい落とすようにプログラムしてあるのでしょう。こうして、最終的に全部の交差点を通過する一筆の経路の存在が得られると、その結果で、距離が最短のものを解として出すように、プログラムされているのでしょう。
 
  もしこういうプログラムなら、問題は簡単で、距離が最短のものを最後に選び出すのではなく、1から始めれば、最後が14になる解があれば、それを選び、そのなかの最短距離のものを選び、それを解として出すようにプログラムに微修正を加えれば可能となるはずです。
 
  この場合、解がない場合が起こるでしょう。
  取りあえず、解法プログラムを想定しての話で、こういうアルゴリズムのプログラムでない場合、以上の話は無意味です。
 
お礼コメント
nintai

お礼率 73% (231/315)

まずは、ありがとうございます。
文字数が足りなくてプログラムをのせることができませんでした。
プログラムは以下のとおりで、2通りあります。
ひとつは一巡探索、ひとつは一筆探索です。
今、プログラムの改良をはかっているのは一筆探索の方です。
starfloraさんがおっしゃっていた基本データはExcel上で、14×14の正方行列の表の中に
「交差点1から5までの距離が45m」なら1行5列のセルに45を記入しており、すべてのセルがうまってます。(もちろん1行1列などは空白です。)

他に説明不足なところがありましたらご指摘ください。
改良できそうでしょうか?よろしくお願いします。



Option Explicit

Public nPoint As Integer '交差点の数
Public dist(20, 20) As Integer '距離を入れておくテーブル
Public availRoad(20, 20) As Boolean '片道通過可能テーブル 既に通ったかどうかを記録
Public availPoint(20) As Boolean '交差点通過可能配列 交差点を既に通ったかどうかを記録
Public checkPoint(20) As Integer '交差点通過回数配列
Public move As Integer '現在作りかけの経路の通過する交差点の延べ数
Public route(50) As Integer '現在作りかけの経路
Public distance As Integer '現在作りかけの経路の距離
Public minRoute(50) As Integer 'これまでに見つかった最短経路
Public minMove As Integer 'これまでに見つかった最短経路の通過する交差点の延べ数
Public minDistance As Integer 'これまでに見つかった最短経路の距離
Public startPt As Integer '出発交差点

'一筆経路探索(一度通過した交差点は通らない)
Sub SearchMove()
Dim startStt As Integer '出発点の開始交差点番号
Dim StartEnd As Integer '出発点の終了交差点番号


ShowMsg "一筆探索 実行中" 'メッセージ表示

ClearResult '結果削除

GetRoadTable '道のデータを読み取る。

ClearAvailablePoint '通行可能交差点初期設定

'検索
GetStartPoint startStt, StartEnd '出発点の範囲取得
minDistance = 30000 '大きな数値を入れておく

For startPt = startStt To StartEnd
ShowMsg "一筆探索 実行中 出発点" + str(startPt)
availPoint(startPt) = False '出発点通過するので通過不可能にする
route(1) = startPt 'ルートの履歴設定
SearchMoveRepeat startPt, 0, 1 '出発点startPtから経路検索
availPoint(startPt) = True '通過可能に戻す
Next
'結果表示
ShowResult

'メッセージ表示
ShowMsg "一筆探索 終了"

End Sub

'一巡経路探索(出発点へ戻る。一度通過した方向の道は通らない)
Sub SearchReturn()
Dim startStt As Integer '出発点の開始交差点番号
Dim StartEnd As Integer '出発点の終了交差点番号


ShowMsg "一巡探索 実行中" 'メッセージ表示

ClearResult '結果削除

GetRoadTable '道のデータを読み取る。

ClearAvailableRoad '通行可能片道初期設定 & 通過交差点初期設定

'検索
GetStartPoint startStt, StartEnd '出発点の範囲取得
minDistance = 30000 '大きな数値を入れておく
For startPt = startStt To StartEnd
ShowMsg "一巡探索 実行中 出発点" + str(startPt)
route(1) = startPt 'ルートの履歴設定
checkPoint(startPt) = 1 '出発点1回通過済み
SearchReturnRepeat startPt, 0, 1 '出発点startPtから経路検索
checkPoint(startPt) = 0 '出発点を未通過に戻す
Next
'結果表示
ShowResult

'メッセージ表示
ShowMsg "一巡探索 終了"

End Sub


'一筆経路探索(一度通過した交差点は通らない)
'現在交差点curPtに居て、作りかけの経路の距離はdistance、既に交差点move個を通過した。
Private Sub SearchMoveRepeat(curPt As Integer, distance As Integer, move As Integer)
Dim branch As Integer '分岐
Dim nextPt As Integer '次交差点
Dim k As Integer

For branch = 1 To nPoint - 1
nextPt = (curPt + branch - 1) Mod nPoint + 1 '次交差点番号
If availPoint(nextPt) Then '次交差点通過可能の場合
If minDistance > distance + dist(curPt, nextPt) Then '現在の最短距離を越えたら、その先を調べる必要なし。
availPoint(nextPt) = False '次交差点を通過するので通過不可能にする
route(move + 1) = nextPt 'ルートの履歴設定
If move + 1 < nPoint Then 'まだ全交差点を回っていない
SearchMoveRepeat nextPt, distance + dist(curPt, nextPt), move + 1 '経路を延ばす。
Else '全交差点を回っている場合最短記録更新。
minDistance = distance + dist(curPt, nextPt) '全距離
minMove = move + 1 '全交差点数
For k = 1 To minMove '全ルート履歴
minRoute(k) = route(k)
Next
ShowResult '結果表示
End If
availPoint(nextPt) = True '前の交差点に戻るので,通過可能に戻す
End If
End If
Next
End Sub

'一巡経路探索(出発点へ戻る。一度通過した方向の道は通らない)
'現在交差点curPtに居て、作りかけの経路の距離はdistance、既に交差点move個を通過した。
Private Sub SearchReturnRepeat(curPt As Integer, distance As Integer, move As Integer)
Dim branch As Integer '分岐
Dim nextPt As Integer '次交差点
Dim k As Integer

For branch = 1 To nPoint - 1
nextPt = (curPt + branch - 1) Mod nPoint + 1 '次交差点番号
If availRoad(curPt, nextPt) Then '次交差点片道が通過可能の場合
If minDistance > distance + dist(curPt, nextPt) Then '現在の最短距離を越えたら、その先を調べる必要なし。
availRoad(curPt, nextPt) = False '次交差点への片道を通過するので通過不可能にする
checkPoint(nextPt) = checkPoint(nextPt) + 1 '次交差点の通行回数を増加する
route(move + 1) = nextPt 'ルートの履歴設定
If Not CheckAllPoint(move) Then 'まだ全交差点を回っていない
If nextPt <> startPt Then '次交差点が出発点でない(全交差点未周回で出発点にもどると打ち切り)
SearchReturnRepeat nextPt, distance + dist(curPt, nextPt), move + 1 '経路を延ばす。
End If
Else '全交差点を回っている場合,出発点を加える
If minDistance > distance + dist(curPt, nextPt) + dist(nextPt, startPt) Then '現在の最短距離を越えたら、その先を調べる必要なし。
'最短記録更新。
route(move + 2) = startPt 'ルートの最後に出発点設定
minDistance = distance + dist(curPt, nextPt) + dist(nextPt, startPt)
minMove = move + 2
For k = 1 To minMove
minRoute(k) = route(k)
Next
ShowResult '結果表示
End If
End If
availRoad(curPt, nextPt) = True '前の交差点に戻るので,通過可能に戻す
checkPoint(nextPt) = checkPoint(nextPt) - 1 '前の交差点に戻るので,通過回数を戻す
End If
End If
Next
End Sub

'全交差点を通過したかどうか。
Private Function CheckAllPoint(move As Integer)
Dim i As Integer
Dim pass As Integer '通過交差点数

CheckAllPoint = False
If move + 1 < nPoint Then Exit Function '交差点の通過数が全交差点数以下なら絶対無理

pass = 0
For i = 1 To nPoint
If checkPoint(i) > 0 Then pass = pass + 1 '通過済み交差点のカウント
Next

CheckAllPoint = (pass = nPoint) '通過済み交差点数が全交差点数と等しい
End Function

'道のデータを読み取る。
Private Sub GetStartPoint(startStt As Integer, StartEnd As Integer)
Dim stt As Integer '指定出発点番号

stt = Range("start")
If stt = 0 Then
startStt = 1
StartEnd = nPoint
Else
startStt = stt
StartEnd = stt
End If
End Sub

'道のデータを読み取る。
Private Sub GetRoadTable()
Dim i As Integer
Dim j As Integer

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
Next
End With
End Sub

'通行可能交差点初期設定
Private Sub ClearAvailablePoint()
Dim i As Integer

For i = 1 To nPoint
availPoint(i) = True
Next
End Sub

'通行可能片道初期設定 & 通過交差点初期設定
Private Sub ClearAvailableRoad()
Dim i As Integer
Dim j As Integer

For i = 1 To nPoint
checkPoint(i) = False '最初は全交差点未通過
For j = 1 To nPoint
availRoad(i, j) = dist(i, j) > 0 '片道に距離が設定されていたらTrue
Next
Next
End Sub

'結果を削除
Private Sub ClearResult()
Dim k As Integer

Range("minDistance").Clear
With Range("route")
For k = 1 To 20
.Cells(k, 1).Clear
Next k
End With
End Sub

'結果を表示
Private Sub ShowResult()
Dim k As Integer

Range("minDistance").Value = minDistance
With Range("route")
For k = 1 To minMove
.Cells(k, 1).Value = minRoute(k)
Next k
.Range(Cells(minMove + 1, 1), Cells(minMove * 2, 1)).Value = ""
End With
End Sub

'メッセージを表示
Private Sub ShowMsg(msg As String)
Range("message").Value = msg
End Sub
投稿日時 - 2001-11-20 20:41:35
  • 回答No.5
レベル14

ベストアンサー率 57% (1014/1775)

ひょっとして、 「同じ交差点に2度来ちゃいけない」なんて条件がついてたりは、まさかしませんよね。それだとまた話が違うので。 ...続きを読む
ひょっとして、

「同じ交差点に2度来ちゃいけない」なんて条件がついてたりは、まさかしませんよね。それだとまた話が違うので。
お礼コメント
nintai

お礼率 73% (231/315)

ありがとうございます。
「一筆書き」と書いたのですが、ニュアンスが伝わっていなかったでしょうか?
まさに指摘されたとおり「同じ交差点に2度来ちゃいけない」という条件で
す。組んでもらったプログラムはそうなっているはずです。

テストまでしていただいたのに大変申し訳ないのですが・・
投稿日時 - 2001-11-22 17:48:23
  • 回答No.6
レベル14

ベストアンサー率 57% (1014/1775)

No.5を前提として。 No.147691の回答No.4のプログラムにおいて、worksheetに"start"という名前のcellと、"goal"という名前のcellを追加し、そこに出発点とゴールの交差点の番号を入力して、実行。 今度は一応テストしましたよ。 Dim nPoint As Integer Dim dist(20, 20) Dim a ...続きを読む
No.5を前提として。

No.147691の回答No.4のプログラムにおいて、worksheetに"start"という名前のcellと、"goal"という名前のcellを追加し、そこに出発点とゴールの交差点の番号を入力して、実行。
今度は一応テストしましたよ。

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

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

Private Sub search(i, distance, move)
For jj = i To i + nPoint - 2
j = (jj Mod nPoint) + 1
goon = available(i, j) And (dist(i, j) > 0)
' If goon Then
' If visit(i) > 1 And move > 0 Then
' goon = (route(move - 1) <> j)
' End If
' End If
If goon Then
available(i, j) = False: available(j, i) = False
route(move + 1) = j
visit(j) = visit(j) + 1
If minDistance > distance + dist(i, j) Then
If roundTrip(move + 1) Then
minDistance = distance + dist(i, j)
showMinDistance 'just for fun
minMove = move + 1
For k = 0 To minMove
minRoute(k) = route(k)
Next k
Else
Call search(j, distance + dist(i, j), move + 1)
End If
End If
available(i, j) = True: available(j, i) = True
visit(j) = visit(j) - 1
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 minMove
.Cells(k + 1, 1) = minRoute(k)
Next k
.Cells(minMove + 2, 1) = ""
End With
End Sub

Private Function roundTrip(m)
rountTrip = False
If m < nPoint Then Exit Function
If route(m) <> goalPoint Then Exit Function
For kk = 1 To nPoint
If visit(kk) = 0 Then Exit Function
Next kk
roundTrip = True
End Function

Private Sub getRoad()
startPoint = Range("start").Value
goalPoint = Range("goal").Value
minDistance = 0
nPoint = Range("points").Value
With Range("road")
For i = 1 To nPoint
For j = 1 To nPoint
dist(i, j) = .Cells(i, j).Value
minDistance = minDistance + dist(i, j)
Next j
Next i
End With
initialMinDistance = minDistance
End Sub

Private Sub clearAvailable()
For i = 1 To nPoint
For j = 1 To nPoint
available(i, j) = (dist(i, j) > 0)
Next j
Next i
End Sub
お礼コメント
nintai

お礼率 73% (231/315)

「一筆書き」と書いたのですが、ニュアンスが伝わっていなかったでしょうか?
まさに指摘されたとおり「同じ交差点に2度来ちゃいけない」という条件で
す。組んでもらったプログラムはそうなっているはずです。

また僕のパソコンが遅いのかわかりませんが、交差点数が14になると大変時間がかかるようです。
stomachman さんはどれくらいで終わるのでしょうか?
投稿日時 - 2001-11-22 17:50:45
  • 回答No.10
レベル14

ベストアンサー率 57% (1014/1775)

>点はすべて観光スポットです ということで構わないのであれば、ま、宜しいでしょう。  本気でやれば、距離じゃなく所要時間、それも時間帯によって変化する、など非常に複雑な問題になっちゃいますね。    何にせよ、意図を正確に表現なさることは、建築・都市計画など、「ひとりじゃ何もできない」分野では特に重要かと…いや、これは余計なお節介でした。  細かい事ながら、No.8のPrivate S ...続きを読む
>点はすべて観光スポットです
ということで構わないのであれば、ま、宜しいでしょう。
 本気でやれば、距離じゃなく所要時間、それも時間帯によって変化する、など非常に複雑な問題になっちゃいますね。
 
 何にせよ、意図を正確に表現なさることは、建築・都市計画など、「ひとりじゃ何もできない」分野では特に重要かと…いや、これは余計なお節介でした。

 細かい事ながら、No.8のPrivate Sub search(i, distance, move, pregoals)の中の
ElseIf minDistance > distance + dist(i, j) + minLast Then

ElseIf pregoals1 > 0 And minDistance > distance + dist(i, j) + minLast Then
にした方がちょびっと速い。
お礼コメント
nintai

お礼率 73% (231/315)

おっしゃるとおりです。実際、先生には大変迷惑かけてる学生です。

組んでもらったプログラムではExcelのシート上で

B18 message (終了のメッセージを表示させる)
B19   points(交差点数)
B20   start (出発点をいれる)
B21   minDistance (最小距離)
B23~O23 route(ルートが表示される) 
B2 ~O15 road (距離の行列表)

というようにセルに名前をつけてました。
stomachmanさんにつくっていただいたプログラムの場合はどのように名前をつければいいいのでしょうか?
そこのところが、すいませんよくわかりませんでした。
投稿日時 - 2001-11-23 22:10:38
  • 回答No.9
レベル14

ベストアンサー率 57% (1014/1775)

No.7のコメントを見て、まだ、正しく問題が定義されていないらしいことがわかりました。はじめっから、何やりたいか仰っていただけば良かったのですが… ●点には2種類あります。観光地と通過点です。観光地は全部、丁度1度づつ通りたい。通過点は何度通っても良いし、1度も通らないものがあってもよい。  道は何度通っても良いし、一度も通らないものがあっても良い。なお、2つの点を結ぶ道が2つ以上ある場合には短い ...続きを読む
No.7のコメントを見て、まだ、正しく問題が定義されていないらしいことがわかりました。はじめっから、何やりたいか仰っていただけば良かったのですが…

●点には2種類あります。観光地と通過点です。観光地は全部、丁度1度づつ通りたい。通過点は何度通っても良いし、1度も通らないものがあってもよい。
 道は何度通っても良いし、一度も通らないものがあっても良い。なお、2つの点を結ぶ道が2つ以上ある場合には短い方だけを使えばよいので、長い方は初めから除いておきます。

こういう条件じゃないでしょうか。だとすると、またしてもNo.8のアルゴリズムは落第ということになりますが…
お礼コメント
nintai

お礼率 73% (231/315)

本当にありがとうございます。
ご指摘されましたが、
点はすべて観光スポットです、つまりそれら14地点はちょうど1度づつ通り、
2度通ってはいけない。という条件です。
「何度も通ってもよい点」はありません。

図で説明したいのですが、できないようなのでこれで私の意図はつたわったでしょうか?
投稿日時 - 2001-11-23 18:28:27
  • 回答No.8
レベル14

ベストアンサー率 57% (1014/1775)

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 ...続きを読む
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の距離と同じ距離で繋がっている交差点)を新たに付け加え、これを到着点として実行すれば良いのです。
  • 回答No.7
レベル14

ベストアンサー率 57% (1014/1775)

えと。ご質問の正確な意味を確認したいと思います。 (1) 交差点同士を道で繋いだ地図がある。道にはそれぞれ「距離」が対応づけられている。 (2) 交差点のうち、出発点sと到着点g(s≠g)が指定されている。 (3) sからgへの経路であって、全ての交差点を丁度1度づつ通る経路のうちで、最短距離であるものを求めるアルゴリズムは? こういうご質問ですか? だとすれば、ここまでの回答は全部間違 ...続きを読む
えと。ご質問の正確な意味を確認したいと思います。

(1) 交差点同士を道で繋いだ地図がある。道にはそれぞれ「距離」が対応づけられている。
(2) 交差点のうち、出発点sと到着点g(s≠g)が指定されている。
(3) sからgへの経路であって、全ての交差点を丁度1度づつ通る経路のうちで、最短距離であるものを求めるアルゴリズムは?

こういうご質問ですか?
だとすれば、ここまでの回答は全部間違いです。

 普通、一筆書きといいますと、
(1)どの道も一度しか通ってはならない。そして
(2)全ての道を通らねばならない。
そういう経路を求めよ、という意味ですぜ。(同じ交差点を何度通っても良いんですよ。 ∞ という図形を一筆書きしろと言われたら、交差点をどうしても2度通るでしょ?)
 ご質問の場合「最短距離」を求めようというのですから、上記の2条件のうち(2)は外して考えるしかないと解釈いたしました結果が、これまでの回答です。全部はずれ。

 という訳で、はじめからやりなおしです。もうちょっと待ってね。
お礼コメント
nintai

お礼率 73% (231/315)

stomachmanさん。こんなに丁寧に付き合ってくれて本当にありがとうございます。
まさにご指摘とおりです。
私の説明が本当に不十分ですいませんでした。
一筆書きが同じ交差点を何度通ってもいいとは知りませんでした。そうです。私の意図は、同じ交差点は二度通ってはいけないという条件下における経路探索です。
というのも観光ルート的なものを提案するのが目的なので。
待ちます。よろしくお願いします。
投稿日時 - 2001-11-23 13:21:07
11件中 1~10件目を表示
このQ&Aで解決しましたか?
関連するQ&A
-PR-
-PR-
このQ&Aにこう思った!同じようなことあった!感想や体験を書こう
このQ&Aにはまだコメントがありません。
あなたの思ったこと、知っていることをここにコメントしてみましょう。

その他の関連するQ&A、テーマをキーワードで探す

キーワードでQ&A、テーマを検索する
-PR-
-PR-
-PR-

特集


いま みんなが気になるQ&A

関連するQ&A

-PR-

ピックアップ

-PR-
ページ先頭へ