Грешно изчисление с FindShortestTour / Wolfram

[go6aih]

Проблема е, че програмата дава очевидно грешно изчисление, а допълнително и чертежа не ми излиза правилно. Кода е следния:
Clear All;
n = Input[n];
p = RandomInteger[100, {n, 2}]
FindShortestTour[p]
Graphics[{Arrow [p], PointSize[Large], Red, Point[p]}, Frame -> True]
Задачата е:
Търговски пътник трябва да посети всеки град и да се върне в града от който е тръгнал, като сумарно измине най- кратък път.Като се използва алгоритъм за най- близкия съсед- тръгвайки от един град се преминава в най- близкия, от него в най- близкия и т.н.
Мислех допълнително да добавя към общия път и пътя от последната точка до първата...
Ако се вкарват ръчно точките p = {{2, 34}, {20, 2}, {19, 17}, {38, 1}}, защо ги чертае така...

[go6aih]

Чертае правилно, но изходната матрица. За да изчертае обхождането трубва да е така :
Clear All;
n = Input[n];
mat = RandomInteger[100, {n, 2}]
N[fst = FindShortestTour[mat]]
por = fst[[2]] // MatrixForm;
nmat = mat[[por[[1]]]]
Graphics[{Arrow [nmat], PointSize[Large], Red, Point[nmat]},
Frame -> True]
Проблемите са два: 1- понякога дава очевидно грешно решение и 2- трябва да отива ВИНАГИ до следващия НАЙ-БЛИЗЪК град.
Дайте някакви идеи...

[go6aih]

По-скоро трябва де е нещо такова:

Clear All;
n = 4;
mat = {{25, 25}, {10, 20}, {8, 9}, {25, 10}}
" CICLE "
nearX = Nearest[mat]
k1 = nearX[[2, 1]];
k2 = nearX[[2, 2]];
k11 = k1 - 1;
k12 = k1 + 1;
Which[k12 == n, mat1 = mat[[;; n - 2, n]], k12 > n,
mat1 = mat[[;; n - 1]], k12 < n, mat1 = mat[[;; k11, k12 ;;]]]
NEAR = mat[[k1]]

И нататък да се развие цикъл до n като в NEAR се добавят новите най-близки, а изчертаването ще е лесно след това...

[go6aih]

За да не е грешно :
Clear All;
n = 5
p = N[{{4, 9}, {3, 0}, {8, 8}, {3, 4}, {3, 3}}]
b = N[FindShortestTour[p]]
f = p[[b[[2]]]]
Graphics[{Line[p[[b[[2]]]]], PointSize[Large], Red,
Point[p[[b[[2]]]]]}, Frame -> True]
Отговорът е:
{22.6561, {1., 3., 2., 5., 4.}}

Ако 3-и ред е:
p = {{4, 9}, {3, 0}, {8, 8}, {3, 4}, {3, 3}}
Отговорът е:
{23.2932, {1., 3., 5., 2., 4.}}

Защо е така- не знам и няма да търся...
и без друго си пиша сам, но съм сигурен , че има някаква връзка с EuclideanDistance...
Сега ще търся решението за FindShortestTour...

[go6aih]

ClearAll;
"Курсова задача №2
Задача за търговския пътник"
"ПРОБА;
n=6;
mat=N[{{0,0},{3,0},{5,1},{3,1},{6,0},{5,0},{6,8},{6,4}}]";
Горните 3 реда са за проба като махнеш "" от началото и края
и ги сложиш на долните 3 реда можеш да провериш че задачата работи правилно
горните точки са така подбрани че да показват правилността изчисленията в задачата
n = Input[n]; брой на генерираните точки(имат вида {5,0}т.е. двойка числа)
If[n < 10, n = Input[n]] проверка дали числата са повече от 10
mat = N[RandomInteger[100, {n, 2}]] генерира матрица с n числа от 0 100
x = mat[[1]]; взимам І-я елемент
NEAR = x; правя нова матрица NEAR
mat1 = mat[[2 ;;]]; от матрицата mat правя нова матрица mat1 без І-я елемент на mat
nearX = Nearest[mat1, x]; намирам най-близката до х точка от матрица mat1
x = nearX[[1]]; замествам старата х с новата точка nearX
p = EuclideanDistance[x, NEAR]; изчислявам разстоянието от новата х до старата х
pat = 0; въвеждам променлива pat за сумата на пътя
pat += p; сумата на пътя
NEAR = Append[{NEAR}, x]; допълвам матрица NEAR с новата точка х
w = Count[mat1, _Real, Infinity]; смятам броя елементи на mat1
w = w/2; смятам броя елементи на mat1
t = Position[mat1, x]; намирам позицията на х в матрица mat1
t = t[[1, 1]]; намирам позицията на х в матрица mat1
While[w > 1, Правя цикъл - Докато w > 1
{If[w >= 3, Ако w >= 3
{mat1 = Drop [mat1, {t, t}]; правя нова матрица mat1 от старата матрица mat1 без елемента х
nearX = Nearest[mat1, x]; намирам най-близката до х точка от матрица mat1
x = nearX[[1]]; замествам старата х с новата точка nearX
t = Position[mat1, x]; намирам позицията на х в матрица mat1
t = t[[1, 1]]; намирам позицията на х в матрица mat1
p = EuclideanDistance[x, NEAR[[-1]]]; изчислявам разстоянието от новата х до старата х
pat += p; сумата на пътя+разстоянието от новата х до последната х
NEAR = Append[NEAR, x]; допълвам матрица NEAR с новата точка х
w = w - 1; намалявам w с 1
}]; оттук до IF по-горе е тялото на IF-a
IF-a се изпълнява докато w>2 поради по-долните редове
При w == 2 се изпълнява долният If
If[w == 2, {Which[t == 2, x1 = mat1[[1]], t == 1, x1 = mat1[[2]]];
Which[t == 1, mat1 = mat1[[1]], t == 2, mat1 = mat1[[2]]];
като останат 2 елемента в матрица mat1 ги взимам поред по близост
p = EuclideanDistance[mat1, x]; изчислявам разстоянието от новата х(mat1) до старата х
pat += p; сумата на пътя+разстоянието от новата х до последната х
NEAR = Append[NEAR, mat1]; допълвам матрица NEAR с новата точка х
p = EuclideanDistance[mat1, x1]; изчислявам разстоянието от новата х до старата х
pat += p; сумата на пътя+разстоянието от новата х до последната х
NEAR = Append[NEAR, x1]; допълвам матрица NEAR с новата точка х
Break[]; Прекъсвам цикъла
}]}];
p = EuclideanDistance[NEAR[[-1]], NEAR[[1]]]; изчислявам разстоянието от последната х до
първата х(началото на пътя)
pat += p; сумата на пътя+разстоянието от последната х до първата х
"дължина на ЦЕЛИЯТ ПЪТ с връщане в нач.точка"
pat показвам целият път
"последователност на точките"
NEAR показвам последователността на точките
Graphics[{Arrow [NEAR], PointSize[Large], Red, Point[NEAR]},
Frame -> True] изчертавам пътя, със стрелка е последната точка

Ето го решението, ето го обяснението...Благодаря на всички за помощта...