DMUG-Archiv 2020

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

[Dmug] FN J 2020 HNY

Liebe Freundinnen und Freunde des Neuen Jahres,


im dreidimensionalen Ortsraum können einem Dreikant 7 weitere als Oktanten eines schiefwinkligen Koordinatensystems zugwiesen werden


Clear[dreiKantRaw, dreiKantSpatial]
dreiKantRaw[s_, k1_, k2_, k3_] :=
 Block[{k1s, k2s, k3s, x1, x2, x3, n1, n2, n3, pep12, pep13, pep21,
    pep23, pep31, pep32, targetR, targetM, t, t3, s1, s2, s3, u1, u2,
    u3, res, p, q, g, bCommon},
   If[MatrixRank[{k1, k2, k3} - s] != 3,
    Print["Singular. Bye."];
    Return[$Failed]
    ];
   If[MemberQ[{k1, k2, k3}, s],
    Print["s \[Element] {k1,k2,k3}. Bye."];
    Return[$Failed]
    ];
   {k1s, k2s, k3s} = Normalize /@ rightHand[k1 - s, k2 - s, k3 - s];
   (* Die Spitze des Dreikants sei s, der Spitzenpunkt *)
   {x1, x2, x3} = N[s + #] & /@ {k1s, k2s, k3s};
   n1 = Normalize /@ dreiBein[x1 - s, x2 - s];
   pep12 = Parallelepiped[s, n1];
   pep13 =
    Parallelepiped[s,
     Times[{1, -1, 1}, Normalize /@ dreiBein[x1 - s, x3 - s]]];
   n2 = Normalize /@ dreiBein[x2 - s, x3 - s];
   pep23 = Parallelepiped[s, n2];
   pep21 =
    Parallelepiped[s,
     Times[{1, -1, 1}, Normalize /@ dreiBein[x2 - s, x1 - s]]];
   n3 = Normalize /@ dreiBein[x3 - s, x1 - s];
   pep31 = Parallelepiped[s, n3];
   pep32 =
    Parallelepiped[s,
     Times[{1, -1, 1}, Normalize /@ dreiBein[x3 - s, x2 - s]]];
   targetR =
    RegionIntersection[Region[pep12], Region[pep13], Region[pep21],
     Region[pep23], Region[pep31], Region[pep32]];
   targetM = If[Head[targetR[[1]]] === Parallelepiped,
     ConvexHullMesh[Partition[Flatten[List @@ targetR[[1]]], 3]], (*
     else *)
     ConvexHullMesh[targetR[[1, 1]]]
     ];
   res = ConicOptimization[-t,
     {VectorGreaterEqual[{{s1, s2, t3}, 0}, {"PowerCone", 1/2}],
      VectorGreaterEqual[{{t3, s3, t}, 0}, {"PowerCone", 2/3}],
      t3 >= 0, s1 >= 0, s2 >= 0, s3 >= 0,
      Map[({u1, u2, u3} + # {s1, s2, s3} \[Element] targetM) &,
       Tuples[{0, 1}, 3]]},
     {t, t3, s1, s2, s3, u1, u2, u3}];
   p = Plus @@ ({{u1, u2, u3}, {s1, s2, s3}/2.} /. res);
   q = LinearSolve[Transpose[n1], p - s];
   {n1[[1]], n1[[3]]} = q[[1 ;; 3 ;; 2]] {n1[[1]], n1[[3]]};
   x1 = s + n1[[1]];
   q = LinearSolve[Transpose[n2], p - s];
   {n2[[1]], n2[[3]]} = q[[1 ;; 3 ;; 2]] {n2[[1]], n2[[3]]};
   x2 = s + n2[[1]];
   q = LinearSolve[Transpose[n3], p - s];
   {n3[[1]], n3[[3]]} = q[[1 ;; 3 ;; 2]] {n3[[1]], n3[[3]]};
   x3 = s + n3[[1]];
   {
    {
     Opacity[1/E],
     Polygon[{
       {s, x1, x1 + n1[[3]], x2}, {s, x2, x2 + n2[[3]], x3}, {s, x3,
        x3 + n3[[3]], x1},
       {p, x3 + n3[[3]], x1, x1 + n1[[3]]}, {p, x1 + n1[[3]], x2,
        x2 + n2[[3]]}, {p, x2 + n2[[3]], x3, x3 + n3[[3]]}
       }]
     },
    {AbsolutePointSize[9], Black, Point[s]},
    {AbsolutePointSize[9], Gray, Point[{x1, x2, x3}]},
    {AbsolutePointSize[9], Pink,
     Point[{x1 + n1[[3]], x2 + n2[[3]], x3 + n3[[3]]}]},
    {AbsolutePointSize[9], Red, Point[p]}
    }
   ] /; MatrixQ[{s, k1, k2, k3}, NumericQ] &&
   Dimensions[{s, k1, k2, k3}][[2]] ==
    3 && (Alternatives @@ Join[s, k1, k2, k3]) \[Element] Reals
dreiKantSpatial[k1_, k2_, k3_] :=
 Graphics3D[
   Join[
    dreiKantRaw[{0, 0, 0}, k1, k2, k3],
    dreiKantRaw[{0, 0, 0}, -k1, k2, k3],
    dreiKantRaw[{0, 0, 0}, k1, -k2, k3],
    dreiKantRaw[{0, 0, 0}, k1, k2, -k3],
    dreiKantRaw[{0, 0, 0}, k1, -k2, -k3],
    dreiKantRaw[{0, 0, 0}, -k1, k2, -k3],
    dreiKantRaw[{0, 0, 0}, -k1, -k2, k3],
    dreiKantRaw[{0, 0, 0}, -k1, -k2, -k3]
    ], Boxed -> False
   ] /; MatrixQ[{k1, k2, k3}, NumericQ] &&
   Dimensions[{k1, k2, k3}][[2]] ==
    3 && (Alternatives @@ Join[k1, k2, k3]) \[Element] Reals


und dreiKantSpatial[] kann für Neujahrskarten verwendet werden


dreiKantSpatial @@ RandomInteger[{-10, 9}, {3, 3}]


einmal von "oben" (dmug-2020-seasons-greetings-1.jpg) und einmal von "unten" (dmug-2020-seasons-greetings-2.jpg) gesehen ....


Frohes Neues Jahr!

Udo.


Attachment: dmug-2020-seasons-greetings-1.jpg
Description: JPEG image

Attachment: dmug-2020-seasons-greetings-2.jpg
Description: JPEG image

_______________________________________________
DMUG Deutschsprachiges Mathematica-Forum demug@XXXXXXX.ch
http://www.mathematica.ch/mailman/listinfo/demug
Archiv: http://www.mathematica.ch/archiv.html
Frühere   Chronologischer Index   Spätere
Vorherige   Thematischer Index   Nächste

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