Graphics Simulations

Applied to MATh.en.JEANS research workshop themes

February 27, 2025 - Yves Papegay - yap@informathiques.fr

This notebook is the final version of the support of the fourth session of the course “Online teacher training and community of practices - Digital tools for STEAM education and Makers pedagogy, November 2024 - June 2025” , an activity of the “MEJ MAKERS ERASMUS+ project (2023-2-FR01-KA210-SCH-000176068)” - visit the course dedicated web page for details.

Cactus

Rules-based evolution

In this example, the evolution is based on a substitution : moving from one generation to another consists in substituting (replacing) each “F” by “FF[+F–F]FF[-F +F ]FF”. Such evolution are implemented by rules or by the SubstitutionSystem function in the Wolfram Language.

It allows, for example, to directly compute the string corresponding to the fourth generation, given that the first generation is “F” :

Let’s start by defining the rule...

rule="F"->"FF[+F-F]FF[-F+F]FF"

...and then compute the corresponding substitutions for the fourth generation.

SubstitutionSystem[rule,"F",{3}]

Analyzing the evolution

Being able to compute with large strings allows us to compute in a reasonable time up to 8 evolutions as we can see on the following try.

First[Timing[SubstitutionSystem[rule,"F",1]]]
First[Timing[SubstitutionSystem[rule,"F",2]]]
First[Timing[SubstitutionSystem[rule,"F",3]]]
First[Timing[SubstitutionSystem[rule,"F",4]]]
First[Timing[SubstitutionSystem[rule,"F",5]]]
First[Timing[SubstitutionSystem[rule,"F",6]]]
First[Timing[SubstitutionSystem[rule,"F",7]]]
First[Timing[SubstitutionSystem[rule,"F",8]]]

It can be used to support intuitive guesses and help to find interesting properties.

Let’s compute the 8 first evolutions and store theme in a variable.

evolution=SubstitutionSystem[rule,"F",8];

Number of characters at generation

Compute the number of characters of the 9 first generations

Map[StringLength,evolution]

To understand the previous result compute the number of ”F” in each generation

