6
$\begingroup$

The app MirrorLab on Android has a very interesting Julia Effect, and I'd like to recreate this effect in Mathematica. Here are some examples of input images and their outputs:

inputs = Import /@ {
   CloudObject["https://www.wolframcloud.com/objects/09bf1cae-1109-4490-a35a-960ff9199863"], 
   CloudObject["https://www.wolframcloud.com/objects/17390d2b-3271-4c7c-9f0c-190db3d81b8c"], 
   CloudObject["https://www.wolframcloud.com/objects/2cc137f2-6a2f-4cd9-9792-97c4df3a98b3"], 
   CloudObject["https://www.wolframcloud.com/objects/5c1ce239-7fe8-4636-a008-eae8fad0bff8"]
 }

enter image description here

effects = Import /@ {
   CloudObject["https://www.wolframcloud.com/objects/c3f3e2ef-2a66-474d-a031-fb078353e0da"],
   CloudObject["https://www.wolframcloud.com/objects/2e6f5a50-09a3-469c-b8cf-5418fa4f4c83"],
   CloudObject["https://www.wolframcloud.com/objects/af56d7cb-11c0-421a-8759-bac6ed20d250"], 
   CloudObject["https://www.wolframcloud.com/objects/fbfdb34f-3ea1-4f99-912f-b9cfa47b0ea7"]
}

enter image description here

I think they are using some sort of shading function. I've been playing with ImageForwardTransformation, but can't seem to get this to work.

