# Shortest Tour Subject to A Condition

Say I have a list of cities

cities = {"Istanbul", "Moscow", "London", "Saint Petersburg",
"Berlin", "Madrid", "Kyiv", "Rome", "Bucharest", "Paris", "Minsk",
"Vienna", "Warsaw", "Hamburg", "Budapest", "Belgrade", "Barcelona",
"Munich", "Kharkiv", "Milan", "Kazan", "Sofia", "Prague",
"Tbilisi", "Samara", "Ufa", "Birmingham", "Cologne", "Voronezh",

coordinates = GeoPosition[ CityData[#, "Coordinates"]] & /@ cities;
country = CityData[#, "Country"] & /@ cities;

GeoListPlot[coordinates]

I want to travel to every country. I don't need to travel to every city but I'm happy travelling to multiple cities in a country.

I don't see an obvious way to write this condition using FindShortestTour[]

For example,

tour = FindShortestTour[coordinates];
GeoGraphics[{Thick, Red, GeoPath[coordinates[[tour[[2]]]]]}]

I can run all the permutations - but this seems silly. Is there a way to tell FindShortestTour[] to optimise something else?

• I'm pretty confident that if you want a shortest tour with at least one city per country, that in practice means exactly one city per country. I guess this would be a binary-valued linear programming problem with constraints in practice? Apr 22, 2023 at 16:45
• The original task was to incorporate vertices of different length linking the cities - but I simplified it for this case. I agree - no need to go to different cities.
– Tomi
Apr 22, 2023 at 16:49

tuples = Tuples @ Values @
GroupBy[cities, CityData[#, "Country"] &, Map[CityData[#, "Coordinates"] &]];

{length, tour} = First @ MinimalBy[First] @
Map[With[{fst = FindShortestTour @ #}, {First @ fst, #[[Last @ fst]]}] &] @
tuples;

coordsToCity = AssociationThread[CityData[#, "Coordinates"] & /@ cities, cities];

{length, coordsToCity /@ tour}
{112.502,
{"Istanbul", "Bucharest", "Sofia", "Belgrade", "Budapest", "Vienna",
"Milan", "Barcelona", "Paris", "London", "Cologne", "Prague", "Warsaw",
"Minsk", "Kharkiv", "Voronezh", "Tbilisi", "Istanbul"}}
countrypolygons = DeleteDuplicates[Polygon[CityData[#, "Country"]] & /@ cities];

GeoGraphics[{{RandomColor[], #} & /@ countrypolygons, Black,
Point[Reverse@CityData[#, "Coordinates"] & /@ cities],
Text[#, Reverse@CityData[#, "Coordinates"], {0, -1}] & /@ cities,
Thick, PointSize[Large], Red, Point@Map[Reverse]@tour,
GeoPath[tour]},
GeoBackground -> None, GeoRange -> {{30, 70}, {-10, 60}}]

Clear["Global`*"]

cities = {"Istanbul", "Moscow", "London", "Saint Petersburg", "Berlin",
"Madrid", "Kyiv", "Rome", "Bucharest", "Paris", "Minsk", "Vienna",
"Warsaw", "Hamburg", "Budapest", "Belgrade", "Barcelona", "Munich",
"Kharkiv", "Milan", "Kazan", "Sofia", "Prague", "Tbilisi", "Samara", "Ufa",
"Birmingham", "Cologne", "Voronezh", "Perm", "Volgograd"};

The center of all the cities is

geoCenter = Mean[CityData[#, "Coordinates"] & /@ cities]

(* {49.4251, 23.6938} *)

Group cities by their country

cities2 = GatherBy[cities, CityData[#, "Country"] &];

Select city from each country closest to geoCenter

nearestCenter[cities_List] :=
SortBy[cities, GeoDistance[CityData[#, "Coordinates"], geoCenter] &][[1]]

cities3 = nearestCenter /@ cities2

(* {"Istanbul", "Voronezh", "London", "Berlin", "Barcelona", "Kyiv", "Milan", \
"Bucharest", "Paris", "Minsk", "Vienna", "Warsaw", "Budapest", "Belgrade", \
"Sofia", "Prague", "Tbilisi"} *)

tour = FindShortestTour[CityData[#, "Coordinates"] & /@ cities3]

(* {114.463, {1, 8, 15, 14, 13, 11, 7, 5, 9, 3, 4, 16, 12, 10, 6, 2, 17, 1}} *)

coordinates = GeoPosition[CityData[#, "Coordinates"]] & /@ cities3;

GeoGraphics[{Thick, Red, GeoPath[coordinates[[tour[[2]]]]]}]