# Draw impossible figure with MMA, how can it be done?

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.

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

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


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


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


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

• 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. :) Sep 18, 2022 at 13:33
• @cvgmt,hi,What version of MMA do you use, I have 12 and the result presented by you does not occur. Sep 18, 2022 at 17:40
• @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. Sep 18, 2022 at 22:25
• @cvgmt: I determined the center of rotation in your try with AnglePath - see my answer. Sep 29, 2022 at 22:46

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]


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

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]


• (+1) The colors theme is very good. Sep 29, 2022 at 22:57
• azerbajdzan, thanks , very good Sep 30, 2022 at 12:07

Easy way:

img = Import["https://i.sstatic.net/zC0NX.png"];
ImageGraphics[Binarize[Last@ColorSeparate[img], 0.67],
DominantColors[img][[;; 2]], Method -> "Exact"]

• thank you very much, it is possible in the same code to vectorize the image so that it does not pixelate on the edges Sep 18, 2022 at 6:37
• @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. Sep 18, 2022 at 13:31