Make the moon's 3D gif

How do I make the following gif

I tried:

moon = Import[

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

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


but..

• What is the "but.."? Are you after the animation part? Apr 21, 2016 at 11:58
• @YvesKlett "but.." this is a ugly image, my method doesn't work. see [here ](dropbox.com/s/7v77pdyv4n82ajk/333.PNG?dl=0) diference
– vito
Apr 21, 2016 at 12:23
• vito - do you just browse this site for images? Apr 21, 2016 at 12:26
• It would be useful to state all your requirements / gripes with your solution in the question. Apr 21, 2016 at 13:18
• Sorry for the edit but I believe this is about the Moon, not any moon, right?
– Kuba
Apr 21, 2016 at 14:37

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[

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).

moon = Import[
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,
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


• It looks like the process is repeated on the other side as well in the original GIF Apr 21, 2016 at 15:23
• You could consider using the built-in method to generate a picture of the moon: ColorConvert[Rasterize[GeoGraphics[GeoModel -> Entity["PlanetaryMoon", "Moon"], GeoProjection -> "Orthographic", GeoRange -> All, Background -> Black]], GrayLevel] Apr 21, 2016 at 16:18
• Haven't played around with it much until the other question about projecting the moon came up. What if you tweak the ImageSize option of GeoGraphics[] and the options of Rasterize[]? Apr 21, 2016 at 16:42
• @J.M. it does change something but somehow I wasn't able to pick parameters and generate an image that would look nice.
– Kuba
Apr 22, 2016 at 6:35
• @Kuba Direct applying Rasterize before Export is generally a wrong idea, I wrote a post about this. It is unfortunate that Rasterize by default returns Graphics instead of Image. :( Apr 22, 2016 at 15:52

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

moon = ColorConvert[