11
$\begingroup$

How do I make the following gif

enter image description here

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

enter image description here

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

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

gif


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

gif

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

$\endgroup$
14
$\begingroup$
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:

enter image description here


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

enter image description here

$\endgroup$
  • $\begingroup$ It looks like the process is repeated on the other side as well in the original GIF $\endgroup$ – Anthony Pham Apr 21 '16 at 15:23
  • $\begingroup$ 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] $\endgroup$ – J. M. is away Apr 21 '16 at 16:18
  • 1
    $\begingroup$ 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[]? $\endgroup$ – J. M. is away Apr 21 '16 at 16:42
  • $\begingroup$ @J.M. it does change something but somehow I wasn't able to pick parameters and generate an image that would look nice. $\endgroup$ – Kuba Apr 22 '16 at 6:35
  • 1
    $\begingroup$ @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. :( $\endgroup$ – Alexey Popkov Apr 22 '16 at 15:52
1
$\begingroup$

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

enter image description here

$\endgroup$
  • 1
    $\begingroup$ So that's the fabled danish moon, eh! $\endgroup$ – Yves Klett Apr 21 '16 at 18:59

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.