Map[StringCount[#,"F"]&,evolution]

Can you now deduct the formula that give the number of characters of the (n^(-th)) generation ?

(c/.RSolve[{f[n+1]-10f[n]==0,c[n+1]==17f[n]+c[n],f[1]==1,c[1]==1},{f,c},n][[1]])[n]

Visualizing the evolution

To visualize the evolution, we have to interpret the string corresponding to a generation as a sequence of graphical directives and associated displacement.

Turtle Graphics

Turtle graphics is a method for drawing based on the movement of a “turtle” that follows a set of commands. It was popularized by the LOGO programming language. Commands typically include moving forward or backward, turning left or right by specific angles, and controlling the drawing state (pen up or down). This approach allows for creating complex shapes and patterns through simple, iterative instructions. In the Wolfram Language, the (TextRefLink[AnglePath, paclet:ref/AnglePath, https://reference.wolfram.com/language/ref/AnglePath.html]) function can be used to compute such paths based on turns and movements.

Compared to the usual way of describing a graphics as a sequence of primitive objects defined with respect to a fixed reference frame, turtle graphics require to maintain, step after step the current position and orientation.

DynamicModule[{turtle,steps={},path,points},
 turtle=;
 Manipulate[
  path=AnglePath[{0.,0.},steps,{"Position","FrameMatrix"}];
  points=path[[All,1]];
  Graphics[{
    Line[points],
    GeometricTransformation[turtle[[1]],
      AffineTransform[{path[[-1,2]],Last[points]}]]
    },
   Axes->True,
   PlotRange->{{-10,10},{-10,10}},
   ImageSize->{400,400}
   ],
  Row[{Control[{{r,1},0,5,1,ControlType->SetterBar}],Spacer[20],
    Control[{{θ,0},-Pi,Pi,AngularGauge[##,ImageSize->125,ScaleOrigin->{-Pi,Pi}]&}]}],
  Button["Next step",AppendTo[steps,{r,θ}];θ=0],
  Button["Restart",{steps={},r=1.,θ=0.}]
  ]
]

We will use turtle graphics method in the following.

Cactus basic part

Let’s first design a basic element of a cactus

cactusBasic={Darker[Green],Rectangle[{-1,-1},{1,9},RoundingRadius->1],Disk[{-1,2},1],Disk[{1,6},1]};
Graphics[cactusBasic]

and a function that produces the corresponding graphics at any given position and orientation and the corresponding new position and orientation

cactus[{p_,o_}]:={GeometricTransformation[cactusBasic,AffineTransform[{RotationMatrix[o],p}]],{p+RotationMatrix[o+Pi/2].{8,0},o}}

Graphics[Map[First,{cactus[{{0,0},0}],cactus[{{0,8},Pi/2}],cactus[{{-8,8},0}]}]]

Map[Last,{cactus[{{0,0},0}],cactus[{{0,8},Pi/2}],cactus[{{-8,8},0}]}]

Main algorithm

To construct the final graphics sequence, we will read each character one after the other, and acts in consequence : we will maintain a list of graphics primitives, a list of positions, the current position and the current orientation. Depending on the first character to read, we will add a graphic to the list (if it is “F”), we will change the current orientation (if it is “+“ or “-“), we will memorize the current position and orientation (if it is “[“), or we will update the current position (if it is “F” or “]”).

Let’s define the function draw1 performing these actions :

Clear[draw1]
draw1[{{graph___},{mem___},{curpos_,curor_}},"F"]:=With[{c=cactus[{curpos,curor}]},{{graph,First[c]},{mem},Last[c]}]
draw1[{{graph___},{mem___},{curpos_,curor_}},"["]:={{graph},{mem,{curpos,curor}},{curpos,curor}}
draw1[{{graph___},{mem___},{curpos_,curor_}},"]"]:={{graph},Most[{mem}],Last[{mem}]}
draw1[{{graph___},{mem___},{curpos_,curor_}},"+"]:={{graph},{mem},{curpos,curor+Pi/2}}
draw1[{{graph___},{mem___},{curpos_,curor_}},"-"]:={{graph},{mem},{curpos,curor-Pi/2}}

and the function draw calling draw1 through the Fold operator and drawing the graphics :

draw[s_String]:=Graphics[Fold[draw1,{{},{},{{0,0},0}},Characters[s]][[1]]]

draw[evolution[[2]]]
draw[evolution[[3]]]
draw[evolution[[4]]]

Size of the cactus

As a benefit of the computation of the sequence of graphics directive, we can get the whole set of positions, and then get the size (measured in cactus basic parts).

Let’s define the function bounds computing the minimal and maximal reached positions

bounds[s_String]:=Map[MinMax,Transpose[With[{e=Fold[draw1,{{},{},{{0,0},0}},Characters[s]]},Append[Map[Last[Last[#]]&,First[e]],First[Last[e]]]]]]/8

b=Table[bounds[evolution[[i]]],{i,1,5}]

{Map[Last[First[#]]&,b],Map[Last[Last[#]]&,b]}

RSolve[{a[0]==0,a[n+1]==6a[n]+1},a,n]

Magic Stairs

Matrix based encoding

Like in the previous theme, evolution is rule-based, and we need to find an encoding to represent it.

A first idea

There are 4 pattens in the magic stairs, let’s denote them by “A”, “B”, “C” and “D”

graphRules=Thread[{"A","B","C","D"}->{Graphics[{{Darker[Green],Line[{{0,0},{1,0},{1,1},{0,1},{0,0}}]},{Thickness[0.02],Arrowheads[.2],Arrow[{{0,0},{1,1}}]}}],Graphics[{{Darker[Green],Line[{{0,0},{1,0},{1,1},{0,1},{0,0}}]},{Thickness[0.02],Arrowheads[.2],Arrow[{{1,0},{0,1}}]}}],Graphics[{{Darker[Green],Line[{{0,0},{1,0},{1,1},{0,1},{0,0}}]},{Thickness[0.02],Arrowheads[.2],Arrow[{{0,1},{1,0}}]}}],Graphics[{{Darker[Green],Line[{{0,0},{1,0},{1,1},{0,1},{0,0}}]},{Thickness[0.02],Arrowheads[.2],Arrow[{{1,1},{0,0}}]}}]}]

First rule is described above :

rule1="A"->{{"A","C","A"},{"B","D","B"},{"A","C","A"}};
("A"/.graphRules )-> Grid["A"/.rule1/.graphRules]

Other rule can be deduced by rotating the scheme :

rule2="B"->{{"B","D","B"},{"A","C","A"},{"B","D","B"}};
rule3="C"->{{"C","A","C"},{"D","B","D"},{"C","A","C"}};
rule4="D"->{{"D","B","D"},{"C","A","C"},{"D","B","D"}};
TabView[{("A"/.graphRules )-> Grid["A"/.rule1/.graphRules],("B"/.graphRules )->Grid["B"/.rule2/.graphRules],("C"/.graphRules )->Grid["C"/.rule3/.graphRules],("D"/.graphRules )->Grid["D"/.rule4/.graphRules]}]

rules={rule1,rule2,rule3,rule4};

Nest[ReplaceAll[#,rules]&,"A",1]/.graphRules//Grid

ArrayFlatten[Nest[ReplaceAll[#,rules]&,"A",2]/.graphRules]//Grid

ArrayFlatten[ArrayFlatten[Nest[ReplaceAll[#,rules]&,"A",3]/.graphRules]]//Grid

This encoding is too poor, because it does not represent the complete path to follow

Matrix based coding

graphRules={{"A",a_}:>Graphics[{GrayLevel[1-0.1a],Rectangle[{0,0},{1,1}],{Darker[Green],Line[{{0,0},{1,0},{1,1},{0,1},{0,0}}]},{Red,Thickness[0.02],Arrowheads[.2],Arrow[{{0,0},{1,1}}]}}],{"B",b_}:>Graphics[{GrayLevel[1-0.1b],Rectangle[{0,0},{1,1}],{Darker[Green],Line[{{0,0},{1,0},{1,1},{0,1},{0,0}}]},{Red,Thickness[0.02],Arrowheads[.2],Arrow[{{1,0},{0,1}}]}}],{"C",c_}:>Graphics[{GrayLevel[1-0.1c],Rectangle[{0,0},{1,1}],{Darker[Green],Line[{{0,0},{1,0},{1,1},{0,1},{0,0}}]},{Red,Thickness[0.02],Arrowheads[.2],Arrow[{{0,1},{1,0}}]}}],{"D",d_}:>Graphics[{GrayLevel[1-0.1d],Rectangle[{0,0},{1,1}],{Darker[Green],Line[{{0,0},{1,0},{1,1},{0,1},{0,0}}]},{Red,Thickness[0.02],Arrowheads[.2],Arrow[{{1,1},{0,0}}]}}]};
Map[#->({#,0}/.graphRules)&,{"A","B","C","D"}]

First rule is described above :

rule1={"A",i_}:>{{{"A",9(i-1)+3},{"C",9(i-1)+4},{"A",9(i-1)+9}},{{"B",9(i-1)+2},{"D",9(i-1)+5},{"B",9(i-1)+8}},{{"A",9(i-1)+1},{"C",9(i-1)+6},{"A",9(i-1)+7}}};
({"A",0}/.graphRules )-> Grid[{"A",1}/.rule1/.graphRules]

Other rule can be deduced by rotating the scheme :

rule2={"B",i_}:>{{{"B",9(i-1)+9},{"D",9(i-1)+8},{"B",9(i-1)+7}},{{"A",9(i-1)+4},{"C",9(i-1)+5},{"A",9(i-1)+6}},{{"B",9(i-1)+3},{"D",9(i-1)+2},{"B",9(i-1)+1}}};
rule3={"C",i_}:>{{{"C",9(i-1)+1},{"A",9(i-1)+2},{"C",9(i-1)+3}},{{"D",9(i-1)+4},{"B",9(i-1)+5},{"D",9(i-1)+6}},{{"C",9(i-1)+7},{"A",9(i-1)+8},{"C",9(i-1)+9}}};
rule4={"D",i_}:>{{{"D",9(i-1)+7},{"B",9(i-1)+6},{"D",9(i-1)+1}},{{"C",9(i-1)+8},{"A",9(i-1)+5},{"C",9(i-1)+2}},{{"D",9(i-1)+9},{"B",9(i-1)+4},{"D",9(i-1)+3}}};
TabView[{({"A",0}/.graphRules )-> Grid[{"A",1}/.rule1/.graphRules],({"B",0}/.graphRules )->Grid[{"B",1}/.rule2/.graphRules],({"C",0}/.graphRules )->Grid[{"C",1}/.rule3/.graphRules],({"D",0}/.graphRules )->Grid[{"D",1}/.rule4/.graphRules]}]

rules={rule1,rule2,rule3,rule4};

Row[{{"A",1}/.rules/.{s_String,i_Integer}->s//MatrixForm,
{"A",1}/.rules/.{s_String,i_Integer}->i//MatrixForm}]
{"A",1}/.rules/.graphRules//Grid

ArrayFlatten[Nest[ReplaceAll[#,rules]&,{"A",1},2]]

MatrixForm[ArrayFlatten[Nest[ReplaceAll[#,rules]&,{"A",1},2]]/.{s_String,i_Integer}->i]
ArrayPlot[ArrayFlatten[Nest[ReplaceAll[#,rules]&,{"A",1},2]]/.{s_String,i_Integer}->i]

MatrixForm[ArrayFlatten[ArrayFlatten[Nest[ReplaceAll[#,rules]&,{"A",1},3]]]/.{s_String,i_Integer}->i]
ArrayPlot[ArrayFlatten[ArrayFlatten[Nest[ReplaceAll[#,rules]&,{"A",1},3]]]/.{s_String,i_Integer}->i]

Graphics3D[With[{mat=ArrayFlatten[Nest[ReplaceAll[#,rules]&,{"A",1},2]]/.{s_String,i_Integer}->i},Table[{RandomColor[],Cuboid[{i,j,0},{i+1,j+1,mat[[i,j]]/Length[mat]}]},{i,1,Length[mat]},{j,1,Length[mat]}]],Lighting->"Neutral"]

Graphics3D[With[{mat=ArrayFlatten[Nest[ReplaceAll[#,rules]&,{"A",1},2]]/.{s_String,i_Integer}->i},Table[{RandomColor[],Ball[{i,j,mat[[i,j]]/Length[mat]},0.5]},{i,1,Length[mat]},{j,1,Length[mat]}]],Lighting->"Neutral"]

Graphics3D[With[{mat=ArrayFlatten[Nest[ReplaceAll[#,rules]&,{"A",1},2]]/.{s_String,i_Integer}->i},Table[{RandomColor[],Cylinder[{{i,j,0},{i,j,mat[[i,j]]/Length[mat]}},0.5]},{i,1,Length[mat]},{j,1,Length[mat]}]],Lighting->"Neutral"]

Graphics3D[With[{mat=ArrayFlatten[Nest[ReplaceAll[#,rules]&,{"A",1},2]]/.{s_String,i_Integer}->i},Table[{RandomColor[],Cylinder[{{i,j,mat[[i,j]]/Length[mat]-0.1},{i,j,mat[[i,j]]/Length[mat]}},0.5]},{i,1,Length[mat]},{j,1,Length[mat]}]],Lighting->"Neutral"]

Graphics3D[With[{mat=ArrayFlatten[ArrayFlatten[Nest[ReplaceAll[#,rules]&,{"A",1},3]]]/.{s_String,i_Integer}->i},Table[{GrayLevel[1-0.1(Mod[mat[[i,j]]-1,9])],Cuboid[{i,j,0},{i+1,j+1,mat[[i,j]]/Length[mat]}]},{i,1,Length[mat]},{j,1,Length[mat]}]],Lighting->"Neutral"]

Graphics3D[With[{mat=ArrayFlatten[ArrayFlatten[ArrayFlatten[Nest[ReplaceAll[#,rules]&,{"A",1},4]]]]/.{s_String,i_Integer}->i},Table[{GrayLevel[1-0.1(Mod[mat[[i,j]]-1,9])],Cuboid[{i,j,0},{i+1,j+1,mat[[i,j]]/Length[mat]}]},{i,1,Length[mat]},{j,1,Length[mat]}]],Lighting->"Neutral"]

String based encoding

We can also encode our stairs using a string, namely the one describing the path with a Turtle Graphics approach.

"FF-F-FF+F+FF"->Graphics[{{Darker[Green],Table[Line[{{0,i},{3,i}}],{i,0,3}],Table[Line[{{i,0},{i,3}}],{i,0,3}]},{LightGray,Thickness[0.01],Arrowheads[.1],Arrow[{{0,0},{1,1}}],Arrow[{{1,1},{0,2}}],Arrow[{{0,2},{1,3}}],Arrow[{{1,3},{2,2}}],Arrow[{{2,2},{1,1}}],Arrow[{{1,1},{2,0}}],Arrow[{{2,0},{3,1}}],Arrow[{{3,1},{2,2}}],Arrow[{{2,2},{3,3}}]},{PointSize[0.02],Table[Point[{i+0.5,j+0.5}],{i,0,2},{j,0,2}],Arrow[{{0.5,0.5},{0.5,1.5}}],Arrow[{{0.5,1.5},{0.5,2.5}}],Arrow[{{0.5,2.5},{1.5,2.5}}],Arrow[{{1.5,2.5},{1.5,1.5}}],Arrow[{{1.5,1.5},{1.5,0.5}}],Arrow[{{1.5,0.5},{2.5,0.5}}],Arrow[{{2.5,0.5},{2.5,1.5}}],Arrow[{{2.5,1.5},{2.5,2.5}}]}}]

To understand the substitution we need to go one step further

"SF+S-FS-FS-FSF+SF+SF+S-FS"->Graphics[{{Darker[Green],Table[Line[{{0,i},{9,i}}],{i,0,9}],Table[Line[{{i,0},{i,9}}],{i,0,9}]},{LightGray,Thickness[0.005],Arrowheads[.04],Table[Arrow[{{0+2i,0+2j},{1+2i,1+2j}}],{i,0,4},{j,0,4}],Table[Arrow[{{1+2i,1+2j},{0+2i,2+2j}}],{i,0,4},{j,0,3}],Table[Arrow[{{1+2i,3+2j},{2+2i,2+2j}}],{i,0,3},{j,-1,3}],Table[Arrow[{{2+2i,2+2j},{1+2i,1+2j}}],{i,0,3},{j,0,3}]},{PointSize[0.01],Table[Point[{i+0.5,j+0.5}],{i,0,8},{j,0,8}],{Line[{{0.5,0.5},{0.5,2.5},{1.5,2.5},{1.5,1.5},{1.5,0.5},{2.5,0.5},{2.5,1.5},{2.5,2.5}}],Line[{{2.5,3.5},{1.5,3.5},{0.5,3.5},{0.5,4.5},{1.5,4.5},{2.5,4.5},{2.5,5.5},{1.5,5.5},{0.5,5.5}}],Line[{{0.5,6.5},{0.5,7.5},{0.5,8.5},{1.5,8.5},{1.5,7.5},{1.5,6.5},{2.5,6.5},{2.5,7.5},{2.5,8.5}}],Line[{{3.5,8.5},{4.5,8.5},{5.5,8.5},{5.5,7.5},{4.5,7.5},{3.5,7.5},{3.5,6.5},{4.5,6.5},{5.5,6.5}}],Line[{{5.5,5.5},{5.5,4.5},{5.5,3.5},{4.5,3.5},{4.5,4.5},{4.5,5.5},{3.5,5.5},{3.5,4.5},{3.5,3.5}}],Line[{{3.5,2.5},{4.5,2.5},{5.5,2.5},{5.5,1.5},{4.5,1.5},{3.5,1.5},{3.5,0.5},{4.5,0.5},{5.5,0.5}}],Line[{{6.5,0.5},{6.5,1.5},{6.5,2.5},{7.5,2.5},{7.5,1.5},{7.5,0.5},{8.5,0.5},{8.5,1.5},{8.5,2.5}}],Line[{{8.5,3.5},{7.5,3.5},{6.5,3.5},{6.5,4.5},{7.5,4.5},{8.5,4.5},{8.5,5.5},{7.5,5.5},{6.5,5.5}}],Line[{{6.5,6.5},{6.5,7.5},{6.5,8.5},{7.5,8.5},{7.5,7.5},{7.5,6.5},{8.5,6.5},{8.5,7.5},{8.5,8.5}}]}},{Red,Arrow[{{2.5,2.5},{2.5,3.5}}],Circle[{2.5,3.5},0.3,{-Pi/6,5Pi/6}],Arrow[{{3.5,3.5},{3.5,2.5}}],Circle[{3.5,2.5},0.3,{-Pi/6,-7Pi/6}],Arrow[{{8.5,2.5},{8.5,3.5}}],Circle[{8.5,3.5},0.3,{-Pi/6,5Pi/6}],Arrow[{{5.5,0.5},{6.5,0.5}}],Circle[{6.5,0.5},0.3,{-4Pi/6,2Pi/6}]},{Blue,Arrow[{{0.5,5.5},{0.5,6.5}}],Circle[{0.5,5.5},0.3,{-2 Pi/6,-8Pi/6}],Arrow[{{2.5,8.5},{3.5,8.5}}],Circle[{2.5,8.5},0.3,{ Pi/6,7Pi/6}],Arrow[{{5.5,6.5},{5.5,5.5}}],Circle[{5.5,6.5},0.3,{ -2Pi/6,4Pi/6}],Arrow[{{6.5,5.5},{6.5,6.5}}],Circle[{6.5,5.5},0.3,{-2 Pi/6,-8Pi/6}]}}]

start = "S"->"FF-F-FF+F+FF";
rule="S"->"SF+S-FS-FS-FSF+SF+SF+S-FS";

Clear[next,position]
next[{{x_,y_},0}]:={{x+1,y},0}
next[{{x_,y_},Pi/2}]:={{x,y+1},Pi/2}
next[{{x_,y_},Pi}]:={{x-1,y},Pi}
next[{{x_,y_},-Pi}]:={{x-1,y},Pi}
next[{{x_,y_},-Pi/2}]:={{x,y-1},-Pi/2}
next[{{x_,y_},3Pi/2}]:={{x,y-1},-Pi/2}
position[{{pts___},{curpos_,curor_}},"F"]:=With[{c=next[{curpos,curor}]},{{pts,First[c]},c}]
position[{{pts___},{curpos_,curor_}},"+"]:={{pts},{curpos,curor+Pi/2}}
position[{{pts___},{curpos_,curor_}},"-"]:={{pts},{curpos,curor-Pi/2}}

Clear[draw]
draw[s_String]:=Graphics[Line[Fold[position,{{{0.5,0.5}},{{0.5,0.5},Pi/2}},Characters[s]][[1]]]]

StringReplace[StringReplace["S",rule],start]

draw[StringReplace["S",start]]

draw[StringReplace[Nest[StringReplace[#,rule]&,"S",4],start]]