Is it possible to produce anaglyphs with Mathematica?

I think the basic idea is to create two slightly different views and combine them in the red and (green + blue) channels.

p = Plot3D[Sin[x y]^2, {x, -2, 2}, {y, -2, 2}];

{r, g} = ColorConvert[
 Image[Show[p, ViewPoint -> {3 Sin[#], 3 Cos[#], 2} &[# Degree]],
   ImageSize -> {360, 275}], "Grayscale"] & /@ {141, 139};

ColorCombine[{r, g, g}]

enter image description here

A simple way to animate is just to change the ViewPoint in a loop and Export the individual frames. I use some software called VirtualDub to combine the images into a movie or animated gif:

Do[{r, g} = ColorConvert[
     Image[Show[p, SphericalRegion -> True, 
       ViewPoint -> {3 Sin[#], 3 Cos[#], 2} &[# Degree]], 
      ImageSize -> {360, 275}], "Grayscale"] & /@ {2 a + 1, 2 a - 1}; 
 Export["frame" <> ToString[a] <> ".bmp", ColorCombine[{r, g, g}]]
 , {a, 0, 44}]

enter image description here


The idea of interactive rotation of the anaglyph has caught my attention. I propose the following:

Manipulate[
ColorCombine@
Flatten@(ColorSeparate[
    Image[Show[pl, ViewPoint -> {2 Sin[(\[Alpha] + #[[1]]) Degree], 
        2 Cos[(\[Alpha] + #[[1]]) Degree], 
        3 Cos[\[Beta] Degree]}], 
     ImageSize -> {360, 275}]][[#[[2]]]] & /@ {{2, 1}, {0, 
   2 ;; 3}}), {{\[Alpha], 45}, -90, 90}, {{\[Beta], 60}, 0, 180}, 
   ContinuousAction -> True, 
   Initialization :> (pl = 
   Plot3D[Sin[(x y)]^2, {x, -2, 2}, {y, -2, 2}, Boxed -> False, 
 Axes -> False, SphericalRegion -> True, PlotRange -> All, 
 ColorFunction -> "GrayTones", ColorFunctionScaling -> True])]

and my result is the following:

enter image description here

The main problem with anaglyphs are the combination of colors in the image. Try to avoid many explicit reds and blues, or your pseudo-stereo image (plot) will suffer from ghost parts. I recommend a color scheme based on grey tones.

  • Edit update

I have edited the code to be a bit more faster.

Tags:

Graphics3D