Skip to main content
added 823 characters in body
Source Link
David
  • 15k
  • 4
  • 47
  • 121

I am wondering about m_goldberg's approach, which works for this situation, but look what happens when I apply it to these points:

pts = {{1, 1}, {1, 2}, {1, 3}, {1, 4}, {1, 5}, {2, 1}, {2, 3}, {2, 
    5}, {3, 1}, {3, 2}, {3, 4}, {3, 5}, {4, 1}, {4, 3}, {4, 5}, {5, 
    1}, {5, 2}, {5, 3}, {5, 4}};
poly = SortBy[pts, ToPolarCoordinates[#][[2]] &];
Graphics[{FaceForm[], EdgeForm[Red], Polygon[poly], PointSize[Large], 
  Point[pts]}]

enter image description here

Whereas:

tour = FindShortestTour[pts];
pts = pts[[Last[tour]]];
Graphics[{
  Line[pts],
  Red, PointSize[Large], Point[pts]
  }]

Produces:

enter image description here

I am wondering about m_goldberg's approach, which works for this situation, but look what happens when I apply it to these points:

pts = {{1, 1}, {1, 2}, {1, 3}, {1, 4}, {1, 5}, {2, 1}, {2, 3}, {2, 
    5}, {3, 1}, {3, 2}, {3, 4}, {3, 5}, {4, 1}, {4, 3}, {4, 5}, {5, 
    1}, {5, 2}, {5, 3}, {5, 4}};
poly = SortBy[pts, ToPolarCoordinates[#][[2]] &];
Graphics[{FaceForm[], EdgeForm[Red], Polygon[poly], PointSize[Large], 
  Point[pts]}]

enter image description here

Whereas:

tour = FindShortestTour[pts];
pts = pts[[Last[tour]]];
Graphics[{
  Line[pts],
  Red, PointSize[Large], Point[pts]
  }]

Produces:

enter image description here

added 1662 characters in body
Source Link
David
  • 15k
  • 4
  • 47
  • 121

Update: Based on Rahul's answer, I was able to do the following. Same start:

sols = Solve[z^8 + (4 Sqrt[3] + 6) z^4 - (4 Sqrt[3] + 7) == 0, z];
pts = {Re[z], Im[z]} /. sols;

Then, Rahul's command:

tour = FindShortestTour[pts] // FullSimplify

Which gave the correct answer for the length of the shortest tour, but it also ordered the points for the shortest tour.

(* {8 Sqrt[2], {1, 2, 3, 4, 5, 6, 7, 8, 9, 1}} *)

So it looks like they were already in the preferred order. Then I did this:

pts = pts[[Last[tour]]]

Which sorted my points (which were already sorted, but added point number one at the end). Then:

Graphics[{
  Line[pts],
  Red, PointSize[Large], Point[pts]
  }]

This produced am image similar to that provided by m_goldberg. Then I worried I wasn't interpreting the sort order properly, so I mixed up the list of points.

pts = {{1/2 (-1 - Sqrt[3]), -(1/2) Sqrt[4 + 2 Sqrt[3]]}, {1/
    2 (1 + Sqrt[3]), -(1/2) Sqrt[4 + 2 Sqrt[3]]},
  {-1, 0}, {0, -1}, {0, 1}, {1, 0}, {1/2 (-1 - Sqrt[3]), 
   1/2 Sqrt[4 + 2 Sqrt[3]]}, {1/2 (1 + Sqrt[3]), 
   1/2 Sqrt[4 + 2 Sqrt[3]]}}

Then:

tour = FindShortestTour[pts] // FullSimplify

Provided this order and the same shortest length:

(* {8 Sqrt[2], {1, 3, 7, 5, 8, 6, 2, 4, 1}} *)

And:

pts = pts[[Last[tour]]];
Graphics[{
  Line[pts],
  Red, PointSize[Large], Point[pts]
  }]

Again produced the same result.

enter image description here

So I hope I am interpreting the FindShortesTour command correctly.

Update: Based on Rahul's answer, I was able to do the following. Same start:

sols = Solve[z^8 + (4 Sqrt[3] + 6) z^4 - (4 Sqrt[3] + 7) == 0, z];
pts = {Re[z], Im[z]} /. sols;

Then, Rahul's command:

tour = FindShortestTour[pts] // FullSimplify

Which gave the correct answer for the length of the shortest tour, but it also ordered the points for the shortest tour.

(* {8 Sqrt[2], {1, 2, 3, 4, 5, 6, 7, 8, 9, 1}} *)

So it looks like they were already in the preferred order. Then I did this:

pts = pts[[Last[tour]]]

Which sorted my points (which were already sorted, but added point number one at the end). Then:

Graphics[{
  Line[pts],
  Red, PointSize[Large], Point[pts]
  }]

This produced am image similar to that provided by m_goldberg. Then I worried I wasn't interpreting the sort order properly, so I mixed up the list of points.

pts = {{1/2 (-1 - Sqrt[3]), -(1/2) Sqrt[4 + 2 Sqrt[3]]}, {1/
    2 (1 + Sqrt[3]), -(1/2) Sqrt[4 + 2 Sqrt[3]]},
  {-1, 0}, {0, -1}, {0, 1}, {1, 0}, {1/2 (-1 - Sqrt[3]), 
   1/2 Sqrt[4 + 2 Sqrt[3]]}, {1/2 (1 + Sqrt[3]), 
   1/2 Sqrt[4 + 2 Sqrt[3]]}}

Then:

tour = FindShortestTour[pts] // FullSimplify

Provided this order and the same shortest length:

(* {8 Sqrt[2], {1, 3, 7, 5, 8, 6, 2, 4, 1}} *)

And:

pts = pts[[Last[tour]]];
Graphics[{
  Line[pts],
  Red, PointSize[Large], Point[pts]
  }]

Again produced the same result.

enter image description here

So I hope I am interpreting the FindShortesTour command correctly.

edited tags
Link
m_goldberg
  • 108.1k
  • 16
  • 104
  • 259
Source Link
David
  • 15k
  • 4
  • 47
  • 121
Loading