6
$\begingroup$

I've been looking at the site, but it doesn't occur to me there was a method to obtain the coordinates of the image, but I can't find it. Could you give me a hand?

It's for a poster of the Mathematical Olympics that my son's teacher asked me for once he saw me doing things with Mathematica. It is understood that it is the 3D image, people do not.

Enter image description here

Improve this question
$\endgroup$

3 Answers 3

Reset to default
13
$\begingroup$

This is the process of reconstructing the polyhedron Icosahedron.

Clear["Global`*"];
img = Import["https://i.sstatic.net/FAbVi.png"];
colors = DominantColors[img]
c = 1/2 (1 + Sqrt[5]);
p1 = {1, -c, 0};
p2 = {0, -1, c};
p3 = {-1, -c, 0};
xy = {{1, c, 0}, {-1, c, 0}, {-1, -c, 0}, {1, -c, 0}};
yz = {{0, 1, c}, {0, -1, c}, {0, -1, -c}, {0, 1, -c}};
zx = {{c, 0, 1}, {c, 0, -1}, {-c, 0, -1}, {-c, 0, 1}};
g=Graphics3D[{AbsolutePointSize[8], Point /@ {xy, yz, zx}, colors[[5]], 
  Polygon[xy], colors[[4]], Polygon[yz], colors[[3]], Polygon[zx], 
  Red, AbsolutePointSize[12], Point[{p1, p2, p3}]}, 
 Lighting -> {{"Ambient", White}}]

enter image description here

Where the c come from the equation.

Clear[p1, p2, p3, c];
p1 = {1, -c, 0};
p2 = {0, -1, c};
p3 = {-1, -c, 0};
Solve[{EuclideanDistance[p1, p2] == EuclideanDistance[p1, p3], c > 0},
  c]

enter image description here

  • Animation
img = Import["https://i.sstatic.net/FAbVi.png"];
colors = DominantColors[img];
c = 1/2 (1 + Sqrt[5]);
xy = {{1, c, 0}, {-1, c, 0}, {-1, -c, 0}, {1, -c, 0}};
yz = {{0, 1, c}, {0, -1, c}, {0, -1, -c}, {0, 1, -c}};
zx = {{c, 0, 1}, {c, 0, -1}, {-c, 0, -1}, {-c, 0, 1}};
options = {Boxed -> False, SphericalRegion -> True, 
   Lighting -> {{"Ambient", White}}};
g = Graphics3D[{AbsolutePointSize[8], Point /@ {xy, yz, zx}, 
    colors[[5]], Polygon[xy], colors[[4]], Polygon[yz], colors[[3]], 
    Polygon[zx], EdgeForm[Thick], FaceForm[], 
    ConvexHullMesh@Catenate[{xy, yz, zx}]}, options];
rotZ = Table[
   Graphics3D[
    GeometricTransformation[First@g, RotationTransform[t, {0, 0, 1}]],
     options], {t, 0, 2 π, .2}];
rotY = Table[
   Graphics3D[
    GeometricTransformation[First@g, RotationTransform[t, {0, 1, 0}]],
     options], {t, 0, 2 π, .2}];
rotX = Table[
   Graphics3D[
    GeometricTransformation[First@g, RotationTransform[t, {1, 0, 0}]],
     options], {t, 0, 2 π, .2}];
ListAnimate[Catenate[{rotZ, rotY, rotX}], AnimationRate -> 5]
Export["rotation.gif", Catenate[{rotZ, rotY, rotX}]]

enter image description here

  • Another way to construct yz and zx by cyclic the coordinate.
Clear[c, xy, yz, zx];
c = 1/2 (1 + Sqrt[5]);
xy = {{1, c, 0}, {-1, c, 0}, {-1, -c, 0}, {1, -c, 0}};
yz = RotateRight /@ xy;
zx = RotateRight /@ yz;
Graphics3D[Polygon /@ {xy, yz, zx}]

enter image description here

Improve this answer
$\endgroup$
4
  • 1
    $\begingroup$ wow ,Thank you, very grateful for the detail to create the image, could you join the corresponding points and animate the corresponding body around the three axes in 360° cycles and export the results to an animated gif $\endgroup$
    – Pamela
    Commented Aug 6, 2023 at 5:18
  • $\begingroup$ @cvgnt, Thank you very much for your effort, ah, it turned out great, so much so that I want to ask you one more favor, in the plans you can include text that says "Second Mathematical Olympiad", there you seal it with a platinum clasp $\endgroup$
    – Pamela
    Commented Aug 6, 2023 at 16:38
  • $\begingroup$ I hope you are encouraged by the last thing I wrote to you, I would appreciate it $\endgroup$
    – Pamela
    Commented Aug 7, 2023 at 16:10
  • $\begingroup$ @Pamela I have try, but the Second Mathematical Olympiad is too long to put onto the rectangles. Or if I scaling the fonts, the fonts too small to see. $\endgroup$
    – cvgmt
    Commented Aug 8, 2023 at 3:13
10
$\begingroup$

enter image description here

cp = Map[Prepend[0]] @ Delete[{{3}, {6}}] @ CirclePoints[{1, Pi/3}, 6] ;

