Plotting iterated function system images

Question

I'm new not only to this forum, but to Mathematica in general, evidently. I'm running into an issue, and my best attempts at Googling solutions (and trying the search box for this forum) came up with nothing.

For those not immediately familiar, an iterated function system is a family $\Phi = \{ \phi_{1}, \ldots, \phi_{N} \}$ of contractive maps $ \phi_{j} : \mathbb{R}^{d} \to \mathbb{R}^{d}$, where $d \in \mathbb{N}$. It's well-known that if we define a map $\Phi : 2^{\mathbb{R}^{d}} \to 2^{\mathbb{R}^{d}}$ by $\Phi(S) = \cup_{j = 1}^{N} \phi_{j}(S)$, then if we endow the set $\mathcal{K}(\mathbb{R}^{d})$ of all compact subsets of $\mathbb{R}^{d}$ with the Hausdorff metric, then the map $\Phi$ is a contraction on the complete metric space $\mathcal{K}(\mathbb{R}^{d})$, and thus we can appeal to Banach's fixed point theorem to show that there must exist a compact set $K = K(\Phi) \subseteq \mathcal{K}(\mathbb{R}^{d})$ for which $\Phi(K) = K$, and moreover that for any compact set $K' \subseteq \mathcal{K}(\mathbb{R}^{d})$, we have that $\lim_{k \to \infty} \Phi^{k} (K') = K$ (in ths sense of Hausdorff metric). We call $K$ the attractor of $\Phi$.

Now, the neat things here are twofold. One is that we can get a reasonable visual approximation of $K$ by just looking at $\Phi^{k}(K')$ for large $k$. Moreover, many notable fractals can be described by an IFS, e.g. the Cantor set is the attractor of the IFS $\Phi = \{ x \mapsto \frac{x}{3}, x \mapsto \frac{x + 2}{3} \}$.

What I'm looking for is a way to look at images of the iterates $\Phi^{k}(K)$ for a compact set $K$ (although I'd be satisfied with a finite set). I'm sorry, but I really have no earthly idea where to start with this. I know how to define the functions of the IFS itself, but I'm having trouble actually creating plots of the images, even when I'm just trying to look at a set like $\{ \phi_{1}(\phi_{2}(0)), \phi_{2}(\phi_{1}(0)) \}$, particularly when $d = 1, 2, 3$.

Answer 1

I've written a package that allows you to easily generate images of self-similar sets in the plane. Here is a zip file containing that package, as well as a related package for digraph self-similar sets.

Here's an example of its use that seems related to your needs. We first load the package, after placing it in our $Path, as described in the installation instructions

Needs["FractalGeometry`IteratedFunctionSystems`"]

Next, we define an IFS as a list of {A,b} pairs, where A is a $2\times2$ matrix and $b$ is a shift vector.

IFS = {
  {{{9, 12}, {12, -9}}, {0, 0}},
  {{{9, -12}, {-12, -9}}, {16, 12}},
  {{{-7, 0}, {0, 7}}, {16, 12}}
}/25;

This particular IFS happens to map the triangle with the following vertices into itself.

vertices = {{0, 0}, {1, 0}, {1/2, 2/3}};

In the following code, we use a graphics primitive, like Polygon[vertices] to specify an Initiator; the IFS acts on the picture described by that primitive.

GraphicsGrid[Partition[Table[
  ShowIFS[IFS, k, Colors -> True, ImageSize -> 400,
  Initiator -> {EdgeForm[Black], Polygon[vertices]}],
 {k, 1, 4}], 2]]

Note that the IFS does not map the triangle onto itself in typical Sierpinski-like fashion. In particular, the images are flipped and the scaling factors are not all equal. When the scaling factors are unequal like this, it is sometimes useful to iterate until the pieces are small, rather than some pre-specified number of times throughout. To accomplish this, the second argument to ShowIFS can be a real number between zero and one to indicate how small we want the pieces to be.

ShowIFS[IFS, 0.01, Colors -> True, ImageSize -> 600,
  Initiator -> Polygon[vertices]]

There's also a stochastic version

ShowIFSStochastic[IFS, 50000, Colors -> True, ImageSize -> 600]

And here is the dimension of the set:

FindIFSDimension[IFS]
(* Out: 1.62234 *)

