Given a background and a pattern jpg files, is there a quick and easy way to produce a stereogram by using Mathematica? The following picture was produced from Photoshop, spent about half an hour. 
Here is the background tile for creating the blank background below:

and here is a blank background picture of pebbles: 
Answer
Here's an alternative method which takes a depth map.
This is a complete change from my original code - my apologies for doing such a major edit after receiving so many upvotes but it was not quite right before (there were artifacts in the 3D view). This version is based on the description here.
I upsample the pattern image and depth map before creating the stereogram, and afterwards downsample the result back to the correct size. This is to allow a greater number of depth planes without having to explicitly interpolate to get sub-pixel shifts.
For better performance I use a compiled function to do the actual pixel-copying core of the algorithm. I have used compilation to C but for those without a C compiler it will work just as well (but a bit slower) using the WVM.
The final function stereogram takes as arguments the pattern image, the depth image and the desired number of tiles in width and height. The fourth optional argument is the maximum pixel shift in the upsampled image - this is also the number of distinct depth planes.
shift = Compile[{
{im, _Real, 3}, {d, _Integer, 2}, {nx2, _Integer},
{ny, _Integer}, {w, _Integer}, {h, _Integer}},
Block[{i = im}, Do[i[[y, x + d[[y, x]]]] = i[[y, x - d[[y, x]]]],
{y, h ny}, {x, 1 + nx2, 2 w nx2 - nx2}]; i],
CompilationTarget -> "C"];
sg[pattern_, depthmap_, copies_, maxshift_] :=
Module[{nx, ny, p, w, h, i, d},
{nx, ny} = ImageDimensions[pattern];
p = If[OddQ[nx], ImageCrop[pattern, {nx = nx - 1, ny}], pattern];
{w, h} = copies;
i = ImageData @ ImageAssemble@ConstantArray[p, {h, w}];
d = depthmap ~ImageCrop~ {w nx, h ny} ~ColorConvert~ "Grayscale";
d = Round[nx/2 - maxshift Clip[ImageData @ d, {0, 1}]];
Image[shift[i, d, nx/2, ny, w, h]]]
stereogram[pattern_Image, depthmap_Image, copies_List: {5, 5}, maxshift_: 40] :=
sg[pattern ~ImageResize~ Scaled[5],
depthmap ~ImageResize~ Scaled[5],
copies, maxshift] ~ImageResize~ Scaled[1/5]
Example:
pattern = Import["http://i.stack.imgur.com/nQKct.jpg"];
depthmap = Import["http://i.stack.imgur.com/RJf51.png"];
stereogram[pattern, depthmap, {6, 5}]

Comments
Post a Comment