Make the moon's 3D gif
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 theLighting
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
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).