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-Archiv, http://www.mathematica.ch/archiv.html