5
$\begingroup$

I've been thinking about hexastix and I thought I would try to make some images in Mathematica, similar to this one which I took from Wikipedia:

Hexastix, meaning 4 families of infinite hexagonal prisms, crossing through three dimensional space

So, my first goal is to make a single infinite hexagonal prism. In coordinates, I can represent a hexagonal prism as: $$-1 \leq x-y \leq 1,\ -1 \leq x-z \leq 1,\ -1 \leq y-z \leq 1 .$$

Here is an attempt to render that region in Mathematica:

RegionPlot3D[-1 < x - y < 1 && -1 < x - z < 1 && -1 < y - z < 1 , {x, -3, 3}, {y, -3, 3}, {z, -3, 3}]

And here is the output:

The output of the RegionPlot command, which is bumpy and rounded off

As you can see, Mathematica's mesh has rounded off the flat sides, and also introduced a periodic pattern of bumps. How can I get Mathematica to just draw $6$ flat planes, which is the actual boundary of the shape?

Improve this question
$\endgroup$
2
  • 1
    $\begingroup$ Try using PlotPoints (if you look in the documentation of RegionPlot there are several examples. Could be that this question will be closed, alternatively you could try creating a meshed region which would have sharp edges. $\endgroup$ Commented 2 days ago
  • $\begingroup$ Alternatively you could try making the exact polygon, or potentially you can find this in PolyhedronData. This would then have the "sharp" edges you are wanting $\endgroup$ Commented 2 days ago

3 Answers 3

Reset to default
5
$\begingroup$

It is quite hard to visualize all the angles in your head.

h contains the definition of a single hexagonal prism (as asked by OP).

c = Table[ColorData[97, n], {n, 4}];
cp = CirclePoints[6];

p1 = Partition[Append[#, -12] & /@ cp, 2, 1, 1];
p2 = Reverse /@ Partition[Append[#, 12] & /@ cp, 2, 1, 1];
h = Polygon[Flatten[#, 1] & /@ Thread[{p1, p2}]];

gt = GeometricTransformation;
tt = TranslationTransform;
rt = RotationTransform;

hh = gt[h, 
   tt[#] & /@ (Append[#, 0] & /@ Append[(9 Sqrt[3])/4 cp, {0, 0}])];

Graphics3D[{c[[2]], hh, c[[3]], 
  gt[hh, {tt[{0, (2 Sqrt[3])/2, 0}] . 
     rt[2 ArcCos[1/Sqrt[3]], {0, 1, 0}]}], c[[1]], 
  gt[hh, {tt[{3/2, -(Sqrt[3]/2), 0}] . 
     rt[2 ArcCos[1/Sqrt[3]], {Sqrt[3]/2, -(1/2), 0}]}], c[[4]], 
  gt[hh, {tt[{-(3/2), -(Sqrt[3]/2), 0}] . 
     rt[ArcSec[3], {Sqrt[3]/2, 1/2, 0}]}]}, 
 Lighting -> {{"Ambient", White}}, Boxed -> False]

Show[%, ViewPoint -> Back, ViewVertical -> {0, 0, 1}, 
 ViewProjection -> "Orthographic"]

enter image description here

enter image description here

Improve this answer
$\endgroup$
3
  • $\begingroup$ Oooh. I need to stare at this. $\endgroup$ Commented yesterday
  • $\begingroup$ Okay, what I have learned from this is (a) if I want Mathematica to plot a polytope, I should give it the list of vertices, edges and faces as a Polygon[], not the list of defining inequalities as in RegionPlot[] (b) I should exploit the fact that Polygon can take a list of lists as an input, not just one list and (c) lots of little tricks about graphics. $\endgroup$ Commented yesterday
  • $\begingroup$ In general, (a) might be painful -- computing the face structure of a polytope from its defining inequalities can be really hard -- but it isn't in this case. $\endgroup$ Commented yesterday
3
$\begingroup$

RegionPlot3D make an approximate plot by sampling. To get a clean figure, use Polygon and Graphics3D.

Graphics3D[GraphicsComplex[
  Join[# - 3, 3 - #] &@Most@Tuples[{0, 1}, 3],
  {Point@Range@14,      (* optional: debugging *)
   FaceForm[Blue, Red], (* optional: check orientation *)
   Polygon[{            (* pairs: n, 16-n *)
     {6, 5, 16 - 5, 16 - 6}, {5, 7, 16 - 7, 16 - 5},
     {7, 3, 16 - 3, 16 - 7}, {3, 4, 16 - 4, 16 - 3},
     {4, 2, 16 - 2, 16 - 4}, {2, 6, 16 - 6, 16 - 2}}]}]
 , Axes -> True, AxesLabel -> {x, y, z}
 ]

hexagonal tube

The OP asks for 6 flat planes, so I assumed the caps may be omitted.

Improve this answer
$\endgroup$
3
$\begingroup$ 
spaces = {HalfSpace[{1, -1, 0}, 1], HalfSpace[-{1, -1, 0}, -(-1)], 
   HalfSpace[{1, 0, -1}, 1], HalfSpace[-{1, 0, -1}, -(-1)], 
   HalfSpace[{0, 1, -1}, 1], HalfSpace[-{0, 1, -1}, -(-1)]};
reg = BoundaryDiscretizeRegion[
      RegionIntersection[#, Ball[{0, 0, 0}, 5]]] & /@ spaces // 
   RegionIntersection;
Graphics3D[{EdgeForm[], FaceForm[Green], reg}]

enter image description here

BoundaryDiscretizeGraphics[#, PlotRange -> 5] & /@ 
  spaces // RegionIntersection

enter image description here

Improve this answer
$\endgroup$

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.