Recreating map from Wolfram|Alpha with GeoGraphics

Question

I have tried to create a map using GeoGraphics, and I have not been able to get one with the same quality as the result Wolfram|Alpha gave me.

WolframAlpha["distance between eeuu and north korea", {{"Map", 1}, "Content"}] 

GeoGraphics[
 GeoPath[{Entity["Country", "UnitedStates"], 
   Entity["Country", "China"]}], GeoBackground -> "VectorMonochrome", 
 GeoProjection -> "AzimuthalEquidistant"]

Can I create a similar map with the same quality (the Wolfram|Alpha image is, for example, vectorized) to the one Wolfram|Alpha gave me using GeoGraphics directly?

In fact, this question is related to others that I've seen some people ask on other sites and never got an answer: If I get a result from Wolfram|Alpha, is there any way to, from that result, get the code I can write in Mathematica to generate it? That is, given the image map, how do I get Mathematica to give me the code for that image?

Answer 1

Here is a rough approximation. First, you generate a temporary GeoGraphics just to get correct positioning (GeoCenter, GeoRange ...). Then, you can get a high quality world map from Polygon[Entity["GeographicRegion", "World"]].

loc1 = Entity["Country", "UnitedStates"]; 
loc2 = Entity["Country", "NorthKorea"]; 

(* Temporary GeoGraphics *)
geo = GeoGraphics[{Polygon[loc1], Polygon[loc2], 
   Arrow[GeoPath[{loc1, loc2}]]}];

GeoGraphics[{{EdgeForm[Gray], FaceForm[LightGray], 
   Polygon[Entity["GeographicRegion", "World"]], GeoStyling[Orange], 
   Polygon[loc1], Polygon[loc2]}, Darker@Red, Thick, 
  Arrow[GeoPath[{loc1, loc2}]], Red, PointSize[Large], 
  Point[{loc1, loc2}]}, GeoBackground -> None, 
 Sequence @@ Options[geo]]

Answer 2

This is pretty close, I think:

GeoGraphics[{{GeoStyling[Orange], 
   Polygon /@ {Entity["Country", "UnitedStates"], 
     Entity["Country", "NorthKorea"]}}, {Red, 
   Arrow[GeoPath[{Entity["Country", "UnitedStates"], 
      Entity["Country", "NorthKorea"]}]]}}, 
 GeoBackground -> {"CountryBorders", "Land" -> GrayLevel[0.95], 
   "Ocean" -> White}]

Answer 3

Perhaps something like this:

usa = Entity["Country", "UnitedStates"];
korea = Entity["Country", "NorthKorea"];

GeoGraphics[{
   {GeoStyling[Append[Orange, 0.8]], Polygon[GeoVariant[usa, "AllAreas"]], Polygon[korea]},
   {ColorData[112, 1], AbsoluteThickness[2], Arrow[GeoPath[{usa, korea}]]},
   {Red, PointSize[Large], Point[{usa, korea}]}
  },
  GeoBackground -> {{"CountryBorders", "Land" -> GrayLevel[0.9], 
    "Ocean" -> None, "Border" -> GrayLevel[0.7]}},
  GeoProjection -> "LambertAzimuthal",
  GeoRange -> GeoBounds[GeoGroup[{usa, korea}]],
  PlotRangePadding -> Scaled[.06],
  AspectRatio -> 1/GoldenRatio
]