3
$\begingroup$

In the square prism ABCD A1B1C1D1, the bottom side lengths are all equal, where AB=2, and the top and bottom side lengths are all equal, where A1B1=1, and the side edge length AA1=Sqrt[2]

My method is to calculate the height of the prism using known conditions, and how to write the coordinates of each point and draw them.

Clear["Global`*"];
a = {Sqrt[2], 0, 0};
b = {0, Sqrt[2], 0};
c = -a;
d = -b;
o = Mean[{a, b, c, d}]
h = Sqrt[6]/2;
a1 = {Sqrt[2]/2, 0, h};
b1 = {0, Sqrt[2]/2, h};
c1 = {-Sqrt[2]/2, 0, h};
d1 = {0, -Sqrt[2]/2, h};
o1 = Mean[{a1, b1, c1, d1}]
labels = {Text[Style[O, 12, FontFamily -> "Times"], o, {-1, -1}], 
   Text[Style[O1, 12, FontFamily -> "Times"], o1, {-1, -1}], 
   Text[Style[A, 12, FontFamily -> "Times"], a, {-1, -1}], 
   Text[Style[B, 12, FontFamily -> "Times"], b, {1, 1}], 
   Text[Style[C, 12, FontFamily -> "Times"], c, {1, 1}], 
   Text[Style[D, 12, FontFamily -> "Times"], d, {-2, 0}], 
   Text[Style[A1, 12, FontFamily -> "Times"], a1, {3, 0}], 
   Text[Style[B1, 12, FontFamily -> "Times"], b1, {-1, -2}], 
   Text[Style[C1, 12, FontFamily -> "Times"], c1, {0, 1}], 
   Text[Style[D1, 12, FontFamily -> "Times"], d1, {3, 0}]};
dashLines = {Dashed, 
   AbsoluteThickness[2], {Line[{{o, o1}, {d, d1}}]}, {Red, 
    Line[{{c, d}, {a, d}, {b, d}, {a, c}}]}};
realLines = {AbsoluteThickness[2], 
   Line[{{a, b}, {b, b1}, {a1, a}, {b, b1}, {b1, a1}, {c, c1}, {b1, 
      c1}, {c1, d1}, {b, c}, {a1, c1}, {b1, d1}, {a1, d1}}]};
Show[Graphics3D[{dashLines, realLines, labels}, Boxed -> False, 
  ViewPoint -> {2, 3.5, 1.28}], 
 Graphics3D[{Arrow[{{o1 - o, o1 - o + {0, 0, 1}}, {a - o, 
      a - o + {1, 0, 0}}, {b - o, b - o + {0, 1, 0}}}], 
   Text[Style["z", 20, Italic, FontFamily -> "Times"], 
    o1 - o + {0, 0, 1}, {-1, -1}], 
   Text[Style["y", 20, Italic, FontFamily -> "Times"], 
    b - o + {0, 1, 0}, {-2, -1}], 
   Text[Style["x", 20, Italic, FontFamily -> "Times"], 
    a - o + {1, 0, 0}, {2, -1}]}]]

enter image description here

What better method or code optimization is there?

Improve this question
$\endgroup$
4
  • 1
    $\begingroup$ What do you mean by "optimize"? The code seems to work fine, and the graphics appear in a fraction of second. Where is the problem? $\endgroup$
    – Domen
    Commented Jun 12, 2023 at 11:19
  • 1
    $\begingroup$ @Domen I have no problem writing this myself and can draw it. What I mean is to see if everyone has any other methods, with less code and more concise ones. $\endgroup$
    – csn899
    Commented Jun 12, 2023 at 11:21
  • 1
    $\begingroup$ I think it's a good question. I don't have Mathematica at hands at the moment to experiment, but one idea would be to define a function label[text_, coords_] := Text[Style[label, 12, FontFamily -> "Times"], coords, {-1, 1}] and then do e.g. labels = MapThread[label, {{"O", o}, {"O1", o1}, ...}] This would reduce the code duplication a bit. $\endgroup$
    – C. E.
    Commented Jun 12, 2023 at 11:32
  • 3
    $\begingroup$ There is an example in the docs for Hexahedron - see the Applications section ...Create a square frustum parameterized by base width, top width, and height: $\endgroup$
    – flinty
    Commented Jun 12, 2023 at 11:32

2 Answers 2

Reset to default
3
$\begingroup$

Adapting the code from the docs for Hexahedron, you can plug your own values that you solved into this to draw it.

SquareFrustum[wb_, wt_, h_] := With[{
   p1 = {wb/2, 0, 0},
   p2 = {0, wb/2, 0},
   p3 = {-wb/2, 0, 0},
   p4 = {0, -wb/2, 0},
   p5 = {wt/2, 0, h},
   p6 = {0, wt/2, h},
   p7 = {-wt/2, 0, h},
   p8 = {0, -wt/2, h}}, {{Red, Dashed, Line[{p1, p3}], 
    Line[{p2, p4}]}, Line[{p5, p7}], Line[{p6, p8}], FaceForm[None], 
   EdgeForm[Blue], Hexahedron[{p1, p2, p3, p4, p5, p6, p7, p8}]}]

Graphics3D[{SquareFrustum[1, 1/2, 3/4]}, Axes -> True]

enter image description here

Improve this answer
$\endgroup$
3
$\begingroup$

Simplify the main code.

reg = ConvexHullRegion[{a, b, c, d, a1, b1, c1, d1}];
Graphics3D[{EdgeForm[Blue], FaceForm[], reg, 
  Line[{o1, #}] & /@ {a1, b1, c1, d1}, Dashed, Red, 
  Line[{o, #}] & /@ {a, b, c, d}}, Boxed -> False]

enter image description here

Improve this answer
$\endgroup$

Not the answer you're looking for? Browse other questions tagged or ask your own question.