2
$\begingroup$

What's an easiest way to specify lower "half-cube" Graphics3D in Mathematica?

Using RegionPlot3D is easy but gives low quality graphics for cube (great quality for spheres however). An approach by specifying faces manually for a Polyhedron is below, but error prone....it ends up specifying the upper half-cube

Clear["Global`*"];

dvis = 2; (* vis dimension *)
d = 3; (* true dimension *)

norm2[vec_] = Total[vec*vec];

(* vec1,vec2 determine the plane of our section *)
vec1 = {1}~Join~ConstantArray[0, d - 1];
vec2 = Normalize[{0}~Join~ConstantArray[1, d - 1]];
mat = {vec1, vec2};

as = ConstantArray[a, d - 1];
zeros = 0*as;
zeros = ConstantArray[0, d];
a = 1;

(* Radius of inscribed sphere *)
R = a (Sqrt[d] - 1);

a = 1;

vec1 = {1}~Join~ConstantArray[0, d - 1];
vec2 = Normalize[{0}~Join~ConstantArray[1, d - 1]];
mat = {vec1, vec2};

normal = Cross @@ mat;
cornerSpheres = sphere[#, a] & /@ {c1, c2, c3, c4};
centerSphere = sphere[zeros, R];

halfCube = 
  Graphics3D@
   Polyhedron[{{-2, -2, -2}, {2, -2, -2}, {2, -2, 2}, {-2, -2, 2}, {2,
       2, 2}, {-2, 2, 2}}, {{1, 2, 3, 4}, {3, 4, 6, 5}, {1, 2, 5, 
      6}, {2, 3, 5}, {1, 4, 6}}];

c1 = {-a}~Join~as;
c2 = {a}~Join~as;
c3 = {-a}~Join~(-as);
c4 = {a}~Join~(-as);

c5 = {a, a, -a};
c6 = {-a, a, -a};

sphere[center_, radius_] := norm2[{x, y} . mat - center] <= radius^2;
cornerSpheres = Sphere[#, a] & /@ {c1, c2, c3, c4};
sideSpheres = Sphere[#, a] & /@ {c5};
centerSphere = Sphere[zeros, R];

regionPlot = 
  Graphics3D[
   cornerSpheres~Join~{Opacity[1]}~Join~sideSpheres~
    Join~{Opacity[1], \!\(\*
TagBox[
StyleBox[
RowBox[{"RGBColor", "[", 
RowBox[{"0.57`", ",", "0.54`", ",", "1"}], "]"}],
ShowSpecialCharacters->False,
ShowStringCharacters->True,
NumberMarks->True],
FullForm]\), centerSphere}];
Show[regionPlot, halfCube, PlotRange -> {{-2, 2}, {-2, 2}, {-2, 2}}]

enter image description here

$\endgroup$
5
  • $\begingroup$ You could just flip the signs of all the $z$-coordinates of the vertices in your description of the half cube, right? No need to touch the list of faces of the polyhedron at all! $\endgroup$ Commented Nov 2, 2023 at 17:32
  • 5
    $\begingroup$ Maybe Prism[{{-1, -1, -1}, {-1, 1, -1}, {-1, 1, 1}, {1, -1, -1}, {1, 1, -1}, {1, 1, 1}}] $\endgroup$
    – lericr
    Commented Nov 2, 2023 at 17:34
  • $\begingroup$ That is true. I had an easier time specifying half cube in terms of equations, but couldn't get region plot or discretize region to give me the high quality results $\endgroup$ Commented Nov 2, 2023 at 17:35
  • $\begingroup$ also BoundaryDiscretizeRegion @ RegionIntersection[HalfSpace[{0, -1, 1}, 0], Cuboid[{0, 0, 0}]]? $\endgroup$
    – kglr
    Commented Nov 2, 2023 at 20:58
  • $\begingroup$ ... and Graphics3D@ RegionProduct[Line[{{0}, {1}}], Triangle[{{0, 0}, {1, 0}, {1, 1}}]] $\endgroup$
    – kglr
    Commented Nov 2, 2023 at 21:03

1 Answer 1

3
$\begingroup$

Summarizing for posterity. The RegionProduct approach appears to be the most intuitive way.

Clear["Global`*"];

d = 3; (* true dimension *)
zeros = ConstantArray[0, d];
a = 1;

halfCube1 = 
     Polyhedron[{{-2, -2, -2}, {2, -2, -2}, {2, -2, 2}, {-2, -2, 
     2}, {2,
            2, 2}, {-2, 2, 2}}, {{1, 2, 3, 4}, {3, 4, 6, 5}, {1, 2, 5, 
           6}, {2, 3, 5}, {1, 4, 6}}];

bounds = {{-2, 2}, {-2, 2}, {-2, 2}};
region = 
  RegionIntersection[HalfSpace[{0, -1, 1}, 0], 
   Cuboid[{-2, -2, -2}, {2, 2, 2}]];
halfCube2 = BoundaryDiscretizeRegion[region, bounds];

halfCube3 = 
  Prism[{{-2, -2, -2}, {-2, 2, -2}, {-2, 2, 2}, {2, -2, -2}, {2, 
     2, -2}, {2, 2, 2}}];

halfCube4 = 
  RegionProduct[Line[{{-2}, {2}}], 
   Triangle[{{-2, -2}, {2, -2}, {2, 2}}]];

(* Radius of inscribed sphere *)
R = Sqrt[d] - 1;


as = ConstantArray[a, d - 1];
c1 = {-a}~Join~as;
c2 = {a}~Join~as;
c3 = {-a}~Join~(-as);
c4 = {a}~Join~(-as);

c5 = {a, a, -a};
c6 = {-a, a, -a};

cornerSpheres = Sphere[#, a] & /@ {c1, c2, c3, c4};
sideSpheres = Sphere[#, a] & /@ {c5};
centerSphere = Sphere[zeros, R];
blue = \!\(\*
TagBox[
StyleBox[
RowBox[{"RGBColor", "[", 
RowBox[{"0.57`", ",", "0.54`", ",", "1"}], "]"}],
ShowSpecialCharacters->False,
ShowStringCharacters->True,
NumberMarks->True],
FullForm]\);
spheres = cornerSpheres~Join~{Opacity[1]}~Join~sideSpheres~
       Join~{Opacity[1], blue, centerSphere};

data = {{halfCube1, "original"}, {halfCube2, 
    "BoundaryDiscretizeRegion"}, {halfCube3, "Prism"}, {halfCube4, 
    "RegionProduct"}};
Show[Graphics3D@spheres, Graphics3D@#[[1]], PlotRange -> bounds, 
   PlotLabel -> #[[2]]] & /@ data

enter image description here

$\endgroup$

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.