3
$\begingroup$

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

Output:

enter image description here

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

$\endgroup$

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.