15
$\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

4 Answers 4

Reset to default
40
$\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
    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
    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
    Sep 18, 2022 at 22:25
  • 1
    $\begingroup$ @padre Please see my updated. $\endgroup$
    – cvgmt
    Sep 18, 2022 at 23:51
  • $\begingroup$ @cvgmt: I determined the center of rotation in your try with AnglePath - see my answer. $\endgroup$
    – azerbajdzan
    Sep 29, 2022 at 22:46
17
$\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
  • 2
    $\begingroup$ (+1) The colors theme is very good. $\endgroup$
    – cvgmt
    Sep 29, 2022 at 22:57
  • $\begingroup$ azerbajdzan, thanks , very good $\endgroup$
    – padre
    Sep 30, 2022 at 12:07
9
$\begingroup$

Easy way:

img = Import["https://i.stack.imgur.com/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
    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
    Sep 18, 2022 at 13:31
2
$\begingroup$

The original image, courtesy of Google Image Search.

Wolfram Mathematica's own method.

The following code is from the Wolfram Mathematica web page with two minor changes. The required color distance was increased to remove the SHutterStock overlay and the image is replaced by the image under discussion.

img = Import["https://i.stack.imgur.com/zC0NX.png"]

colorDistance = 1/2; 

{colors, masks} = Transpose[DominantColors[
    MeanShiftFilter[img, 1, colorDistance, 
     MaxIterations -> 12], Automatic, 
    {"Color", "CoverageImage"}, ColorCoverage -> 0, 
    MinColorDistance -> colorDistance]]
    
cleanMasks = (Opening[#1, 1] & ) /@ masks

validColors = (ImageMeasurements[#1, "Total"] > 0 & ) /@ 
   cleanMasks
   
components = GrowCutComponents[img, Pick[cleanMasks, 
     validColors], MaxIterations -> 5]; 
     
completeMasks = Reverse[Image /@ Differences[
     Table[UnitStep[components - k], {k, Max[components] + 1, 
       1, -1}]]]
       
MaskToFilledCurve[(mask_Image)?BinaryImageQ] := 
  With[{bm = ImageMesh[mask, Method -> "LinearSeparable"]}, 
   GraphicsComplex[MeshCoordinates[bm], 
    With[{lines = MeshCells[bm, 1]}, FilledCurve[
      Split[lines, #1[[1,-1]] === #2[[1,1]] & ]]]]]
      
icon = Graphics[MapThread[
    {#1, MaskToFilledCurve[Binarize[#2]]} & , 
    {Pick[colors, validColors], completeMasks}]]

Mathematica graphics

$Version is "13.2.1 for Microsoft Windows (64-bit) (January 27, 2023)".

Of course, I may have missed something.

Improve this answer
$\endgroup$

Your Answer

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

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