2
$\begingroup$

Let be given a pyramid SABCD. Put H is projection of A on SB and H is projection of A on SD. I work around to find coordinates of H and K. How can I get two points H and K with Mathematica and plot it? I tried

Clear[DashedGraphics3D]
DashedGraphics3D::optx = 
  "Invalid options for Graphics3D are omitted: `1`.";
Off[OptionValue::nodef];
Options[DashedGraphics3D] = {ViewAngle -> 0.4, 
   ViewPoint -> {3, -1, 0.5}, ViewVertical -> {0, 0, 1}, 
   ImageSize -> 800};
DashedGraphics3D[basegraph_, effectFunction_ : Identity, 
   opts : OptionsPattern[]] /; ! 
   MatchQ[Flatten[{effectFunction}], {(Rule | RuleDelayed)[__] ..}] :=
  Module[{basegraphClean = basegraph /. (Lighting -> _) :> Sequence[],
    exceptopts, fullopts, frontlayer, dashedlayer, borderlayer, 
   face3DPrimitives = {Pyramid, Cuboid, Cone, Cylinder, Sphere, Tube, 
     BSplineSurface}}, 
  exceptopts = FilterRules[{opts}, Except[Options[Graphics3D]]];
  If[exceptopts =!= {}, Message[DashedGraphics3D::optx, exceptopts]];
  fullopts = 
   Join[FilterRules[Options[DashedGraphics3D], Except[#]], #] &@
    FilterRules[{opts}, Options[Graphics3D]];
  frontlayer = 
   Show[basegraphClean /. Line[pts__] :> {Thick, Line[pts]} /.
      h_[pts___] /; 
        MemberQ[face3DPrimitives, h] :> {EdgeForm[{Thick}], h[pts]}, 
     fullopts, Lighting -> {{"Ambient", White}}] // Rasterize;
  dashedlayer = Show[basegraphClean /.
       {Polygon[__] :> {}, Line[pts__] :> {Dashed, Line[pts]}} /.
      h_[pts___] /; MemberQ[face3DPrimitives, h] :> {FaceForm[], 
        EdgeForm[{Dashed}], h[pts]}, fullopts] // Rasterize;
  borderlayer = 
   Show[basegraphClean /. RGBColor[__] :> Black, 
       ViewAngle -> (1 - .001) OptionValue[ViewAngle], 
       Lighting -> {{"Ambient", Black}}, fullopts, Axes -> False, 
       Boxed -> False] // Rasterize // GradientFilter[#, 1] & // 
    ImageAdjust;
  ImageSubtract[frontlayer, dashedlayer] // effectFunction // 
      ImageAdd[frontlayer // ColorNegate, #] & // 
     ImageAdd[#, borderlayer] & // ColorNegate // ImageCrop]

and then

a = 2;
h = 3;
pA = {0, 0, 0};
pB = {a, 0, 0};
pC = {a, 2*a, 0};
pD = {0, 2*a, 0};
pS = {0, 0, h};
pH = {a*h^2/(a^2 + h^2), 0, a^2*h/(a^2 + h^2)};
pK = {0, 2*a*h^2/(4*a^2 + h^2), 4*a^2*h/(4*a^2 + h^2)};
pyramid = Pyramid[{pA, pB, pC, pD, pS}];
DashedGraphics3D[Graphics3D[pyramid, Boxed -> False], 
 ViewPoint -> {3, 2, 1}]

I got enter image description here

$\endgroup$
4
  • $\begingroup$ does DashedGraphics3D[ Graphics3D[{pyramid, Red, Line[{pA, pH}], Green, Line[{pA, pK}]}, Boxed -> False], ViewPoint -> {3, 2, 1}] give what you need? $\endgroup$
    – kglr
    Oct 16 at 5:43
  • $\begingroup$ In my code. I find two points H and K by Maple. How can I find it by Mathematica? $\endgroup$ Oct 16 at 5:59
  • 2
    $\begingroup$ try ph = RegionNearest[Line[{pB, pS}], pA] and pk = RegionNearest[Line[{pD, pS}], pA]? $\endgroup$
    – kglr
    Oct 16 at 6:06
  • $\begingroup$ @kglr Yes. Thank you very much. $\endgroup$ Oct 16 at 8:30

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.