4

Some friends from the forum helped me to make this MMA script, I have tried to modify it to put text similar to the image, perhaps with a more beautiful letter, but I can't think of how, I have seen in the forum and in the help of MMA.

I looked in the forum and in the MMA help and the closest thing I found is this

 myarrow[begin_List, end_List, mytext_String] := Graphics3D[
 {Arrow[{begin, end}],Text[Style[mytext, 14], end]}]

Graphics3D[Cylinder[], Epilog -> Inset[Framed[Style["Cylinder", 20], Background -> LightYellow], {Right, Bottom}, {Right, Bottom}]]

I need this, you have to run the code to see where it is, the text is supposed to rotate along with the figure, it is attached to the planes, the image only represents a frontal view of the movement

enter image description here

Clear["Global`*"];
img = Import["https://i.stack.imgur.com/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 \[Pi], .2}];
 rotY = Table[
Graphics3D[
GeometricTransformation[First@g, RotationTransform[t, {0, 1, 0}]],
 options], {t, 0, 2 \[Pi], .2}];
rotX = Table[
Graphics3D[
GeometricTransformation[First@g, RotationTransform[t, {1, 0, 0}]],
 options], {t, 0, 2 \[Pi], .2}];
ListAnimate[Catenate[{rotZ, rotY, rotX}], AnimationRate -> 6]

I would appreciate a hand, I would be grateful

Pamela
  • 309
  • 1
  • 6
  • 2
    Someone made a function text3D https://mathematica.stackexchange.com/a/131842/74641. You can also use VertexTextureCoordinates as in https://mathematica.stackexchange.com/questions/219866/is-possible-to-embed-a-text-on-a-face-grid-in-graphics3d/219878. – Adam Aug 15 '23 at 03:44
  • @Adam ,thanks, I already saw those links, but I can't think of how to implement them – Pamela Aug 15 '23 at 04:11
  • Graphics3D@{Texture@"abc",Polygon[{{0,0,0},{1,0,0},{1,1,0},{0,1,0}},VertexTextureCoordinates->{{0,0},{1,0},{1,1},{0,1}}]} If you Rasterize the Texture to have a transparent background, you could overlay such a polygon. – Adam Aug 15 '23 at 05:35

1 Answers1

6

enter image description here

Using the approach from this answer to construct the polygons and lines:

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

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

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

Transform text primitives to 3D coordinates by processing the output from BoundaryDiscretizeGraphics:

ClearAll[textCoords]
textCoords[string_, cbounds_ : {{-1/2, 1/2}, {1/2, 5/6}}, padding_ : .2] := 
  Module[{tc = (MeshPrimitives[
         BoundaryDiscretizeGraphics[Text[string], _Text], 1, 
         Multicells -> True] /. Line[x_] :> Line[Join @@ x])[[All, 1]]}, 
    Map[Map[Prepend[0] @* 
     RescalingTransform[(1 + padding) CoordinateBounds @ tc, cbounds]]] @ tc];

labels = {"2nd Mathematical Olympiad", "B C M H K", "2023"};

textcoordinates = MapIndexed[{x, y} |-> Map[Map[RotateRight[#, -1 + First @ y] &]][ textCoords[Style[x, FontFamily -> "Times"]]]] @ labels;

show = Show[Graphics3D @ Thread[{AbsoluteThickness[1/2], Black, Map[Line] @ textcoordinates, colors, Lighting -> {{"Ambient", White}}, Polygon /@ coords}], MeshConnectivityGraph @ ConvexHullRegion[Join @@ coords], SphericalRegion -> True, Boxed -> False, PlotRange -> 1, ImageSize -> Large, ImagePadding -> 5]

enter image description here

Animation above produced using

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

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

Export["MathOlympiad.gif", frames]

Notes:

$Version
"13.3.0 for Linux x86 (64-bit) (June 3, 2023)"

Ignore the red syntax highlighting of Multicells -> True.

kglr
  • 394,356
  • 18
  • 477
  • 896
  • thanks ,Multicells -> True] ,that instruction is in red, My version of MMA is 13.0.0, it will have something to do with it, the figure is displayed, but the animation is static , https://drive.google.com/file/d/1C_EUfEWsO3YkoWkBsz2JSooL1_x-pWhX/view?usp=sharing – Pamela Aug 15 '23 at 14:54
  • 1
    @Pamela, re "..animation is static", I forgot to copy/paste the definition of rotate (added now). Re syntax highlighting in red of Multicells -> True (suggesting an error) simply ignore it. – kglr Aug 15 '23 at 14:58
  • wow ,thanks, Your animation with the letters is great but it kind of jumps, I tried to see what part of the code produces that but I don't see it, I'm sending you yours so you can see how it looks and another one I have to see if you can give it that smoothness, thank you very much beforehand. https://drive.google.com/drive/folders/1HObv1p37lAzPPmUZNjVxNUcghgiMHdMw?usp=sharing – Pamela Aug 15 '23 at 15:19
  • although the one you put in the forum in large format does not look like that – Pamela Aug 15 '23 at 15:26
  • 1
    @Pamela, please try the updated version. Because of 2MB limit on image uploads on this site, I had to reduce the number of frames; you can replace 1/18 on the last line to a smaller number to get smoother rotations. – kglr Aug 15 '23 at 16:19
  • Thanks , it worked great – Pamela Aug 15 '23 at 20:05