coords = Table[Map[RotateRight[#, i] &] @ cp, {i, 3}];

colors = {RGBColor[1, .5, .5], RGBColor[1, 1, .5], RGBColor[.5, 1, .5]};

show = Show[Graphics3D @
   Thread[{colors, Lighting -> {{"Ambient", White}}, Polygon /@ coords}],
 MeshConnectivityGraph @ ConvexHullRegion[Join @@ coords], 
 SphericalRegion -> True, Boxed -> False]

enter image description here

rotate[angle_, axis_] := MapAt[Rotate[#, angle, UnitVector[3, axis]] &, {1}]

Manipulate[rotate[θ, axis] @ show,
 {{axis, 1, "axis" }, Thread[Range @ 3 -> {"X", "Y", "Z"}]}, 
 {{θ, 0, "angle"}, 0, 2 π, Appearance -> "Open"}]

enter image description here

Animation above created using:

frames = Join @@ Table[rotate[2 Pi t, a] @ show, {a, 1, 3, 1}, {t, 0, 1, 1/25}]

Export["rotations.gif", frames]
Improve this answer
$\endgroup$
2
  • $\begingroup$ :) :) Thanks, impressive for the shortness of the code, you could animate it in 360° cycles, for the three axes and export the animation to a gif $\endgroup$
    – Pamela
    Commented Aug 6, 2023 at 5:13
  • $\begingroup$ hi , It also turned out great, although I had problems with rotate some bug, "Rotate is not a primitive or directive of Graphics3D. ", my MMA version is 13.0.1. Could you, if possible, include text on the cloths that says "Second Mathematical Olympiad", I would be very grateful. $\endgroup$
    – Pamela
    Commented Aug 6, 2023 at 17:07
6
$\begingroup$

Building on cvgmt's answer

$Version

(* "13.3.0 for Mac OS X ARM (64-bit) (June 3, 2023)" *)

Clear["Global`*"];

img = Import["https://i.sstatic.net/FAbVi.png"];

colors = DominantColors[img];

c = 1/2 (1 + Sqrt[5]);
z = {{c, 1, 0}, {-c, 1, 0}, {-c, -1, 0}, {c, -1, 0}};
x = {{0, c, 1}, {0, -c, 1}, {0, -c, -1}, {0, c, -1}};
y = {{1, 0, c}, {1, 0, -c}, {-1, 0, -c}, {-1, 0, c}};

Manipulate[
 f = GeometricTransformation[#,
    RollPitchYawMatrix[{α, β, γ}]] &;
 Graphics3D[{
   Opacity[0.1], EdgeForm[AbsoluteThickness[1.5]],
   f@Icosahedron[{0, -3 Pi/16}, 2],
   Opacity[1], EdgeForm[],
   colors[[3]], f@Polygon[x],
   colors[[4]], f@Polygon[y],
   colors[[5]], f@Polygon[z]}, Lighting -> {{"Ambient", White}},
  Boxed -> False],
 {{α, 7 Pi/16}, -Pi/2, Pi/2, Pi/64, Appearance -> "Labeled"},
 {{β, 0}, -Pi/2, Pi/2, Pi/64, Appearance -> "Labeled"},
 {{γ, 0}, -Pi/2, Pi/2, Pi/64, Appearance -> "Labeled"},
 SynchronousUpdating -> False,
 TrackedSymbols :> {α, β, γ}]

enter image description here

EDIT: To export an animated GIF

animation = Animate[
  f = GeometricTransformation[#,
     RollPitchYawMatrix[{α, β, γ}]] &;
  Graphics3D[{
    Opacity[0.1], EdgeForm[AbsoluteThickness[1.5]],
    f@Icosahedron[{0, -3 Pi/16}, 2],
    Opacity[1], EdgeForm[],
    f@Polygon[x, VertexColors ->
       {Pink, White, Pink, White}],
    colors[[4]], f@Polygon[y, VertexColors ->
       {Yellow, White, Yellow, White}],
    f@Polygon[z, VertexColors ->
       {Green, White, Green, White}]},
   Lighting -> {{"Ambient", White}},
   Boxed -> False],
  {{α, -Pi}, -Pi, Pi, Pi/16},
  {{β, -Pi}, -Pi, Pi, Pi/16},
  {{γ, -Pi}, -Pi, Pi, Pi/16},
  AnimationRepetitions -> 1]

enter image description here

Export["/Users/roberthanlon/Downloads/animation.gif", animation];
Improve this answer
$\endgroup$
3
  • $\begingroup$ wow ; Thanks, since you put three angles, it would be possible to produce 360° movements for each angle and the movements to store them in an animated gif, thanks in advance $\endgroup$
    – Pamela
    Commented Aug 6, 2023 at 5:10
  • $\begingroup$ I was visualizing your animation and it sticks a few jumps, apparently the border of the planes is annoying there, the color blur that you put on it is important, you can fix the animation so that it only comes out with the animated body, thanks for your effort, I learn a lot from you. $\endgroup$
    – Pamela
    Commented Aug 6, 2023 at 17:20
  • 1
    $\begingroup$ If you don't want the controls use Table instead of Animate $\endgroup$
    – Bob Hanlon
    Commented Aug 6, 2023 at 18:16

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.