6
$\begingroup$

I would like to learn how to recreate this fractal in Mathematica and make others in the same style:

https://m.imgur.com/r/FractalGifs/lYEK8Cd

enter image description here

$\endgroup$
  • 3
    $\begingroup$ The downvote is not from me but thinking about it, this might be easier with a unmanipulated image of the dog as a reference... $\endgroup$ – Henrik Schumacher Feb 22 '19 at 19:17
  • 1
    $\begingroup$ Combine a set of AffineTransforms and use those with ImageTransformation to adjust the original image padding around the edges with 0 (Black) then add them together $\endgroup$ – b3m2a1 Feb 22 '19 at 19:17
  • $\begingroup$ There is a related post here on the Wolfram Mathematica Blog. $\endgroup$ – Ted Ersek Feb 25 '19 at 0:19
10
$\begingroup$

Making the GIF

I'm bored so let me GIF this up for you. I whipped out my trusty lasoo tool to make a no-background doge for you. The final result looks like this:

enter image description here

Here's how we use a variant of that IFS to make the frames of that GIF.

fadeFrame[sides_: 20, bottom_: 40] :=
  ImageEffect[
    ImageEffect[#, {"FadedFrame", sides, {Left, Right}}],
    {"FadedFrame", bottom, {Bottom}}
    ] &;

dogeImg2 =
  ImagePad[
      Import["https://i.stack.imgur.com/BM8Bu.png"],
      {{0, 0}, {0, 100}},
      GrayLevel[1, 0]
      ] // ImageResize[#, Scaled[.5]] & //
    
    ImageTake[#, {.75, {.1, .85}}*Reverse@ImageDimensions[#] // 
       Apply[Sequence]] & // fadeFrame[];

dogeIFS2 =
  With[{scales = {1/5, 1/3}},
   With[{
     transfs = DiagonalMatrix[{1, 1}]/# & /@ scales,
     shifts = {{0.26, .98}, {0.65, .95}}/scales
     },
    MapThread[
     AffineTransform[{#, -#2}] &,
     {transfs, shifts}
     ]
    ]
   ];

dogesRaw =
  Table[
   ImageCompose[#, makeIFSImage[#, dogeIFS2, 4]] &@
    ImageResize[dogeImg2, Scaled[scaling]],
   {scaling, 1, 3, .1}
   ];
    
    dogeIFS2 =
      With[{scales = {1/5, 1/3}},
       With[{
         transfs = DiagonalMatrix[{1, 1}]/# & /@ scales,
         shifts = {{0.26, .98}, {0.65, .95}}/scales
         },
        MapThread[
         AffineTransform[{#, -#2}] &,
         {transfs, shifts}
         ]
        ]
       ];
    
    doges =
      Table[
       ImageTake[
        makeIFSImage[
         ImageResize[dogeImg2, Scaled[scaling]],
         dogeIFS2,
         4
         ],
        Sequence @@
         Times[
          {1, -1},
          Reverse@ImageDimensions[
            dogeImg2
            ]
          ]
        ],
       {scaling, 1, 3, .1}
       ];

Your computer will churn for a while while it makes all those images, but you get a pretty good result. Then we'll stabilize the images and take only the region of interest for a nice GIF:

topWhiteSpacePadding = 14; (*these are fudge factors to make the GIF stableish *)
rightWhiteSpacePadding = 7;

dogesProcessed =
  Table[
   With[
    {
     dims1 = ImageDimensions[doge],
      dims2 = ImageDimensions[dogeImg2]
     },
    With[{scaling = dims1[[2]]/dims2[[2]]},
     (*fadeFrame[0, 0]@*)
     ImageTake[
      doge,
      {
        0,
        dims2[[2]]
        } + (scaling - 1)*topWhiteSpacePadding,
      {
        dims1[[1]] - dims2[[1]],
        dims1[[1]]
        } - (scaling - 1)*rightWhiteSpacePadding
      ]
     ]
    ],
   {doge, dogesRaw}
   ];

Finally we export with some other GIF-specific tweaks:

Export["~/Desktop/dogeGif.gif", 
 dogesProcessed[[2 ;;]], 
 "AnimationRepetitions" -> Infinity,
  "DisplayDurations" ->
  Join[
   ConstantArray[.06, 10],
   ConstantArray[.02, 10]
   ]
 ]

And in the end you have that GIF up there.

Original

Here's a fun example. We'll use this basic doge:

enter image description here

Then we fade the frame, define our IFS, and doge away:

dogeImg = 
  ImageEffect[
   Import["https://i.stack.imgur.com/igIrh.png"], {"FadedFrame", 40}];

dogeIFS =
  With[{scale = 1/3},
   With[{D = 1/scale*DiagonalMatrix[{1, 1}]}, {
     AffineTransform[{D, -{0.26, 0.80}/scale}],
     AffineTransform[{D, -{0.6, 0.7}/scale}]
     }]
   ];

makeIFSImage[dogeImg, dogeIFS]

enter image description here

Code

Here's the approach I mentioned in my comment:

imageIFS[imgs_List, funs_List] :=
  Flatten@Table[
    ImageTransformation[img, fn,
     DataRange -> Automatic,
      Padding -> Transparent
     ],
    {img, imgs},
    {fn, funs}
    ];
imageIFS[img_?ImageQ, funs_List] :=
  imageIFS[{img}, funs];
makeIFSImage[img_?ImageQ, funs_List, iterations_: 4] :=
 
 Fold[ImageCompose,
  Flatten@
   NestList[
    imageIFS[#, funs] &,
    img,
    iterations
    ]
  ]

When applied to the Sierpinski triangle with a sample test image it looks like this:

img = ExampleData[{"TestImage", "Mandrill"}];

sierpinksiGasketFS =
  With[{D = 2*DiagonalMatrix[{1, 1}]}, {
    AffineTransform[{D}],
    AffineTransform[{D, -{1, 0}}],
    AffineTransform[{D, -{0, 1}}]
    }];

makeIFSImage[img, sierpinksiGasketFS]

enter image description here

You can easily tweak sierpinksiGasketFS to get it to position the images differently and scale them differently.

Another version could be done just using Graphics and Inset and using a basic IFS to generate to points for the inset but I'll leave that for someone else.

| improve this answer | |
$\endgroup$
  • $\begingroup$ Oh wait, but it doesn't zoom 🙁 $\endgroup$ – user5601 Feb 23 '19 at 18:14
  • $\begingroup$ @user5601 if you want it to be a GIF like that try modifying the input image to zoom on that for like 10 different scaling factors and make a GIF with "AnimationRepetitions"->Infinity $\endgroup$ – b3m2a1 Feb 23 '19 at 23:06
7
$\begingroup$

I didn't bother generating the nested fractal still since I don't have the original image. But here's how to semi-eyeball an animation with the still provided by OP. Because of this, my GIF will lose noticeable quality as it zooms.

First let's remove the watermark:

doge = RemoveAlphaChannel[Import["https://i.stack.imgur.com/PGfAi.jpg"]];

mask = Dilation[DeleteSmallComponents[# - DeleteSmallComponents[#] &[Binarize[im, .1]]], 2];

doge = Inpaint[im, mask]

enter image description here

Next I used the interactive coordinates tool to find the coordinates of 2 noses.

enter image description here

The coordinates I picked:

pts = {{227, 360}, {133, 244}};
HighlightImage[doge, pts]

enter image description here

It's clear we need to translate the top point to the bottom point, but how much should we scale by? We can minimize the error through FindMinimum.

translated = ImagePerspectiveTransformation[
  doge, 
  TranslationTransform[Subtract @@ pts], 
  Padding -> "Fixed",
  DataRange -> Full
];

scaledoge[t_?NumericQ] := ImagePerspectiveTransformation[
  translated, 
  ScalingTransform[{t, t}, First[pts]], 
  Padding -> "Fixed", 
  DataRange -> Full
]

t /. Last[Quiet@FindMinimum[ImageDistance[doge, scaledoge[t]], {t, 4.25}]]
4.14845

I'll round this to 4.15 and find the frames. Note that I scale the rate by a power of 1.5 to make the gif smoother.

frames = Most @ Table[
  ImagePerspectiveTransformation[
    doge, 
    ScalingTransform[(3.15 t + 1) {1, 1}, {t, 1 - t}.pts]@*TranslationTransform[{t, 1 - t}.pts - Last[pts]], 
    Padding -> "Fixed", 
    DataRange -> Full
   ], 
   {t, Range[0, 1, 1/24]^1.5}
];

Export["doge_fractal.gif", frames, AnimationRepetitions -> ∞, "DisplayDurations" -> 1/24];

enter image description here

Lastly, here's a comparison between the original image and the translated and scaled one: enter image description here

| improve this answer | |
$\endgroup$
6
$\begingroup$

A real doge: His Serenity Leonardo Loredan, the 75th Doge of Venice, with due credit to Bellini and Chip Hurst:

im = Import[
   "https://upload.wikimedia.org/wikipedia/commons/6/6b/Giovanni_Bellini%2C_portrait_of_Doge_Leonardo_Loredan.jpg"];

doge0 = ImageTake[im, {140, 4226 - 500}];

ctr = {1893, 3345};
doge = ImageCompose[doge0, 
   ImageResize[doge0, ImageDimensions@doge0/10], ctr];

doge = ImageCompose[doge0, 
   ImageResize[doge, ImageDimensions@doge0/10], ctr];

tfun = Last@FindGeometricTransform[
    {{0, 0}, ImageDimensions@doge},
    {ctr - ImageDimensions@doge0/20,
     ctr + ImageDimensions@doge0/20}
    ];

frames = Most@Table[
    ImageResize[
     ImagePerspectiveTransformation[
      doge, {IdentityMatrix[2] (1 - t) + t #[[All, ;; 2]], 
         t Flatten@#[[All, 3]]/First@ImageDimensions@doge} &@
       Most@TransformationMatrix[tfun]],
     ImageDimensions@doge/8.],
    {t, Range[0, 1, 1/24]^1.5}];

Export["/tmp/doge_fractal.gif", frames, 
  AnimationRepetitions -> ∞, "DisplayDurations" -> 1/24];

enter image description here

(Having placed the inset images, the transformation was easier to find. One could derive it by hand as well.)


We can use Inpaint to make the background of the GIF constant.

im = Import[
   "https://upload.wikimedia.org/wikipedia/commons/6/6b/Giovanni_Bellini%2C_portrait_of_Doge_Leonardo_Loredan.jpg"];

bluecoverage = DominantColors[im, Automatic, "CoverageImage"][[1]];

mask = Dilation[DeleteSmallComponents[ColorNegate[bluecoverage]], 
   DiskMatrix[100]];

bg = Blur[
   DeleteSmallComponents[
    ColorNegate[DeleteSmallComponents[bluecoverage, 500]]], 10];

imsmall = ImageResize[ImageTake[im, {140, 4226 - 500}], Scaled[1/8]];
masksmall = ImageResize[ImageTake[mask, {140, 4226 - 500}], Scaled[1/8]];

background = 
  Inpaint[imsmall, masksmall, 
   Method -> {"TextureSynthesis", 
     "Masking" -> ColorNegate[masksmall]}];

{background, SetAlphaChannel[im, bg]}

enter image description here

doge0 = ImageTake[SetAlphaChannel[im, bg], {140, 4226 - 500}];

ctr = {1893, 3345};
doge = ImageCompose[doge0, 
   ImageResize[doge0, ImageDimensions@doge0/10], ctr];

doge = ImageCompose[doge0, 
   ImageResize[doge, ImageDimensions@doge0/10], ctr];

tfun = Last@
   FindGeometricTransform[{{0, 0}, 
     ImageDimensions@doge}, {ctr - ImageDimensions@doge0/20, 
     ctr + ImageDimensions@doge0/20}];

frames = Most@
   Table[RemoveAlphaChannel[
     ImageCompose[background, 
      ImageResize[
       ImagePerspectiveTransformation[
        doge, {IdentityMatrix[2] (1 - t) + t #[[All, ;; 2]], 
           t Flatten@#[[All, 3]]/First@ImageDimensions@doge} &@
         Most@TransformationMatrix[tfun]], 
       ImageDimensions[background]]]], {t, Range[0, 1, 1/24]^1.5}];

Export["/tmp/doge_fractal.gif", frames, 
  AnimationRepetitions -> ∞, "DisplayDurations" -> 1/24];

enter image description here

$\endgroup$

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.