This is the code for the celebrated Sperner's Lemma in two dimensions --- which is equivalent to Brouwer Fixed Point theorem. Incidentally, it's my first program without any help --- until I ask this question.
In a triangle with colored vertices, each point on a edge has a random color drawn form the two color of the corresponding vertices and each interior point resulting from the triangulation of the first triangle has a random color drawn from the three vertices colors. The there exist at least one subtriangle with three color vertices.
This works perfectly but I would be happy to add three new items:
- the three colors triangle must have a specific color.
- if one interpret an edge segment with two colors as a door, there exist always a path for this specific type of door from one edge to a three color sub-triangle, which ever be the starting edge --- a path could also lead to an exit. How to dynamically show the paths.
- It will be nice to take the move the edges and vertices external points to make a keeping property transformation.
My difficulty with the first and the second point is to freeze the colors --- in such a way to know which are the three colored triangles. One can colorize a path with a light color or draw a line from barycenter to barycenter.. I have no idea how to program the third item.
Thanks for help
Here is my code
t = AASTriangle[\[Pi]/3, \[Pi]/3, 1];
c1 = Disk[{0, 0}, .015];
c2 = Disk[{1, 0}, .015];
c3 = Disk[{1/2, Sqrt[3]/2}, .015];
a = List[{{Red, Disk[{0, 0}, .015]}, {Blue,
Disk[{1, 0}, .015]}, {Green, Disk[{1/2, Sqrt[3]/2}, .015]}}];
r2 := RandomInteger[{1, 2}]
d := Table[{If[Random[Integer] == 1, Red, Green],
Disk[{i Cos[\[Pi]/3], i Sin[\[Pi]/3]}, .015]}, {i, 0.10, 0.90, 0.1}]
dd := Table[{If[Random[Integer] == 1, Blue, Red],
Disk[{i, 0}, .015]}, {i, 0.10, 0.90, 0.1}]
ddd := Table[{If[Random[Integer] == 1, Blue, Green],
Disk[{1 + i Cos[(2 \[Pi])/3], i Sin[(2 \[Pi])/3]}, .015]}, {i,
0.10, 0.90, 0.1}]
l := Table[{Line[{{i Cos[\[Pi]/3], i Sin[\[Pi]/3]}, {i, 0}}]}, {i,
0.10, 0.90, 0.1}]
ll := Table[{Line[{{i Cos[\[Pi]/3],
i Sin[\[Pi]/3]}, {1 + i Cos[(2 \[Pi])/3],
i Sin[(2 \[Pi])/3]}}]}, {i, 0.10, 0.90, 0.1}]
lll := Table[{Line[{{1 - i, 0}, {1 + i Cos[(2 \[Pi])/3],
i Sin[(2 \[Pi])/3]}}]}, {i, 0.10, 0.90, 0.1}]
p := Table[{If[r2 == 1, Blue, If[r2 == 2, Red, Green]],
Disk[{i + j/20, j/10 Sqrt[3]/2}, .015]}, {j, 1, 8, 1}, {i, 0.1,
0.9 - 0.1 j, .1}];
Show[Graphics[{White, EdgeForm[Thick], t}], Graphics[l], Graphics[ll],
Graphics[lll], Graphics[a], Graphics[d], Graphics[dd],
Graphics[ddd], Graphics[p]]
Output:
PS I could not be very reactive since where I am I get access to internet sporadically.