How can I generate an interrupted projection of a world map?

Question

How can I generate a world map like the one here, but for an arbitrary hand-drawn map?

For example, starting from scratch, how can I manipulate this world map

to get something that looks like this?

Attempt: Starting with the world map, I thought to cut the image into vertical strips and somehow contract each rectangular strip at its upper and lower ends while keeping the middle constant to make symmetric lenses, i.e. the transformation that does this:

However, I don't how to do this, and I suspect there may be an easier way. Any suggestions are appreciated.

Answer 1

I'm going to take the interpretation that you want to apply the transverse Mercator projection to an image you have to produce something like the one in the Wolfram page you linked to. One only needs to make a few changes to the code in that link. I will be using a different image, since the one in the OP is awkwardly cut off, which will mess with the mapping.

With[{Δ = 30},
     earth = Import["https://i.sstatic.net/jteWq.jpg"];
     ImageAssemble[MapThread[Rasterize[
          GeoGraphics[GeoBackground -> GeoStyling[{"GeoImage", #2}], 
                      GeoRange -> {{-90, 90}, #1[[1]]}, 
                      GeoProjection -> {"TransverseMercator", "Centering" -> #1[[2]]},
                      ImageSize -> Large], 
                    ImageSize -> Large] &,
                    {Table[{{λ, λ + Δ}, {0, λ + Δ/2}}, {λ, -180, 180 - Δ, Δ}],
                     First @ ImagePartition[earth, Scaled[{Δ/360, 1}]]}]]]

---

Here is a slower method that uses ImageTransformation[] and formulae 22-23 from here to directly transform the map (note that I took the liberty to work directly in radians instead of degrees):

With[{Δ = π/6},
     earth = Import["https://i.sstatic.net/jteWq.jpg"];
     ImageAssemble[Table[ImageTransformation[earth, 
                   Module[{x = #[[1]], y = #[[2]], h = Δ/2, λt},
                          λt = ArcTan[Cos[y], Sinh[x]]; 
                          If[-h <= λt <= h,
                             {λ + h + λt, ArcSin[Sin[y] Sech[x]]},
                             {π, π/2} (* dummy value for off-range pixels *)]] &, 
                   Background -> White, DataRange -> {{-π, π}, {-π/2, π/2}}, 
                   Masking -> All, 
                   PlotRange -> {{-InverseGudermannian[Δ/2], InverseGudermannian[Δ/2]},
                                 {-π/2, π/2}}],
                   {λ, -π, π - Δ, Δ}]]]

Answer 2

J.M.'s answer is the best and he helped me figure out the correct parametric equations from here, but the method I've been working on is very fast (<0.5 sec) and doesn't include any white-space where the slices connect.

img = Import["https://i.sstatic.net/jteWq.jpg"];
gore = 12;
tex = First @ ImagePartition[img, Scaled[{1/gore, 1}]];
ImageAssemble[Table[
  ParametricPlot[{ArcTanh[Cos[ϕ] Sin[λ]],  ArcTan[Cos[ϕ] Cos[λ], Sin[ϕ]]},
   {ϕ, -π/2, π/2}, {λ, -π/gore, π/gore},
   PlotStyle -> Directive[Texture[tex[[i]]], Opacity[1]], 
   TextureCoordinateFunction -> ({#1, #2} &), Frame -> False, 
   Axes -> False, BoundaryStyle -> None, PlotRangePadding -> 0],
  {i, 1, gore}]]