19
$\begingroup$

How can I draw this figure using Mathematica? I have tried to trace the points on it but the white lines or contours that they have distort the resulting figure.

I have searched for some similar code but it did not work for this figure.enter image description here

This is reminiscent of Escher's work, but after sufficient staring, this picture can be broken into three identical rotated sections.

enter image description here

Improve this question
$\endgroup$
0

3 Answers 3

Reset to default
46
$\begingroup$

Edit

Since TernaryListPlot is new in 13.1 version,for old version,we use ternary[{p1_, p2_, p3_}] = {p1 + 1/2 p2, Sqrt[3]/2 p2}; to translate the ternary-coordinate to normal Cartesian coordinate and do the same thing.

Clear[n, m1, m2, m3, pts1, pts2, pts3, ternary];
(* for all versions  *)
n = 19;
m1[k_][{x_, y_, z_}] = {x, y + k, n - (x + y + k)};
m2[k_][{x_, y_, z_}] = {x + k, y, n - (x + k + y)};
m3[k_][{x_, y_, z_}] = {n - (y + k + z), y + k, z};
pts1 = ComposeList[{m1[6], m3[-3], m1[7], m3[-5], m2[1], m3[7], 
    m1[-7], m3[2], m1[9], m3[-4], m2[1], m3[6], m1[-17], m3[-1]}, 
   m2[1]@{0, 0, 1}];
