WOLFRAM

Wolfram Language & System Documentation Center

Find the Shortest Tour around the World

Plan a tour through every country of the world and visualize it on a map of the globe.

    
Find the shortest path, using CountryData:
Wolfram Language code: SC[{lat_, lon_}] := r {Cos[lon °] Cos[lat °], Sin[lon °] Cos[lat °], Sin[lat °]};
Wolfram Language code: r = 6378.7; places = CountryData["Countries"]; centers = Map[CountryData[#, "CenterCoordinates"]&, places] /. GeoPosition -> Identity; distfun[{lat1_, lon1_}, {lat2_, lon2_}] := VectorAngle[SC[{lat1, lon1}], SC[{lat2, lon2}]]r;
Wolfram Language code: {dist, route} = FindShortestTour[centers, DistanceFunction -> distfun];
Visualize the tour:
Wolfram Language code: surfaceCenters = Map[SC, centers[[route]]];
Wolfram Language code: GreatCircleArc[{lat1_, lon1_}, {lat2_, lon2_}] := Module[{u = SC[{lat1, lon1}], v = SC[{lat2, lon2}], a}, a = VectorAngle[u, v]; Table[Evaluate[RotationTransform[θ, {u, v}][u]], {θ, 0, a, a / Ceiling[10a]}]]
Wolfram Language code: tourLine = Apply[GreatCircleArc, Partition[centers[[route]], 2, 1], {1}];
Wolfram Language code: Graphics3D[{Sphere[{0, 0, 0}, 0.99 r], Map[Line[Map[SC, CountryData[#, "SchematicCoordinates"] /. GeoPosition -> Identity, {-2}]]&, places], {Red, Thick, Line[tourLine]}, {Yellow, PointSize[Medium], Map[Tooltip[Point[SC[CountryData[#, "CenterCoordinates"] /. GeoPosition -> Identity]], #]&, places]}}, Boxed -> False, SphericalRegion -> True]