4
$\begingroup$

I am using the code below (from this link) and the result is the pentagonal tiling on the left-hand side.

Questions:

  1. How can I get rid of Manipulate in the code and obtain only the fixed given plot?

  2. Is it possible to use two colors for the tiling edges? something like the picture on the right-hand side?

  3. How can I add black points at all conjunctions (like the right picture)?

enter image description here

n := 10;
Manipulate[
 If[swpaintold != swpaint,
  If[swpaint, swtetrad = False];
  swpaintold = swpaint
  ];
 
 If[swtetrad,
  swpaint = False;
  pol1 = {{0, 0}, {1, -e}, {2, 0}, {3, e} , {3, 2 - e} , {2, 
     2}, {2 + e, 3}, {4 - e, 3},
    {4, 4}, {3, 4 + e}, {3, 6 - e}, {4, 6}, {4 - e, 7}, {2 + e, 
     7}, {2, 8}, {1, 8 - e},
    {0, 8}, {-e, 7}, {0, 6}, {1, 6 + e}, {2, 6}, {2 - e, 5}, {2, 
     4}, {1, 4 - e},
    {1, 2 + e}, {0, 2}, {e, 1}, {0, 0}};
  
  pol2 = {{0, 0}, {1, e}, {2, 0}, {2 + e, 1} , {2, 2} , {1, 
     2 - e}, {0, 2}, {e, 3},
    {0, 4}, {1, 4 + e}, {1, 6 - e}, {2, 6}, {2 - e, 7}, {2, 8}, {1, 
     8 + e}, {0, 8},
    {-1, 8 - e}, {-1, 6 + e}, {0, 6}, {-e, 5}, {-2 + e, 5}, {-2, 
     4}, {-1, 4 - e}, {-1, 2 + e},
    {-2, 2}, {-2 + e, 1}, {-e, 1}, {0, 0}};
  
  pol3 = {{0, 0}, {1, -e}, {2, 0}, {2 - e, 1} , {2, 2} , {3, 
     2 - e}, {4, 2}, {4 + e, 1},
    {6 - e, 1}, {6, 0}, {7, e}, {8, 0}, {8 + e, 1}, {8, 2}, {8 - e, 
     3}, {6 + e, 3},
    {6, 2}, {5, 2 + e}, {5, 4 - e}, {4, 4}, {4 - e, 3}, {2 + e, 
     3}, {2, 4}, {1, 4 - e},
    {1, 2 + e}, {0, 2}, {e, 1}, {0, 0}};
  ];
 
 Graphics[{
   col1,
   Thickness[thick1],
   Opacity[op1],
   Table[{
     Translate[
      Line[{{0, 0}, {1, -e}, {2, 0}, {2 - e, 1} , {e, 1} , {0, 
         0}}], {i*4, j*4}],
     Translate[
      Line[{{e, 1} , {0, 2}, {1, 2 + e}, {2, 2}, {2 - e, 1}, {e, 
         1}}], {i*4, j*4}],
     Translate[
      Line[{{0, 2}, {-e, 3}, {0, 4}, {1, 4 - e} , {1, 2 + e}, {0, 
         2} }], {i*4, j*4}],
     Translate[
      Line[{ {1, 4 - e}  , {2, 4}, {2 + e, 3}, {2, 2}, {1, 2 + e}, {1,
          4 - e}}], {i*4, j*4}],
     
     Translate[
      Line[{{2, 0}, {3, e}, {3, 2 - e}, {2, 2} , {2 - e, 1} , {2, 
         0}} ], {i*4, j*4}],
     Translate[
      Line[{{3, e} , {3, 2 - e}, {4, 2}, {4 + e, 1}, {4, 0}, {3, 
         e}}], {i*4, j*4}],
     Translate[
      Line[{{3, 2 - e}, {2, 2}, {2 + e, 3}, {4 - e, 3} , {4, 2}, {3, 
         2 - e}}], {i*4, j*4}],
     Translate[
      Line[{ {2 + e, 3}  , {4 - e, 3}, {4, 4}, {3, 4 + e}, {2, 
         4}, {2 + e, 3} }], {i*4, j*4}]
     }, {i, 0, n}, {j, 0, n}
    ]
   
   },
  PlotRange -> {{0, 13}, {0, 13}}, ImageSize -> {500, 500}    
  ], (* end Graphics *)
 
 {{e, .5, "morph"}, 0, 1, ImageSize -> Small}
 ,
 
 (*  here we list the variants :  *)(* \n = linefeed *)
 (*{{ch,1,"tetrad"},Range[chmax], ControlType\[Rule]PopupMenu},*)
 
 Delimiter,
 Style["Cairo tiling:"],
 {{col1, Red, "outline"}, Red, ColorSlider, ImageSize -> Small, 
  AppearanceElements -> "Swatch"},
 {{op1, 1, "opacity"}, 0, 1, ImageSize -> Small},
 {{thick1, .0005, "thickness"}, 0.0001, .02, ImageSize -> Small},
 {{swpaint, False, "color tiles"}, {True, False}},
 {{swtetrad, True, "polycairo tetrad"}, {True, False}}
 ]

$\endgroup$

1 Answer 1

6
$\begingroup$

You can do this relatively easily using my IGraph/M package. You will need to install the package first. If you end up using it extensively for your work, a citation would be very much appreciation.

Load the package:

<<IGraphM`

Create a mesh using this pentagonal tiling:

mesh = IGLatticeMesh["CairoPentagonal", {5, 5}]

enter image description here

Convert the mesh to a graph and add the base styling:

graph = IGMeshGraph[mesh, GraphStyle -> "BasicBlack", 
  EdgeStyle -> Directive[Thick, Darker@Green]]

Now comes the most involved part. We want to colour horizontal or vertical edges in red.

horizontalOrVerticalQ[{p1_, p2_}] := Mod[ArcTan @@ (p1 - p2), Pi/2] < 10^-5
IGEdgeMap[If[horizontalOrVerticalQ[#], Red, {}] &, 
 EdgeStyle -> IGEdgeVertexProp[VertexCoordinates], graph]

enter image description here

A short explanation of how this works:

IGEdgeMap[f, prop -> extractor, graph] will map the function f over the values extractor[graph] and store the result in the edge property prop. In this case, the extractor IGEdgeVertexProp takes a vertex property, and for each edge it produces a pair of values corresponding to the edge endpoints. We use the VertexCoordinates property, i.e. the coordinate of each vertex. Thus the result will be of the form {p1, p2} for each edge, where p1 and p2 are the coordinates of endpoints. You can look at the complete result like so: IGEdgeVertexProp[VertexCoordinates][graph]. Finally we determine if the point pair lines on a horizontal or vertical line and colour accordingly.

$\endgroup$
4
  • $\begingroup$ Wow. Thank you very much. It is marvelous. $\endgroup$
    – MsMath
    Mar 7, 2023 at 22:31
  • $\begingroup$ Unfortunately, there is a problem in loading the package, Mathematica says Get::noopen: Cannot open IGraphM.` $\endgroup$
    – MsMath
    Mar 7, 2023 at 23:30
  • 1
    $\begingroup$ @MsMath You need to install the package. Check the link to the package and follow the instructions. $\endgroup$
    – Szabolcs
    Mar 8, 2023 at 9:05
  • 1
    $\begingroup$ I realized the link was broken. I fixed it now. $\endgroup$
    – Szabolcs
    Mar 8, 2023 at 9:08

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.