$\endgroup$
8
  • 6
    $\begingroup$ The images in this paper were mostly prepared with Mathematica. I could post an answer with code later. You might be entertained by this web page as well. $\endgroup$ Aug 16, 2018 at 20:27
  • 1
    $\begingroup$ @MarkMcClure that would be great! Have you tried the MirrorLab app? They seem to have a bunch of different families of transforms in addition to this type. If you don't have an Android device - just use the Blue Stacks on your mac. $\endgroup$
    – M.R.
    Aug 16, 2018 at 21:51
  • $\begingroup$ @MarkMcClure any chance you can show us your solution here? $\endgroup$
    – M.R.
    Aug 27, 2018 at 21:07
  • 2
    $\begingroup$ This looks very similar to what ResourceFunction["ComplexTransformImage"] is doing for example: img = Import@ CloudObject[ "https://www.wolframcloud.com/objects/09bf1cae-1109-4490-a35a-960ff9199863"]; julia[z_, c_] := z^2 + c; ResourceFunction["ComplexTransformImage"][img, julia[#1[[1]] + I #1[[2]], 0.3 + 0.6 I] &, 3, 2] $\endgroup$
    – flinty
    Oct 5, 2020 at 22:06
  • 1
    $\begingroup$ The center is a Julia point set for -.79+i.15 in red and white with a special Pointsize. The circumference is from a Julia set with ComplexTransImage. For the transition, I do not get a solution so far. Perhaps it is with ComplexTransImage but with a different picture, function. The second is done the same with the same process and so on. $\endgroup$ Oct 10, 2020 at 13:32

5 Answers 5

6
$\begingroup$

You do not need excotic function, the built in tools will do the job. Due to bad weather, I did some experimenting. What I did not yet try is to use Nest, that I think may come in handy. For the time being, I did everything "by hand". Maybe I will add more, if I have the time. Have fun:

inputs = Import /@ {
   CloudObject["https://www.wolframcloud.com/objects/09bf1cae-1109-4490-a35a-960ff9199863"], 
   CloudObject["https://www.wolframcloud.com/objects/17390d2b-3271-4c7c-9f0c-190db3d81b8c"], 
   CloudObject["https://www.wolframcloud.com/objects/2cc137f2-6a2f-4cd9-9792-97c4df3a98b3"], 
   CloudObject["https://www.wolframcloud.com/objects/5c1ce239-7fe8-4636-a008-eae8fad0bff8"]
 }

tx = Texture[inputs[[1]]];
pol = Polygon[t = Table[{Cos[p], Sin[p]}, {p, 0, 2 Pi, Pi/6}], 
   VertexTextureCoordinates -> Automatic];
circ[r_, s_, n_] := 
 Table[Rotate[Translate[Scale[pol, s], {r, 0}], i 2 Pi/n, {0, 0}], {i,
    n}]
p1 = Table[
   Rotate[Translate[Scale[pol, .5/i], {1/i, 0}], i  Pi/3, {0, 0}], {i,
     2, n}];
Graphics[{tx, circ[0, 1, 1], circ[1.7, 0.75, 7], circ[2.8, 0.5, 18], 
  circ[3.5, 0.3, 40], circ[3.9, 0.15, 80]}]

enter image description here

pol = Polygon[t = Table[{Cos[p], Sin[p]}, {p, 0, 2 Pi, Pi/6}], 
   VertexTextureCoordinates -> Automatic];
tx = Texture[inputs[[1]]];
pol1[c_, s_, phi_] := 
  Rotate[Translate[Scale[pol, s], {c, 0}], phi, {0, 0}];
Graphics[{tx, Table[pol1[40/i^1.3, 10/i^1.1, Pi  i 0.2], {i, 3, 50}]}]

enter image description here

gr = {tx, 
  Table[pol1[40/i^1.3, 10/i^1.1, Pi  i 0.2], {i, 3, 50}]};
 Graphics[
 Table[Rotate[Translate[gr, {10, 0}], ph, {0, 0}], {ph, 0, 2 Pi, 
   Pi/4}]]

enter image description here

gr1 := Table[
  Rotate[Translate[gr, {10, 0}], ph, {0, 0}], {ph, 0, 2 Pi, Pi/4}]
Graphics[Table[
  Rotate[Translate[gr1, {20, 0}], ph, {0, 0}], {ph, 0, 2 Pi, Pi/4}]]

enter image description here

$\endgroup$
7
  • $\begingroup$ Is there a way to produce the julia set like this? This is more like an IFS. $\endgroup$
    – flinty
    Oct 10, 2020 at 20:52
  • $\begingroup$ A Julia set is a different kind of beast, it is not an image transformation. A Julia set is the set of points in the complex plane that, under repeated application of some rational function, does not diverge to infinity. Therefore, you may create it by picking a point in the complex plane, apply your chosen function a couple of times, using Nest, and check if the result exceed some limit. $\endgroup$ Oct 11, 2020 at 9:13
  • $\begingroup$ @flinty Actually, it is built into MMA. Look up "JuliaSetPlot" or "MadelbrotSetPlot" $\endgroup$ Oct 11, 2020 at 9:20
  • $\begingroup$ That just plots the julia/mandelbrot set. It does not let you to transform a texture using a conformal map of the julia/mandelbrot set which is the effect OP asks about. So far I've only found ResourceFunction["ComplexTransformImage"] capable of doing this. $\endgroup$
    – flinty
    Oct 11, 2020 at 12:05
  • $\begingroup$ pol = Polygon[t = Table[{1.3 Cos[p], 1.*Sin[p]}, {p, 0, 2 Pi, Pi/6}], VertexTextureCoordinates -> Automatic]; this makes the circles elliptical like in the given picture. $\endgroup$ Oct 12, 2020 at 8:32
5
+100
$\begingroup$

I have tested code from the paper Through the Looking-Glass, and What the Quadratic Camera Found There to understand how they been able to take Figure 1-5. Let use this code to produce Julia set points from the picture inputs[[1]]

inputs = Import /@ {CloudObject[
    "https://www.wolframcloud.com/objects/09bf1cae-1109-4490-a35a-\
960ff9199863"], 
   CloudObject[
    "https://www.wolframcloud.com/objects/17390d2b-3271-4c7c-9f0c-\
190db3d81b8c"], 
   CloudObject[
    "https://www.wolframcloud.com/objects/2cc137f2-6a2f-4cd9-9792-\
97c4df3a98b3"], 
   CloudObject[
    "https://www.wolframcloud.com/objects/5c1ce239-7fe8-4636-a008-\
eae8fad0bff8"]}   

Now we run code1 I have modified for this answer:

scale = 1;
    pic = Image[inputs[[1]]];
dims = ImageDimensions[pic];
pic = ImageResize[pic, scale dims];
dims = ImageDimensions[pic];

complexSize = 2.4 ;

 im = Image[
   Rasterize[ImagePad[pic, {{0, 0}, {0, 0}}], 
    RasterSize -> (200; Automatic), ImageResolution -> 300]];
im = ImageResize[im , {200, 200}];


Quiet[LaunchKernels[]];

c = -.83 - I .18;  p = 0.;
limitColor = {0.15, 0.95, 0.95};
{xmin, xmax} = {-complexSize, complexSize};
{ymin, ymax} = {-complexSize, complexSize};
{m, n} = ImageDimensions[im];


imm[0] = im; Do[imageData = ImageData[imm[i - 1]]; 
 color1 = With[{c = c, imageData = imageData , m = m, n = n, p = p, 
    limitColor = limitColor, xmin = xmin, xmax = xmax, ymin = ymin, 
    ymax = ymax}, 
   Compile[{{z, _Complex}}, 
    Module[{z1}, z1 = z^2 + c; 
     If[! (xmin <= Re[z1] <= xmax && ymin <= Im[z1] <= ymax), {0, 0, 
       0}, p limitColor + (1 - p) imageData[[
         Round[Max[1, (n (Im[z1] - ymax))/(ymin - ymax)]], 
         Round[Max[1, (m (Re[z1] - xmin))/(xmax - xmin)]]]]]], 
    RuntimeAttributes -> {Listable}, Parallelization -> True]];
 colors = 
  color1[Table[
    x + I y, {y, ymax, ymin, (ymin - ymax)/n}, {x, xmin, xmax, (
     xmax - xmin)/m}]]; imm[i] = Image[colors] ;, {i, 6}]

Table[imm[i], {i, 6}] 

Figure 1

Now we run code2 I also have modified for this answer

pic = Import@
   CloudObject[
    "https://www.wolframcloud.com/objects/09bf1cae-1109-4490-a35a-\
960ff9199863"];
f[z_] := z^2 - .83 - I .18;
Clear[n];
invImage[im_Image] := 
  Image[cInvImage[ImageData[im]], ImageSize -> 2 128];
{xmin, xmax} = {-2, 2}; {ymin, ymax} = {-2., 2};
DynamicModule[{a = 0, b = 0, da = 128, db = 128}, 
  pic1 = ImageTake[pic, {a, da}, {b, db}]; {m, n} = 
   ImageDimensions[pic1]; si[x_] = (x (xmax - xmin))/m + xmin; 
  sx[i_] = x /. First[Solve[si[x] == i, x]]; 
  sj[y_] = (y (ymax - ymin))/n + ymin; 
  sy[j_] = y /. First[Solve[sj[y] == j, y]]; 
  fScaled = 
   ComplexExpand[{Re[f[x + I y]], Im[f[x + I y]]}] /. {x -> si[x], 
     y -> sj[y]}; fScaledBack = {sx[fScaled[[1]]], sy[fScaled[[2]]]}; 
  intInv = With[{fScaledBack = fScaledBack}, 
    Compile[{{x, _Integer}, {y, _Integer}}, Round[fScaledBack]]]; 
  rgb2 = With[{intInv = intInv, m = m, n = n}, 
    Compile[{{x, _Integer}, {y, _Integer}, {imageData, _Real, 3}}, 
     Module[{x2, y2}, {x2, y2} = intInv[x, y]; 
      If[1 <= x2 < m && 1 <= y2 < n, 
       imageData[[y2, x2]], {0.`, 0.`, 0.`}]]]]; 
  cInvImage = 
   With[{rgb2 = rgb2, m = m, n = n}, 
    Compile[{{imageData, _Real, 3}}, 
     Table[rgb2[x, y, imageData], {y, 1, n}, {x, 1, m}]]]];

Visualization

img[0] = pic1; Do[img[i] = invImage[img[i - 1]], {i, 6}]

Table[img[i], {i, 6}]

Figure 2 Therefore in 2 cases we have after 32 iterations some picture similar to inside of filtered picture. Why we can't produce this with standard function like ImageTransformation[] or with ResourceFunction["ComplexTransformImage"][]? It is question of scaling. For ImageTransformation[] we read from tutorials "In 2D, the range of the coordinate system for the input image is assumed to be {{0,1},{0,a}}, where a is the aspect ratio. The bottom-left corner of the image corresponds to coordinates {0,0} by default." Thus first we need to define coordinate system so that we can cover all data we use for Julia set. Second, we compose all pictures in one to get right sequences used Image[Rasterize[Overlay[]]]. Finally we can make picture from inputs[[4]] produced by quadratic camera without Julia set. For this we run code from the paper:

screen = Image[inputs[[4]]];
{sm, sn} = ImageDimensions[screen];

backSize = 1000;
twoSquare = 
  Polygon[{
    {{0, 0}, {1, 0}, {1, 1}, {0, 1}},
    {{1, 1}, {2, 1}, {2, 2}, {1, 2}}}];
back = Graphics[{Darker[Gray, 0.4], Translate[twoSquare,
     Flatten[Table[{i, j}, {i, 0, 8, 2}, {j, 0, 8, 2}], 1]]},
   PlotRangePadding -> 0, Frame -> True, FrameTicks -> False,
   FrameStyle -> Thick, ImageSize -> backSize];
im = Image[Rasterize[Overlay[{back, screen},
     Alignment -> Center]]];
screenOnBackground = Show[im,
  Graphics[{Thickness[0.005], Lighter@Yellow,
    Circle[Scaled[{0.5, 0.5}], Scaled[1/(2*2.4)]]}],
  ImageSize -> 400]

c = 0; (* The circle *)
complexSize = 2.4;
p = 0.2;
limitColor = {0.15, 0.95, 0.95};
{xmin, xmax} = {-complexSize, complexSize};
{ymin, ymax} = {-complexSize, complexSize};
{m, n} = ImageDimensions[im];
imageData = ImageData[im];
color1 = With[
   {c = c, imageData = imageData, m = m, n = n, p = p,
    limitColor = limitColor, xmin = xmin,
    xmax = xmax, ymin = ymin, ymax = ymax},
   Compile[{{z, _Complex}},
    Module[{z1},
     z1 = z^2 + c;
     If[! (xmin <= Re[z1] <= xmax && ymin <= Im[z1] <= ymax),
      {0, 0, 0},
      p*limitColor + (1 - p)*imageData[[
          Round[Max[1, (n (Im[z1] - ymax))/
             (ymin - ymax)]],
          Round[Max[1, (m (Re[z1] - xmin))/
             (xmax - xmin)]]]]]],
    RuntimeAttributes -> {Listable}]];
colors = color1[Table[x + I*y,
    {y, ymax, ymin, (ymin - ymax)/n},
    {x, xmin, xmax, (xmax - xmin)/m}]];
im = Image[colors];
screenShows1 = im = ImageTake[im,
    {(backSize - sn)/2, backSize - (backSize - sn)/2},
    {(backSize - sm)/2, backSize - (backSize - sm)/2}];
cameraSees1 = Show[{im = Image[Rasterize[Overlay[{back, im},
       Alignment -> Center]]],
   Graphics[{Thickness[0.005], Lighter[Yellow], Circle[Scaled[{0.5, 0.5}], Scaled[1/(2*2.4)]]}]},
  ImageSize -> 400]    

Figure 3

$\endgroup$
2
  • 1
    $\begingroup$ Image 29 with c = -.79 - 0.22 I is even better as far as getting the center shape (with code 1). $\endgroup$ Oct 12, 2020 at 19:03
  • $\begingroup$ @Jean-Pierre Thank you for this point. As we understand there are continuum of these points, but for visualization some of them are better then another. $\endgroup$ Oct 12, 2020 at 19:24
4
$\begingroup$

I am now much closer to an answer. It is a two-step process. First the original image must be transformed. Second, the transformed image is used to get the pixel color in a modified Julia code where the position of the pixel is not the original z0, but the last position before escaping the radius of 2.

Part 1 - Transforming the original image

The transformation is a version of what is shown at this location.

imgTrans = With[{sectors = 12}, 
  ImageTransformation[img, 
   Function[{pt}, {ArcTan[-#2, #1] & @@ (pt), Norm[pt]}], {200, 200}, 
   DataRange -> {Pi/sectors {-1, 1}, {0, 1}}, 
   PlotRange -> {{-2, 2}, {-2, 2}}, Padding -> "Reversed"]] 

This is the result of the transformations. I am using 12 sectors and a size of {200,200}:

enter image description here

Part 2 - Julia code

Then we can use use the julia code. The code I have is a bit clunky. It is an adaptation on the fly of my previous code.

(* The Julia function where c is a constant *)
julia[z_, c_] := (
  z^2 + c
  )

(* Holds the final image pixels *)
finalImage = {};

(* The Julia c constant *)
cConstant = -0.79 + 0.15 I;

(* Points in the complex plane that will form the starting point z of \
the iterations. The complex plane betwwee -2 and 2 is split in a 200 \
X 200 grid, so there are 40000 starting points z *)

complexZPoints = 
  Flatten[Table[{x + y I}, {x, -2, 1.99, 0.02}, {y, -2, 1.99, 0.02}], 
   1];

(* Nearest Function *)
nf = Nearest[complexZPoints];

(* Iterate through the starting z points *)
k = 1;
Monitor[While[k <= Length[complexZPoints],
   p = complexZPoints[[k]];
   n = 1;
   passed = True;
   (* Iterate with the julia function 50 times. At each iteration, 
   check if the value escaped the value of 2. If so stop and mark \
passed as False *) 
   While[n <= 50,
    pLast = p;
    p = julia[p, cConstant] // N;
    If[ Norm[p] > 2,
     passed = False; Break[]];
    n++;
    ];
   
   If[passed == True,
    AppendTo[finalImage, {1, 0, 0}],
    AppendTo[finalImage, 
  PixelValue[a2, 50 { Re[imgTrans][[1]] + 2, Im[imgTrans][[1]] + 2}]];
    ];
   k++;
   ], k];
    
(* The list of 40000 colors is formatted as a 200x200 image *) 
Image[Transpose[Partition[finalImage, 200]]]

And this gives the following (note that I added the color of the pattern at the center by hand). This is not exactly what is expected, but it is close:

enter image description here

$\endgroup$
2
$\begingroup$

This is not an answer, but I want to show an image. This is the left reflection of the Julia set with c= -0.79 + I 0.15. No colors shown. Black represents points not escaping after 100 iterations. The four gray levels represents points escaping at the first, second and third iteration, and at higher iterations. The shape of the three darker bands are visible in the images supplied, but of course colored in a fancy way. I was wondering if coloring these bands with pixels taken from our images (or some modifications of our images) would do the trick.

enter image description here

EDITED: This looks terrible, but this is an example of what I mean. In the image below the bands were colored by taking pixels from 4 different images to color the 4 gray bands. Each contained the same circular arrangement of multiple copies of the original image, but of a size getting smaller and smaller as we move toward the darker band. In this last one, images are so small that they look like dots. The black center was just colored red.

enter image description here

Someone asked for code in the comments. I did not provide it initially because it does not solve the problem. But here it is. I tried to insert some comments.

(* Load image *)

img = Import[
   CloudObject[
    "https://www.wolframcloud.com/objects/09bf1cae-1109-4490-a35a-\
960ff9199863"]];

(* Create four 200x200 images based on the imported image. This is \
for demo only. Arbitrary parameters are used. This is based on Daniel Huber code on this page  *)
tx = Texture[img];
pol = Polygon[t = Table[{Cos[p], Sin[p]}, {p, 0, 2 Pi, Pi/6}], 
   VertexTextureCoordinates -> Automatic];
circ[r_, s_, n_] := 
 Table[Rotate[Translate[Scale[pol, s], {r, 0}], i 2 Pi/n, {0, 0}], {i,
    n}]

mg1 = ImageResize[
   Graphics[{tx, Table[circ[x, 0.6, 4 x + 3], {x, 3, 1, -0.95}]}], 
   200];
mg2 = ImageResize[
   Graphics[{tx, Table[circ[x, 0.4, 8 x + 1], {x, 3, 0.5, -0.5}]}], 
   200];
mg3 = ImageResize[
   Graphics[{tx, Table[circ[x, 0.3, 11 x + 5], {x, 3, 0.5, -0.2}]}], 
   200];
mg4 = ImageResize[
   Graphics[{tx, Table[circ[x, 0.06, 60 x + 5], {x, 3, 0.1, -0.05}]}],
    200];

(* The Julia function where c is a constant *)
julia[z_, c_] := (
  z^2 + c
  )

(* Holds the final image pixels *)
finalImage = {};

(* The Julia c constant *)
cConstant = -0.79 + 0.15 I;

(* Points in the complex plane that will form the starting point z of \
the iterations. The complex plane betwwee -2 and 2 is split in a 200 \
X 200 grid, so there are 40000 starting points z *)

complexZPoints = 
  Flatten[Table[{x + y I}, {x, -2, 1.99, 0.02}, {y, -2, 1.99, 0.02}], 
   1];

(* Iterate through the starting z points *)
k = 1;
Monitor[While[k <= Length[complexZPoints],
   p = complexZPoints[[k]];
   n = 1;
   passed = True;
   (* Iterate with the julia function 100 times. At each iteration, 
   check if the value escaped the value of 2. If so stop and mark \
passed as False *) 
   While[n <= 100,
    p = julia[p, cConstant] // N;
    If[ Norm[p] > 2,
     passed = False; Break[]];
    n++;
    ];
   (* Find coordinates (j,
   m) of a point in a 200x200 image corresponding to k *) 
   m = Mod[k, 200, 1];
   j = Ceiling[k/200];
   
   
   If[passed == True,
    (* points not escaping after 100 iterations are just colored red *)
    AppendTo[finalImage, {1, 0, 0}],
    
    (* points escaping before 100 iterations are colored by looking \
at the coordinate color in an image determined by n when the point \
escaped. Four ranges where selected*) 
    col = Which[n < 2, PixelValue[mg1, {j, m}],
      n < 3, PixelValue[mg2, {j, m}],
      n < 4, PixelValue[mg3, {j, m}], 
      n <= 100, PixelValue[mg4, {j, m}]];
    
    (* the pixel color is appended to the list *)
     AppendTo[finalImage, col];
    ];
   k++;
   ], k];
    
(* The list of 40000 colors is formatted as a 200x200 image *) 
Image[Transpose[Partition[finalImage, 200]]]

For the parameters used in the four images used to lookup pixel colors, this is the result:

enter image description here

$\endgroup$
2
  • $\begingroup$ Very good (+1). Is it possible to add some code to your answer? $\endgroup$ Oct 12, 2020 at 12:56
  • $\begingroup$ I did post some code, as requested. Strangely, the image obtained with this code looks like it is a 3D image, particularly when I move some distance away from the screen. $\endgroup$ Oct 12, 2020 at 16:12
1
$\begingroup$

As promised above, I played a bit more. This time using Nestlist, what make things much easier. Please play with it.

tr = TranslationTransform[{2, 0}].RotationTransform[Pi/9].ScalingTransform[0.99{1,1}];
Graphics[{tx,Polygon[#, VertexTextureCoordinates -> Automatic] & /@ 
   NestList[tr, pol[[1]], 400]}]

enter image description here

tr = TranslationTransform[{1,0}].RotationTransform[Pi/17].ScalingTransform[0.99{1,1}];
Graphics[{tx, 
  Polygon[#, VertexTextureCoordinates -> Automatic] & /@  NestList[tr, pol[[1]],400]}]

enter image description here

tr = TranslationTransform[{2, 0}].RotationTransform[
    Pi/5].ScalingTransform[0.99 {1, 1}];
Graphics[{tx, 
  Polygon[#, VertexTextureCoordinates -> Automatic] & /@ 
   NestList[tr, pol[[1]], 400]}

enter image description here

tr = TranslationTransform[{3, 0}].RotationTransform[
    Pi/6.7].ScalingTransform[0.99 {1, 1}];
Graphics[{tx, 
  Polygon[#, VertexTextureCoordinates -> Automatic] & /@ 
   NestList[tr, pol[[1]], 400]}]

enter image description here

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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