DMUG-Archiv 2020

Frühere   Chronologischer Index   Spätere
Vorherige   Thematischer Index   Nächste

Re: [Dmug] FN J 2020 HNY

Und bevor Peter bemerkt, dass doConicHullRegion[] nicht dabei war


Clear[doConicHullRegion]
doConicHullRegion[pep_Parallelepiped] :=
 Apply[ConicHullRegion, MapAt[Construct[List, #] &, pep, 1]]


Grüsse

Udo.


Am 27.04.2020 um 19:56 schrieb Susanne & Udo Krause via demug:

Peter bemerkte, dass sphericalTriangle[] nicht dabei war,


Clear[sphericalTriangle]
sphericalTriangle[{u_List?VectorQ, v_List?VectorQ, w_List?VectorQ},
  s_List?VectorQ, r_Real, col_Integer : 0] :=
 Style[Sphere[s, r], tint[col],
   ClipPlanes -> (InfinitePlane[s, #] & /@
      Partition[{u, v, w}, 2, 1, {1, 1}])] /;
  Norm[u] == 1. \[And] Norm[v] == 1. \[And] Norm[w] == 1.


als Bonus für erlittene Unbill lege ich den sphericalTriangleView[] dazu


Clear[sphericalTriangleView]
sphericalTriangleView[s_List, k1_List, k2_List, k3_List,
  r_Real : 1.] := Block[
   {k1s, k2s, k3s, gc},
   If[MatrixRank[Subtract[#, s] & /@ {k1, k2, k3}] != 3,
    Print["Singular. Bye."];
    Return[$Failed]
    ];
   {k1s, k2s, k3s} = Normalize /@ rightHand[k1 - s, k2 - s, k3 - s];
   (* Die Spitze des Dreikants sei s, der Spitzenpunkt *)
   {gc[1], gc[2], gc[3]} =
    First[rot1Shift[#, s, r]] & /@
     Partition[{k1s, k2s, k3s}, 2, 1, {1, 1}];
   Graphics3D[{Splice[Array[gc, 3]],
     Style[Sphere[s, r], LightBlue,
      ClipPlanes -> (InfinitePlane[s, #] & /@
         Partition[{k1s, k2s, k3s}, 2, 1, {1, 1}])],
     {Opacity[0.5],
      doConicHullRegion[Parallelepiped[s, {k1s, k2s, k3s}]]},
     {AbsolutePointSize[8], Black, Point[s]}
     }, Ticks -> Automatic, Axes -> True, AxesLabel -> {"X", "Y", "Z"}
    ]
   ] /; MatrixQ[{s, k1, k2, k3}, NumericQ] \[And]
   Dimensions[{s, k1, k2, k3}][[2]] ==
    3 \[And] (Alternatives @@ Join[s, k1, k2, k3]) \[Element]
    Reals \[And] Positive[r]



Schönen Abend

Udo.

Am 26.04.2020 um 20:33 schrieb Peter Klamser:
image.png

Am So., 26. Apr. 2020 um 12:58 Uhr schrieb Susanne & Udo Krause via demug <demug@XXXXXXX.ch <mailto:demug@XXXXXXX.ch>>:

    Moin moin,

    eine Illustration des erwähnten Nichtvorhandenseins eine
    Polarpunkts im
    Winkelraum des Dreikants; die Illustration ist auf einer Sphäre.

    Clear[dreiBein]
    (* dreiBein gives right-handed triads *)
    dreiBein[x1_, x2_] :=
      Permute[FoldList[Cross, x1, {x2, x1}], Cycles[{{2, 3}}]]


    Clear[rightHand]
    rightHand[v1_, v2_, v3_] :=
      If[Det[{v1, v2, v3}] >= 0., {v1, v2, v3}, {v1, v3, v2}] /;
       MatrixQ[{v1, v2, v3}] \[And] Length[v1] == 3


    Clear[stain, tint]
    stain[o_Integer] :=
      Switch[o, 1, Cyan, 2, Magenta, 3, Yellow, _,
       RGBColor[0.368417`, 0.506779`, 0.709798`]]
    tint[o_Integer] :=
      Switch[o, 1, LightCyan, 2, LightMagenta, 3, LightYellow, _,
    LightBlue]


    Clear[rotator, rot1Shift, rot2Shift]
    rotator[{u_, v_}, \[CapitalTheta]_] :=
       RotationTransform[\[CapitalTheta], {u, v}];
    rot1Shift[{u_List?VectorQ, v_List?VectorQ}, s_List?VectorQ, r_Real,
       col_Integer : 0] := Block[
        {x, t},
        t = rotator[{u, v}, x];
        ParametricPlot3D[s + r t[u], {x, 0, 2 \[Pi]},
         Boxed -> False, Mesh -> None,
         ColorFunction -> Function[{x}, stain[col]]
         ]
        ] /; Norm[u] == 1. \[And] Norm[v] == 1.


    rot2Shift[{u_List?VectorQ, v_List?VectorQ}, s_List?VectorQ, r_Real] :=
       Block[
        {x1, t1, x2, t2},
        t1 = rotator[{u, v}, x1];
        t2 = rotator[{u, Cross[u, v]}, x2];
        ParametricRegion[s + r t2[t1[u]], {{x1, 0, \[Pi]}, {x2, 0,
    \[Pi]}}]
        ] /; Norm[u] == 1. \[And] Norm[v] == 1.


    Clear[sphericalWedges]
    sphericalWedges[s_List, k1_List, k2_List, k3_List, r_Real : 1.] :=
      Block[
        {k1s, k2s, k3s, gc, wed1, wed2, wed3},
        If[MatrixRank[Subtract[#, s] & /@ {k1, k2, k3}] != 3,
         Print["Singular. Bye."];
         Return[$Failed]
         ];
        (* Die Spitze des Dreikants sei s, der Spitzenpunkt *)
        {k1s, k2s, k3s} = Normalize /@ rightHand[k1 - s, k2 - s, k3 - s];
        (* the three-edge wedge *)
        {gc[1], gc[2], gc[3]} =
         First[rot1Shift[#, s, r, 0]] & /@
          Partition[{k1s, k2s, k3s}, 2, 1, {1, 1}];
        gc[4] = sphericalTriangle[{k1s, k2s, k3s}, s, r, 0];
        (* k1s wedge *)
        wed1 = {k1s, Normalize[Last[dreiBein[k1s, k2s]]],
          Normalize[Last[dreiBein[k1s, k3s]]]};
        {gc[5], gc[6], gc[7]} =
         First[rot1Shift[#, s, r, 1]] & /@ Partition[wed1, 2, 1, {1, 1}];
        gc[8] = sphericalTriangle[wed1, s, r, 1];
        (* k2s wedge *)
        wed2 = {k2s, Normalize[Last[dreiBein[k2s, k3s]]],
          Normalize[Last[dreiBein[k2s, k1s]]]};
        {gc[9], gc[10], gc[11]} =
         First[rot1Shift[#, s, r, 2]] & /@ Partition[wed2, 2, 1, {1, 1}];
        gc[12] = sphericalTriangle[wed2, s, 1.01 r, 2];
        (* k3s wedge *)
        wed3 = {k3s, Normalize[Last[dreiBein[k3s, k1s]]],
          Normalize[Last[dreiBein[k3s, k2s]]]};
        {gc[13], gc[14], gc[15]} =
         First[rot1Shift[#, s, r, 3]] & /@ Partition[wed3, 2, 1, {1, 1}];
        gc[16] = sphericalTriangle[wed3, s, 1.02 r, 3];
        Graphics3D[{Splice[Array[gc, 16]],
          {Opacity[1./(2 E)], Sphere[s, r]},
          {AbsolutePointSize[9], Red,
           Point[N[s + r #] & /@ {k1s, k2s, k3s}]},
          {AbsolutePointSize[8], Black, Point[s]},
          Text["1", s + 1.1 r k1s], Text["2", s + 1.1 r k2s],
          Text["3", s + 1.1 r k3s]
          }, Ticks -> Automatic, Axes -> True,
         AxesLabel -> {"X", "Y", "Z"},
         Epilog ->
          Inset[Framed[
            Style[LineLegend[
              Array[stain, 4, 0], {"\[CapitalDelta]",
               "1\[CirclePlus]1\[Wedge][2|3]",
               "2\[CirclePlus]2\[Wedge][3|1]",
               "3\[CirclePlus]3\[Wedge][1|2]"}], 17],
            Background -> Darker[White]], {Right, Bottom}, {Right,
    Bottom}]
         ]
        ] /; MatrixQ[{s, k1, k2, k3}, NumericQ] \[And]
        Dimensions[{s, k1, k2, k3}][[2]] ==
         3 \[And] (Alternatives @@ Join[s, k1, k2, k3]) \[Element]
         Reals \[And] Positive[r]


    und


    sphericalWedges[{2.5375198118901423,
       1.0201933534694305, -0.2564003232040619}, {4.108751704896875, \
    -5.896516517755337,
       5.5495152483048145}, {7.0087325846666175, -1.7010714005314682,
       7.441921892343082}, {-1.3069519434313825, -4.094854182783557, \
    -10.616702282989259}, 18.3]


    erzeugt das [Beweisb|B]ildchen in der Beilage.


    Grüsse

    Udo.

    _______________________________________________
    DMUG Deutschsprachiges Mathematica-Forum demug@XXXXXXX.ch
    <mailto:demug@XXXXXXX.ch>
    http://www.mathematica.ch/mailman/listinfo/demug
    Archiv: http://www.mathematica.ch/archiv.html

_______________________________________________
DMUG Deutschsprachiges Mathematica-Forum demug@XXXXXXX.ch
http://www.mathematica.ch/mailman/listinfo/demug
Archiv: http://www.mathematica.ch/archiv.html
_______________________________________________
DMUG Deutschsprachiges Mathematica-Forum demug@XXXXXXX.ch
http://www.mathematica.ch/mailman/listinfo/demug
Archiv: http://www.mathematica.ch/archiv.html

Verweise:
Frühere   Chronologischer Index   Spätere
Vorherige   Thematischer Index   Nächste

DMUG DMUG-Archiv, http://www.mathematica.ch/archiv.html