pts2 = ComposeList[{m1[1], m3[1], m2[-1], m3[-2]}, pts1[[8]]];
pts3 = ComposeList[{m1[8], m3[1], m1[-9], m2[1]}, pts2[[3]]];
{pts1, pts2, pts3} = {pts1/n, pts2/n, pts3/n};
ternary[{p1_, p2_, p3_}] = {p1 + 1/2 p2, Sqrt[3]/2 p2};
Graphics[{EdgeForm[{AbsoluteThickness[2], White}], Red, 
  Polygon /@ Map[ternary, {pts1, pts2, pts3}, {2}], Yellow, 
  Polygon /@ Map[ternary@RotateLeft[#, 1] &, {pts1, pts2, pts3}, {2}],
   Green, Polygon /@ 
   Map[ternary@RotateLeft[#, 2] &, {pts1, pts2, pts3}, {2}]}]

enter image description here

Original

We use TernaryListPlot and define three transformations m1,m2,m3 to move the point parallel to the three edges respectively.

Clear[n, m1, m2, m3, pts1, pts2, pts3];
n = 19;
m1[k_][{x_, y_, z_}] = {x, y + k, n - (x + y + k)};
m2[k_][{x_, y_, z_}] = {x + k, y, n - (x + k + y)};
m3[k_][{x_, y_, z_}] = {n - (y + k + z), y + k, z};
pts1 = ComposeList[{m1[6], m3[-3], m1[7], m3[-5], m2[1], m3[7], 
    m1[-7], m3[2], m1[9], m3[-4], m2[1], m3[6], m1[-17], m3[-1]}, 
   m2[1]@{0, 0, 1}];
pts2 = ComposeList[{m1[1], m3[1], m2[-1], m3[-2]}, pts1[[8]]];
pts3 = ComposeList[{m1[8], m3[1], m1[-9], m2[1]}, pts2[[3]]];
(* TernaryListPlot[{pts1, pts2, pts3}, Joined -> True] *)
TernaryListPlot[{pts1, pts2, pts3}, Frame -> False, PlotStyle -> None,
  GridLines -> {Subdivide[0, 1, n]}, GridLinesStyle -> Gray, 
 Prolog -> {EdgeForm[{Thick, White}], Red, 
   Polygon /@ {pts1, pts2, pts3}, Yellow, 
   Polygon /@ Map[RotateLeft, {pts1, pts2, pts3}, {2}], Green, 
   Polygon /@ Map[RotateLeft[#, 2] &, {pts1, pts2, pts3}, {2}]}]

enter image description here

TernaryListPlot[{}, Frame -> False, 
  Epilog -> {EdgeForm[{Thick, White}], Darker@Green, Polygon[pts1], 
    Polygon@pts2, Polygon@pts3, Polygon[RotateLeft /@ pts1], 
    Polygon[RotateLeft /@ pts2], Polygon[RotateLeft /@ pts3], 
    Polygon[RotateLeft /@ pts1], Polygon[RotateLeft /@ pts2], 
    Polygon[RotateLeft /@ pts3], Polygon[RotateLeft[#, 2] & /@ pts1], 
    Polygon[RotateLeft[#, 2] & /@ pts2], 
    Polygon[RotateLeft[#, 2] & /@ pts3]}] /. 
 Line[pts_] :> {White, Line[pts]}

enter image description here

Appendix

I also test AnglePath,but it seems it is not easy to find the rotation center.

n = 19;
Graphics[
 Line[AnglePath[{{6/n, π/3}, {3/n, -2 π/3}, {7/n, 
     2 π/3}, {5/n, -2 π/3}, {1/n, π/3}, {7/n, 
     2 π/3}, {7/n, 
     2 π/3}, {2/n, -2 π/3}, {9/n, -π/3}, {4/
      n, -2 π/3}, {1/n, π/3}, {6/n, 2 π/3}, {17/n, 
     2 π/3}, {1/n, π/3}}]]]
Improve this answer
$\endgroup$
5
  • 1
    $\begingroup$ Ha! (+1) I just suggested such a method in replying to a comment, before I knew anyone else had responded. Doing it this way felt to me deserves a consultant's fee, so I opted for the easy way. :) $\endgroup$
    – Michael E2
    Commented Sep 18, 2022 at 13:33
  • $\begingroup$ @cvgmt,hi,What version of MMA do you use, I have 12 and the result presented by you does not occur. $\endgroup$
    – padre
    Commented Sep 18, 2022 at 17:40
  • 1
    $\begingroup$ @padre Ternary ListPlot is new in 13.1 version. We can also use the low version to do this, but need time to revised the code. $\endgroup$
    – cvgmt
    Commented Sep 18, 2022 at 22:25
  • 1
    $\begingroup$ @padre Please see my updated. $\endgroup$
    – cvgmt
    Commented Sep 18, 2022 at 23:51
  • $\begingroup$ @cvgmt: I determined the center of rotation in your try with AnglePath - see my answer. $\endgroup$
    – azerbajdzan
    Commented Sep 29, 2022 at 22:46
20
$\begingroup$

This is based on @cvgmt's unfinished try with AnglePath. And also using, I think, more appropriate coloring - based not on three different rotations of one object but on orientation of each plane.

n = 19;
c = {17/38, 1/(2 Sqrt[3])};
p1 = AnglePath[{{6/n, π/3}, {3/n, -2 π/3}, {7/n, 
     2 π/3}, {5/n, -2 π/3}, {1/n, π/3}, {7/n, 
     2 π/3}, {7/n, 
     2 π/3}, {2/n, -2 π/3}, {9/n, -π/3}, {4/
      n, -2 π/3}, {1/n, π/3}, {6/n, 2 π/3}, {17/n, 
     2 π/3}, {1/n, π/3}}];
p2 = Rest@
   AnglePath[{{7/n, π/3}, {2/n, -2 π/3}, {1/n, 
      2 π/3}, {1/n, π/3}, {1/n, π/3}}];
p3 = Rest@
   AnglePath[{{7/n, π/3}, {1/n, -π/3}, {8/n, π/3}, {1/
       n, π/3}, {9/n, 2 π/3}}];
r1 = RotationMatrix[2 π/3];
r2 = RotationMatrix[4 π/3];
color = ColorData[97, "ColorList"];
obj = Polygon;
Graphics[{EdgeForm[Black], {color[[1]], obj[# - c & /@ p1], 
   obj[r1 . # & /@ (# - c & /@ p2)], 
   obj[r2 . # & /@ (# - c & /@ p3)]}, {color[[2]], 
   obj[r1 . # & /@ (# - c & /@ p1)], obj[r2 . # & /@ (# - c & /@ p2)],
    obj[# - c & /@ p3]}, {color[[3]], 
   obj[r2 . # & /@ (# - c & /@ p1)], obj[# - c & /@ p2], 
   obj[r1 . # & /@ (# - c & /@ p3)]}}]
Clear[n, c, p1, p2, p3, r1, r2, color, obj]

enter image description here

And this is composed of simple lines using color = {Black, Black, Black}; obj = Line; in the above code:

enter image description here

Update:

trans[x_] := 
 Module[{n = Length /@ Cases[Split[x[[2]]], {0 ..}][[{1, 2, -1}]]},
  {x[[1]] - 9*{1/2, 1/(2 Sqrt[3])}, {-a, b, 
    Sequence @@ Table[0, n[[1]] + 9], -b, 
    Sequence @@ Table[0, n[[2]] + 9], a, b, 
    Sequence @@ Table[0, n[[1]] + 9], b, 
    Sequence @@ Table[0, n[[3]] + 9]}}]

a = π/3;
b = 2 a;
r = {IdentityMatrix[2], RotationMatrix[2 a], RotationMatrix[2 b]};
t = AnglePath[{{1, a}, {1, -b}}] // Mean;
{m1, m2, m3} = {6, 4, 7};
p1 = {{-9, -7}*t, {-a, b, Sequence @@ Table[0, m1], -b, 
    Sequence @@ Table[0, m2], a, b, Sequence @@ Table[0, m1], b, 
    Sequence @@ Table[0, m3]}};
p2 = trans[p1];
p3 = trans[p2];
p4 = trans[p3];
ap1 = AnglePath @@ p1;
ap2 = AnglePath @@ p2;
ap3 = AnglePath @@ p3;
ap4 = AnglePath @@ p4;
q1 = Most[Insert[Drop[ap2, {23, -25}], Splice[Most[ap1]], 9]];
q2 = Most[Insert[Drop[ap3, {23 + 9, -25 - 9}], Splice[q1], 9]];
q3 = Most[Insert[Drop[ap4, {23 + 2*9, -25 - 2*9}], Splice[q2], 9]];
c = ColorData[97, "ColorList"];
Graphics[{EdgeForm[Black], 
  Table[{c[[k]], Polygon[r[[k]] . # & /@ Most[ap1]]}, {k, 3}]}]
Graphics[{EdgeForm[Black], 
  Table[{c[[k]], Polygon[r[[k]] . # & /@ q1], 
    Polygon[r[[k]] . # & /@ ap2[[24 ;; -25]]], 
    Polygon[r[[k]] . # & /@ (r[[2]] . # & /@ 
        Most[AnglePath[ap2[[9]], {-a, 0, b, a, a}]])]}, {k, 3}]}]
Graphics[{EdgeForm[Black], 
  Table[{c[[k]], Polygon[r[[k]] . # & /@ q2], 
    Polygon[r[[k]] . # & /@ ap3[[24 + 9 ;; -25 - 9]]], 
    Polygon[r[[k]] . # & /@ (r[[2]] . # & /@ 
        Most[AnglePath[ap3[[9]], {-a, 0, b, a, a}]])], 
    Polygon[r[[k]] . # & /@ ap2[[24 ;; -25]]], 
    Polygon[r[[k]] . # & /@ (r[[2]] . # & /@ 
        Most[AnglePath[ap2[[9]], {-a, 0, b, a, a}]])]}, {k, 3}]}]
Graphics[{EdgeForm[Black], 
  Table[{c[[k]], Polygon[r[[k]] . # & /@ q3], 
    Polygon[r[[k]] . # & /@ ap4[[24 + 2*9 ;; -25 - 2*9]]], 
    Polygon[r[[k]] . # & /@ (r[[2]] . # & /@ 
        Most[AnglePath[ap4[[9]], {-a, 0, b, a, a}]])], 
    Polygon[r[[k]] . # & /@ ap2[[24 ;; -25]]], 
    Polygon[r[[k]] . # & /@ (r[[2]] . # & /@ 
        Most[AnglePath[ap2[[9]], {-a, 0, b, a, a}]])], 
    Polygon[r[[k]] . # & /@ ap3[[24 + 9 ;; -25 - 9]]], 
    Polygon[r[[k]] . # & /@ (r[[2]] . # & /@ 
        Most[AnglePath[ap3[[9]], {-a, 0, b, a, a}]])]}, {k, 3}]}]
Clear[n, a, b, r, m1, m2, m3, t, p1, p2, p3, p4, q1, q2, q3, c, ap1, ap2, ap3, ap4]

enter image description here enter image description here enter image description here enter image description here

Improve this answer
$\endgroup$
2
  • 3
    $\begingroup$ (+1) The colors theme is very good. $\endgroup$
    – cvgmt
    Commented Sep 29, 2022 at 22:57
  • $\begingroup$ azerbajdzan, thanks , very good $\endgroup$
    – padre
    Commented Sep 30, 2022 at 12:07
11
$\begingroup$

Easy way:

img = Import["https://i.sstatic.net/zC0NX.png"];
ImageGraphics[Binarize[Last@ColorSeparate[img], 0.67], 
 DominantColors[img][[;; 2]], Method -> "Exact"]
Improve this answer
$\endgroup$
2
  • $\begingroup$ thank you very much, it is possible in the same code to vectorize the image so that it does not pixelate on the edges $\endgroup$
    – padre
    Commented Sep 18, 2022 at 6:37
  • 2
    $\begingroup$ @padre The result is in fact vector graphics. The rough edges come from the ImageGraphics algorithm and the noisy edges. If you use the option Method -> "LinearSeparable", ImageGraphics will do some smoothing, but the result is not too good because of the noise along the edge in your image. That's why I stressed "easy" and not "good." There is probably a way to straighten the edges in the image, but it might not be easy (and I don't know how). Probably the most straightforward way is to lay out an equilateral triangular grid and determine the vertices by hand. $\endgroup$
    – Michael E2
    Commented Sep 18, 2022 at 13:31

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