---

For those who might have difficulties obtaining the package, here is the code defining ShowIFS:

Options[ShowIFS] = Union[{AspectRatio -> Automatic,
  Initiator -> Point[{0,0}], Colors -> False, 
  PlotStyle -> {}}, Options[Graphics],
  SameTest -> (First[#1]===First[#2]&)];

ShowIFS[IFS_, depth_Integer?(# >= 0 &), opts___] := Module[
   {initiator, plotStyle, colors, toFunc, funcs, F,
    attractor, at, x},
   initiator = Initiator /. {opts} /. Options[ShowIFS];
   plotStyle = PlotStyle /. {opts} /. Options[ShowIFS];
   colors = Colors /. {opts} /. Options[ShowIFS];

   Which[colors === Automatic || colors === True,
    colors = 
     ColorData["Rainbow"] /@ 
      Range[0., 1 - 1./Length[IFS], 1./Length[IFS]],
    Head[colors] === String,
    colors = 
     ColorData[colors] /@ 
      Range[0., 1 - 1./Length[IFS], 1./Length[IFS]],
    colors =!= None && colors =!= False && Head[colors] =!= List,
    colors = 
     colors /@ Range[0., 1 - 1./Length[IFS], 1./Length[IFS]]];

   toFunc[{A_, b_}] := Module[{cfOut, fOut},
     cfOut = Compile[{{v, _Real, 1}}, A.v + b];
     fOut[{x_?NumericQ, y_?NumericQ}] := cfOut[{x, y}];
     fOut[x_List] := fOut /@ x;
     fOut[Point[pts_]] := Point[fOut[pts]];
     fOut[Line[x_]] := Line[fOut[x]];
     fOut[Arrow[x_]] := Arrow[fOut[x]];
     fOut[Polygon[x_, pOpts___]] := Polygon[fOut[x], pOpts];
     fOut[x_] := x;
     fOut];

   funcs = toFunc /@ IFS;
   F[Point[pt : {_?NumericQ, _?NumericQ}]] := 
    Point[Table[f[pt], {f, funcs}]];
   F[Point[pts : {{_?NumericQ, _?NumericQ} ..}]] :=
    Point[Flatten[Table[f /@ pts, {f, funcs}], 1]];
   F[Line[pts : {{_?NumericQ, _?NumericQ} ..}]] :=
    Line[Table[f /@ pts, {f, funcs}]];
   F[Line[pts : {{{_?NumericQ, _?NumericQ} ..} ..}]] :=
    Line[Flatten[Table[Map[f, pts, {2}], {f, funcs}], 1]];
   F[Arrow[pts : {{_?NumericQ, _?NumericQ} ..}, s___]] :=
    Table[Arrow[f /@ pts, s], {f, funcs}];
   F[Polygon[pts : {{_?NumericQ, _?NumericQ} ..}]] :=
    Polygon[Table[f /@ pts, {f, funcs}]];
   F[Polygon[pts : {{{_?NumericQ, _?NumericQ} ..} ..}]] :=
    Polygon[Flatten[Table[Map[f, pts, {2}], {f, funcs}], 1]];
   F[Polygon[pts : {{_?NumericQ, _?NumericQ} ..}, 
      VertexColors -> vc_]] :=
    Polygon[Table[f /@ pts, {f, funcs}], 
     VertexColors -> Table[vc, {Length[funcs]}]];
   F[Polygon[pts : {{{_?NumericQ, _?NumericQ} ..} ..}, 
      VertexColors -> vc_]] :=
    Polygon[Flatten[Table[Map[f, pts, {2}], {f, funcs}], 1],
     VertexColors -> Flatten[Table[vc, {Length[funcs]}], 1]];
   F[ll_List] := F /@ ll;
   F[x_] := x;
   If[colors =!= False && colors =!= None,
    attractor = Nest[F, initiator, depth - 1];
    attractor = at /@ Table[f[attractor], {f, funcs}];
    attractor = Inner[List, colors, attractor, List] /. 
      at[x__] -> x,
    attractor = Nest[F, initiator, depth]];
   Graphics[attractor,
    FilterRules[{opts}, Options[Graphics]],
    FilterRules[Options[ShowIFS], Options[Graphics]]]
];