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

@YvesKlett "but.." this is a ugly image, my method doesn't work. see here diference — vito, Apr 21 '16 at 12:23
It would be useful to state all your requirements / gripes with your solution in the question. — Yves Klett, Apr 21 '16 at 13:18
Sorry for the edit but I believe this is about the Moon, not any moon, right? — Kuba, Apr 21 '16 at 14:37

score 14 · Answer 1 · edited Jun 16 '20 at 09:23

14

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"], Scaled@.3]

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"], Scaled@.2];
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

edited Jun 16 '20 at 09:23

Community

1

answered Apr 21 '16 at 12:32

Kuba

136,707
13
279
740

It looks like the process is repeated on the other side as well in the original GIF – Anthony Pham Apr 21 '16 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] – J. M.'s missing motivation Apr 21 '16 at 16:18
1

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[]? – J. M.'s missing motivation Apr 21 '16 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 '16 at 06:35
@PythonMaster Yeah, it is slightly different. I have a problem with motivation once I find solution to the core of the task :P So don't wait for that but I will try to update this post in near future :) – Kuba Apr 22 '16 at 06:36
1

@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. :( – Alexey Popkov Apr 22 '16 at 15:52
@AlexeyPopkov Thanks, I didn't know about that. Strange design. – Kuba Apr 25 '16 at 06:54
That is an interesting way to format MMA code! Did you do it by hand? – Aisamu Apr 27 '16 at 17:30
@Aisamu Yep, I'm trying to write my packages similarly, way more readable. – Kuba Apr 27 '16 at 18:13
Wow, I was honestly expecting some IDE magic. ColorFunction -> ("Impressed" &) – Aisamu Apr 28 '16 at 21:09

score 13 · Accepted Answer · edited Jun 16 '20 at 09:23

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"], Scaled@.5];
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).

bill s · Answer 3 · 2016-04-21T15:33:12.303

1

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"]

edited Apr 21 '16 at 15:33

answered Apr 21 '16 at 15:04

bill s

68,936
4
101
191

1

So that's the fabled danish moon, eh! – Yves Klett Apr 21 '16 at 18:59

Make the moon's 3D gif

3 Answers3

`Texture`:

`ColorFunction`

UPDATE

Linked

Make the moon's 3D gif

3 Answers3

Texture:

ColorFunction

UPDATE

Linked

`Texture`:

`ColorFunction`