Skip to main content
Mathematica

Return to Answer

added 2976 characters in body
Source Link
Mark McClure
Mark McClure
  • 32.6k
  • 3
  • 105
  • 164

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]]] ];

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]]] ];
Source Link
Mark McClure
Mark McClure
  • 32.6k
  • 3
  • 105
  • 164

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]]

enter image description here

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]]

enter image description here

There's also a stochastic version

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

enter image description here

And here is the dimension of the set:

FindIFSDimension[IFS] (* Out: 1.62234 *)