Make the moon's 3D gif

Question

How do I make the following gif

I tried:

moon = Import[
 "https://upload.wikimedia.org/wikipedia/commons/f/f0/Full_Moon_as_Seen_From_Denmark.jpg"];

{r, g, b} = ColorSeparate[ImageResize[moon, 200]] 


ListPlot3D[ImageData[r, DataReversed -> True], Mesh -> False, 
ColorFunction -> "GrayTones", Boxed -> False, Axes -> False]

but..

Answer 1

Here is an approach based on direct construction of Image3D from ImageData. The basic idea is taken from the subsection "Volume Creation" of the section "Scope" on the Documentation page for Image3D, some other ideas are from the answer by Kuba:

moon = Import[
 "https://upload.wikimedia.org/wikipedia/commons/f/f0/Full_Moon_as_Seen_From_Denmark.jpg"];

moonGray = ImageResize[ImageCrop@ColorConvert[moon, "Grayscale"], [email protected]];

height = 70;
data = ImageData[moonGray]^3;
data3D = Reverse@Table[data UnitStep[height data - k], {k, height}];

im = Image3D[data3D, ColorFunction -> (GrayLevel[Surd[#, 3], Sign[#]] &), 
  SphericalRegion -> True, ViewPoint -> {0, 0, Infinity}, Background -> Black, 
  ImageSize -> 500];

pics = Table[
   Rasterize[Image3D[im, ViewPoint -> 1000 {0, -Sin[i], 1}], "Image"], 
    {i, .1, Pi, Pi/24.}];

Export["moon.gif", pics, "GIF", 
 "DisplayDurations" -> Append[ConstantArray[1/15., Length[pics] - 1], 1]]

---

UPDATE

With RotationAction -> "Clip" (instead of SphericalRegion -> True) and fixed ImageSize -> {500, 512} we can get rid of the margins:

im = Image3D[data3D, ColorFunction -> (GrayLevel[Surd[#, 3], Sign[#]] &), 
  RotationAction -> "Clip", ViewPoint -> {0, 0, Infinity}, Background -> Black, 
  ImageSize -> {500, 512}]

pics = Table[
   Rasterize[Image3D[im, ViewPoint -> 1000 {0, -Sin[i], 1}], "Image"], {i, .1, Pi, 
    Pi/24.}];

Export["moon.gif", pics, "GIF", 
 "DisplayDurations" -> Append[ConstantArray[1/15., Length[pics] - 1], 1]]

(I have reduced the number of colors in the final GIF to 50 using gifsicle in order to fit the 2Mb file size limit).

Answer 2

moon = Import[
  "https://upload.wikimedia.org/wikipedia/commons/f/f0/Full_Moon_as_\
Seen_From_Denmark.jpg"]

Here are two ways to get something like that:

• with Texture or
• with ColorFunction

---

Texture:

pic = ImageCrop @ ImageResize[ColorConvert[moon, "Grayscale"], [email protected]]

Worse quality than is possible with this image but I had to make it smaller due to the lack of time :P. Feel free to change rescaling factor.

texture = ImageCrop @ ColorConvert[moon, "Grayscale"];

ListPlot3D[ImageData[pic, DataReversed -> True]^3,
 Mesh             -> None,
 PlotStyle        -> Texture[texture],     
 Lighting         -> {{"Ambient",  White}},
 ViewPoint        -> 1000 {0, -.001, 1},
 ImageSize        -> 800,
 PlotRangePadding -> {50, 50, 0},
 RotationAction   -> "Clip",
 Boxed            -> False,
 Axes             -> False,
 Background       -> Black,
 PlotRange        -> All,
 ViewVertical     -> {0, 1, 0}
]

It is even responsible enough to play with:

---

ColorFunction

You need to:

• change the ColorFunction so it respects original color space, then it will look naturally. Also, make the Lighting less interfering: Lighting -> {{"Directional", White, {0, 0, 1000}}}

• transform values of pixels, as seen on linked example those peaks are way bigger that they should be comparing to other areas on the Moon: ImageData[...]^7

• use the inverse transformation for ColorFunction so the coloring doesn't care about what you've done with values: ColorFunction -> (Blend[..., Surd[#3, 7]] &)

---

pic = ImageResize[ColorConvert[moon, "Grayscale"], [email protected]];

pics = Table[
   x = 1000 {0, Sin[i], 1};
   
   Rasterize @ ListPlot3D[
     ImageData[pic, DataReversed -> True]^7, 
     Mesh            -> None, 
     ColorFunction   -> (Blend[{Black, White}, Surd[#3, 7]] &), 
     Lighting        -> {{"Directional", White, {0, 0, 1000}}}, 
     ViewPoint       -> x, 
     Boxed           -> False, 
     Axes            -> False, 
     Background      -> Black, 
     SphericalRegion -> True, 
     PlotRange       -> All
   ],
   {i, .1, Pi, Pi/24.}
];


path = FileNameJoin[{$HomeDirectory, "Desktop", "moon.gif"}]

Export[
 path, pics, "GIF", 
 "DisplayDurations" -> Append[ConstantArray[1/15., Length[pics] - 1], 1]
]

SystemOpen @ path

Answer 3

I've always wished the moon was more habitable. Starting from the OPs picture:

moon = ColorConvert[
  Import["https://upload.wikimedia.org/wikipedia/commons/f/f0/Full_\
Moon_as_Seen_From_Denmark.jpg"], "Grayscale"]; 
ReliefPlot[ImageData[moon], ColorFunction -> "GreenBrownTerrain"]