# Construction Steps of Barnsley's Fern

I am helping a friend with his thesis and we would like to do the following:

We would like to show the construction of Barnsley's fern fractal by starting on the zeroth step with a big ellipse, then on the first step drawing two smaller ellipses, rotated and placed on the sides of the first one plus one more ellipse of the same size, placed on the bottom etc. We are actually trying to show each iteration as a sequence of pictures in order for it to be understood by the reader.

So far, I have only found the Barnsley's ftern to be constructed in way similar to the Chaos game sierpinski triangle, but none in the way I mention above. Is it possible to do so?

Thank you.

• Are you absolutely certain you don't mean Barnsley's fern? Commented Aug 27, 2016 at 13:21
• @kirma oups! :D Commented Aug 27, 2016 at 13:23

After playing with the variables in a Manipulate I came up with these numbers for the arguments of the AffineMap functions.

They aren't perfect. I recommend tuning them yourself:

         (* Activate Roman Maeder's Code first!* )

(fract2[x_, n_] := Show[Graphics[Nest[IFS[{
AffineMap[0 °, 0 °, 0, 0, 0.18, 0],
AffineMap[-2.5 °, -2.5 °, 0.90, 0.90, 0, 1.7],
AffineMap[49 °, 49 °, 0.33, 0.33, 0, 1.7],
AffineMap[120 °, -50 °, 0.33, 0.33, 0.0, 0.33]}],
x, n]], Axes ->  False,
AspectRatio ->  Automatic,
AxesOrigin -> {0, 0}];
Table[fract2[Circle[{1, 1}, {1, 2}], c], {c, 8}])


You set the initial conditions: AffineMap provides the fractal Step

This is Roman Maeder's AffineMap function and IFS

$CirclePoints = 24 Format[m_map] := "-map-" AffineMap[phi_, psi_, r_, s_, e_, f_] := map[{{r Cos[phi], -s Sin[psi], e}, {r Sin[phi], s Cos[psi], f}}] AffineMap[params : {_Symbol, _Symbol}, expr : {_, _}] := map[Function[params, expr]] AffineMap[mat_?MatrixQ] /; Dimensions[mat] == {2, 3} := map[mat] map[mat_?MatrixQ][{x_, y_}] := mat.{x, y, 1} map[f_Function][{x_, y_}] := f[x, y] map /: Composition[map[mat1_?MatrixQ], map[mat2_?MatrixQ]] := map[mat1.Append[mat2, {0, 0, 1}]] map /: Composition[map[f_Function], map[g_Function]] := Module[{x, y}, AffineMap[{x, y}, f @@ g[x, y]]] AverageContraction[map[mat_?MatrixQ]] := Abs[Det[Drop[#, -1] & /@ mat]] AverageContraction[map[f_Function]] := Module[{x, y}, Abs[Det[Outer[D, f[x, y], {x, y}]]]] (m_map)[Point[xy_]] := Point[m[xy]] (m_map)[Line[points_]] := Line[m /@ points] (m_map)[Polygon[points_]] := Polygon[m /@ points] (m_map)[Rectangle[{xmin_, ymin_}, {xmax_, ymax_}]] := m[Polygon[{{xmin, ymin}, {xmax, ymin}, {xmax, ymax}, {xmin, ymax}}]] (m_map)[Circle[xy_, {rx_, ry_}]] := With[{dp = N[2 Pi/$CirclePoints]},
m[Line[Table[xy + {rx Cos[phi], ry Sin[phi]}, {phi, 0, 2 Pi, dp}]]]]

(m_map)[Circle[xy_, r_]] := m[Circle[xy, {r, r}]]

(m_map)[Disk[xy_, {rx_, ry_}]] :=
With[{dp = N[2 Pi/\$CirclePoints]},
m[Polygon[
Table[xy + {rx Cos[phi], ry Sin[phi]}, {phi, 0, 2 Pi - dp, dp}]]]]

(m_map)[Disk[xy_, r_]] := m[Disk[xy, {r, r}]]

(m_map)[(Circle | Disk)[xy_, r_, args__]] :=
Sequence[]

(m_map)[Text[text_, pos : {_, _}, args___]] := Text[text, m[pos], args]
(m_map)[(h :
PointSize | AbsolutePointSize | Thickness | AbsoluteThickness)    [r_]] := h[r Sqrt[AverageContraction[m]]]

(m_map)[Graphics[objs_List, opts___]] :=
Graphics[Function[g, m[g], Listable] /@ objs, opts]

(m_map)[unknown_] := unknown

rotation[alpha_] := AffineMap[alpha, alpha, 1, 1, 0, 0]

scale[s_, t_] := AffineMap[0, 0, s, t, 0, 0]
scale[r_] := scale[r, r]

translation[{x_, y_}] := AffineMap[0, 0, 1, 1, x, y]

Options[IFS] = {Probabilities -> Automatic};

Format[_ifs] := "-ifs-"

optnames = First /@ Options[IFS]

IFS[ms : {_map ...}, opts___?OptionQ] :=
Module[{optvals},
optvals = optnames /. Flatten[{opts}] /. Options[IFS];

ifs[ms_List, _][gr : Graphics[_, opts___]] :=
Graphics[First /@ Through[ms[gr]], opts]
(i_ifs)[objs_List] := i /@ objs
ifs[ms_List, _][obj_] := Through[ms[obj]]


The examples below are from the book and they use points.

 collage1[x_, n_] := Graphics[Nest[IFS[{
AffineMap[-2 °, -2 °, 0.02, 0.6, -0.14, -0.8],
AffineMap[0, 0, 0.6, 0.4, 0, 1.2],
AffineMap[-30 °, -30 °, 0.4, 0.7, 0.6, -0.35],
AffineMap[30 °, 30 °, 0.4, 0.65, -0.7, -0.5]}],
x, n],
Axes -> False,
AspectRatio -> Automatic,
AxesOrigin -> {0, 0},
ColorOutput -> (RGBColor[0.316411, 0.699229, 0.0585946] &)];

Show[collage1[Point[{0, 0}], 8]]


  collage2[x_, n_] := Graphics[Nest[IFS[{
AffineMap[0 °, 0 °, 0, 0, 0.16, 0],
AffineMap[-2.5 °, -2.5 °, 0.85, 0.85, 0, 1.6],
AffineMap[49 °, 49 °, 0.3, 0.34, 0, 1.6],
AffineMap[120 °, -50 °, 0.3, 0.37, 0.0, 0.37]}],
x, n],
Axes -> False,
AspectRatio -> Automatic,
AxesOrigin -> {0, 0},
ColorOutput -> (RGBColor[0.316411, 0.699229, 0.0585946] &)];

Show[collage2[Point[{0, 0}], 8]]


I took this from

• Thank you for your perfect answer! I will try to tune them up and if I have any questions regarding the code I will ask again. One more time, thanks! Commented Aug 27, 2016 at 17:40
• Might I recommend using a triangle instead of an oval? It would make it easier to see which of the sub-shapes are mirrored. (You could also add a dot/line/arrow inside the oval to show the same thing.) The limit should be the same for any starting shape. Commented Aug 27, 2016 at 18:36
• Very good idea! @Joshua Taylor Commented Aug 27, 2016 at 18:52

I've got a package that makes dealing with iterated function systems pretty easy. You can download it off of my webspace. That package implements both deterministic and stochastic alorithms to generate images of self-affine sets like the Barnesly fern

Also, I think we can use a better initial shape than an oval. Let's use the functions of the IFS to obtain an outline of the set:

barnsleyFernIFS = {
{{{.85, .04}, {-.04, .85}}, {0, 1.6}},
{{{-.15, .28}, {.26, .24}}, {0, .44}},
{{{.2, -.26}, {.23, .22}}, {0, 1.6}},
{{{0, 0}, {0, .16}}, {0, 0}}};
toFunction[{A_, b_}] := A.# + b &;
{f1, f2, f3, f4} = toFunction /@ barnsleyFernIFS;
tip = {x, y} /. First[Solve[f1[{x, y}] == {x, y}, {x, y}]];
leftSide = NestList[f1, f2[tip], 30];
rightSide = NestList[f1, f3[tip], 30];
outline = Join[{{0, 0}}, rightSide, {tip}, Reverse[leftSide]];
init = {EdgeForm[Black], Polygon[outline]};
Graphics[{Gray, init}]


Now, if you have the package above installed, you can do the following:

Needs["FractalGeometryIteratedFunctionSystems"];
pics = Table[
ShowIFS[barnsleyFernIFS, k, Initiator -> init, Colors ->
{Darker[Green], Green, Green, Black}], {k, 1, 4}];
GraphicsRow[pics]


The result illustrates a difficulty with this approach when the pieces of the attractor have different sizes like this. The ShowIFS command implements another version of the deterministic algorithm where the pieces are decomposed until they reach a certain size, rather than a certain depth. To access this approach, we simply make the second argument a real number smaller than one to indicate how small we want the sizes to be - rather than an integer indicating the depth. This allows us to generate a picture like so:

init = {EdgeForm[Opacity[0.3]], Polygon[outline]};
ShowIFS[barnsleyFernIFS, 0.02, Initiator -> init, Colors ->
{Darker[Green], Green, Green, Black}]


If you'd like to illustrate how this process works, it probably makes the most sense to do so dynamically:

Manipulate[
ShowIFS[barnsleyFernIFS, r, Initiator -> init, Colors ->
{Darker[Green], Green, Green, Black}],
{{r, 0.9}, 0.1, 0.9}]


This allows you to see the decomposition happen as you move the slider down.

• this is amazing. Commented Aug 28, 2016 at 16:48
• @ConorCosnett Thanks! Commented Aug 28, 2016 at 17:49
• @MarkMcClure Indeed, it is stunning. You can actually work out any fractal out of this, right? Commented Aug 29, 2016 at 9:18
• @Mitscaype I'm not sure I fully understand what you're asking. The package implements several Iterated Function System algorithms, so you should be able to generate any fractal that is the invariant set of an IFS. Not other fractal types, though. Commented Aug 29, 2016 at 12:38
• @MarkMcClure Excuse me, I did not mention it, but I meant any IFS fractal. Thank you again for the package, it is really useful! Commented Aug 29, 2016 at 13:27