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:

  1. the three colors triangle must have a specific color.
  2. 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.
  3. 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]]


enter image description here

PS I could not be very reactive since where I am I get access to internet sporadically.


Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.