5
$\begingroup$

I am trying to visualize a geometry concept by using Wolfram Mathematica. enter image description here

Here is a sample image.

I have found the source code for tetrahedron online, but I can't find a source code for inscribed cubes in a tetrahedron.

Could anybody help me finding it?

$\endgroup$
10
$\begingroup$

This might get you started:

T = PolyhedronData["Tetrahedron", "MeshRegion"];
Q = PolyhedronData["Cube", "BoundaryMeshRegion"];
edgepairs = DeleteDuplicates[
   Sort[{#, Complement[Range[4], #]}] & /@ Subsets[Range[4], {2}]
   ];
U = Map[
   Transpose[
     Normalize /@ {#[[1, 1]] - #[[1, 2]], #[[2, 1]] - #[[2, 
         2]], (#[[1, 1]] + #[[1, 2]]) - (#[[2, 1]] + #[[2, 2]])}] &,
   ArrayReshape[MeshCoordinates[T][[Flatten[edgepairs]]], {3, 2, 2, 3}]
   ];
ξ = Mean[MeshCoordinates[T][[2 ;; 4]]] - MeshCoordinates[T][[1]];
pts = Transpose[U.Transpose[MeshCoordinates[Q]], {1, 3, 2}];
pts *= (ξ.MeshCoordinates[T][[4]]/Max[pts.ξ]);
cubelist = MapIndexed[
   MeshRegion[
     #,
     Hexahedron[{{1, 3, 4, 2, 5, 7, 8, 6}}],
     PlotTheme -> "SphereAndTube"
     ] &,
   pts
   ];

And here a plot:

cols = ColorData[97] /@ {1, 3, 4};
θ = 0.0075;
Show[
 Graphics3D[{
   Specularity[White, 30],
   Blend[{White, cols[[1]]}, .5],
   Opacity[.2],
   MeshPrimitives[T, 3],

   Opacity[1],
   Gray,
   MeshPrimitives[T, 1] /. Line[x_] :> Tube[x, θ],
   MeshPrimitives[T, 0] /. Point[x_] :> Sphere[x, 2 θ],
   Riffle[
    cols, 
    MeshPrimitives[#, 1] & /@ cubelist /. Line[x_] :> Tube[x, θ]],
   Riffle[
    cols, 
    MeshPrimitives[#, 0] & /@ cubelist /. Point[x_] :> Sphere[x, 2 θ]]
   }],
 Lighting -> "Neutral",
 Boxed -> False,
 PlotRange -> All,
 SphericalRegion -> True
 ]

enter image description here

$\endgroup$
  • $\begingroup$ Thank you! This really helps! Do you know the code that allows me to move around the vertex of the tetrahedron while still maintaining the inscribed cubes? $\endgroup$ – Larry Sep 16 '18 at 17:47
  • 1
    $\begingroup$ You're welcome. Simply Translate and Rotate etc. the MeshRegions in cubelist and in T after the first code block. $\endgroup$ – Henrik Schumacher Sep 16 '18 at 17:54
  • $\begingroup$ Can I make the tetrahedron non-regular? $\endgroup$ – Larry Sep 16 '18 at 18:36
  • $\begingroup$ I doubt it. What would happen to the cubes? $\endgroup$ – Henrik Schumacher Sep 16 '18 at 21:59
  • $\begingroup$ That is the problem. I think this particular code does not allow me to manipulate the cubes when the tetrahedron is irregular. I want to have the visualization for all kinds of tetrahedron, not just the regular ones. $\endgroup$ – Larry Sep 17 '18 at 0:37

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.