Hallo zusammen,das Dreikant (die körperliche Ecke) ist in http://www.zeno.org/Lueger-1904/A/Dreikant beschrieben als
°*Dreikant*, eine von drei durch einen Punkt gehendenEbenen <http://www.zeno.org/Lueger-1904/A/Ebenen>begrenzte körperlicheEcke <http://www.zeno.org/Lueger-1904/A/Ecke>.
°Wählt man im Winkelräume eines Dreikants einen Punkt und fällt von ihm Senkrechte zu den Seiten des Dreikants, so entsteht ein neues Dreikant, dessenKanten <http://www.zeno.org/Lueger-1904/A/Kante+%5B1%5D>zu denFlächen <http://www.zeno.org/Lueger-1904/A/Fl%C3%A4che+%5B1%5D>des ersten Dreikants senkrecht stehen und in dem die Seiten- bezw. Flächenwinkel dieFlächen <http://www.zeno.org/Lueger-1904/A/Fl%C3%A4che+%5B1%5D>- bezw. Seitenwinkel des ursprünglichen Dreikants zu je 180° ergänzen, weshalb das zweite Dreikant auch das Supplementär- oder Polardreikant der ersten heißt.
Der Ecke des anfänglichen Dreikants wird als Spitzenpunkt bezeichnet, der Spitzenpunkt des Polardreikants wird als Polarpunkt des anfänglichen Dreikants bezeichnet. Der Einheitswürfel kann angesehen werden als Dreikant mit Spitzenpunkt {0,0,0} und Polarpunkt {1,1,1}.
Bei der Berechnung des Polarpunkts scheint man es sich zunächst einfach machen zu können, indem man Skalenfaktoren für die drei Vektoren des Dreikants mitgibt, durch die Endpunkte der skalierten Vektoren senkrechte Ebenen legt und den Polarpunkt als Schnittpunkt dieser drei senkrechten Ebenen ausrechnet:
Clear[dreiBein]
(* dreiBein gives left-handed triads *)
dreiBein[x1_, x2_] := FoldList[Cross, x1, {x2, x1}]
Clear[dreiKantSc]
dreiKantSc[s_, k1_, k2_, k3_, r_] :=
Block[{c9 = {-1, 0, 0, -1, 0, 0, -1, 0, 0},
c6 = ConstantArray[0, 6], c3 = ConstantArray[0, 3],
x1, x2, x3, n1, n2, n3, q, p, 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]
];
(* Die Spitze des Dreikants sei s *)
x1 = s + r[[1]] Normalize[k1 - s];
x2 = s + r[[2]] Normalize[k2 - s];
x3 = s + r[[3]] Normalize[k3 - s];
n1 = Normalize /@ dreiBein[x1 - s, x2 - s];
n2 = Normalize /@ dreiBein[x2 - s, x3 - s];
n3 = Normalize /@ dreiBein[x3 - s, x1 - s];
(* Die Spitze des Polardreikants sei s *)
q = LinearSolve[Transpose[{Join[n1[[2]], c6],
Join[n1[[3]], c6],
Join[c3, n2[[2]], c3],
Join[c3, n2[[3]], c3],
Join[c6, n3[[2]]],
Join[c6, n3[[3]]],
c9,
RotateRight[c9, 1],
RotateRight[c9, 2]}], -Join[x1, x2, x3]
];
(* Polarpunkt p *)
p = Take[q, -3];
{n1[[3]], n2[[3]], n3[[3]]} =
q[[2 ;; 6 ;; 2]] {n1[[3]], n2[[3]], n3[[3]]};
bCommon =
If[Sign[((p - s).n1[[2]])/Norm[p - s]] !=
Sign[((x3 - s).n1[[2]])/Norm[x3 - s]]
|| Sign[((p - s).n2[[2]])/Norm[p - s]] !=
Sign[((x1 - s).n2[[2]])/Norm[x1 - s]]
|| Sign[((p - s).n3[[2]])/Norm[p - s]] !=
Sign[((x2 - s).n3[[2]])/Norm[x2 - s]]
(* --------- *)
|| Sign[((x3 + n3[[3]] - s).n1[[2]])/Norm[x3 + n3[[3]] - s]] !=
Sign[((x3 - s).n1[[2]])/Norm[x3 - s]]
|| Sign[((x3 + n3[[3]] - s).n2[[2]])/Norm[x3 + n3[[3]] - s]] !=
Sign[((x1 - s).n2[[2]])/Norm[x1 - s]]
(* --------- *)
|| Sign[((x1 + n1[[3]] - s).n2[[2]])/Norm[x1 + n1[[3]] - s]] !=
Sign[((x1 - s).n2[[2]])/Norm[x1 - s]]
|| Sign[((x1 + n1[[3]] - s).n3[[2]])/Norm[x1 + n1[[3]] - s]] !=
Sign[((x2 - s).n3[[2]])/Norm[x2 - s]]
(* --------- *)
|| Sign[((x2 + n2[[3]] - s).n3[[2]])/Norm[x2 + n2[[3]] - s]] !=
Sign[((x2 - s).n3[[2]])/Norm[x2 - s]]
|| Sign[((x2 + n2[[3]] - s).n1[[2]])/Norm[x2 + n2[[3]] - s]] !=
Sign[((x3 - s).n1[[2]])/Norm[x3 - s]],
If[FileExistsQ[
FileNameJoin[{$TemporaryDirectory, "dreikant-outlier.txt"}]],
PutAppend[{s, k1, k2, k3, r},
FileNameJoin[{$TemporaryDirectory, "dreikant-outlier.txt"}]],
Put[{s, k1, k2, k3, r},
FileNameJoin[{$TemporaryDirectory, "dreikant-outlier.txt"}]]
];
False, (* else *)
True
];
Graphics3D[
{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]]}
}],
{PointSize[0.03], Black, Point[s]},
{PointSize[0.03], Gray, Point[{x1, x2, x3}]},
{PointSize[0.03], Pink,
Point[{x1 + n1[[3]], x2 + n2[[3]], x3 + n3[[3]]}]},
{PointSize[0.03], Red, Point[p]}
}, Ticks -> Automatic, Axes -> True, AxesLabel -> {"X", "Y", "Z"},
PlotLabel -> If[bCommon, "Common", "Outlier"]
]
] /; MatrixQ[{s, k1, k2, k3, r}, NumericQ] &&
VectorQ[r, Positive] &&
Dimensions[{s, k1, k2, k3, r}][[2]] ==
3 && (Alternatives @@ Join[s, k1, k2, k3]) \[Element] Reals
leider verfehlt man überraschenderweise den Raumwinkel des Dreikants
allzuoft, z.B.
dreiKantSc[{0, 0, 0}, {1, 0, 7/3}, {2/3, 1, 0}, {0, 1/2, 1}, {1, 1, 3}]
Bild dreikantsc-outlier-1.jpg, der Spitzenpunkt ist schwarz, der
Polarpunkt rot dargestellt.
Die Seitenflächen bestehen entweder aus dem Spitzenpunkt (schwarz), zwei grauen Punkten, in denen die Kanten senkrecht geschnitten werden und einem rosa Punkt, dem Fusspunkt des Lotes des Polarpunkts auf eine Seitenfläche des Dreikants oder aus dem Polarpunkt (rot), zwei Lotfusspunkten (rosa) und einem Kantenschnittpunkt (grau). Offensichtlich kommt es zu diversen Selbstdurchkreuzungen, aber wenigstens zwei Seitenflächen sind von der genannten Art.
Ein anderer Fall ist
dreiKantSc[{3.7495296493250976, -9.325407937118118, \
-1.243225782009901}, {1.074937545808659, -5.962754165608377,
3.013370202031119}, {1.420286197444991, -4.576384163215863,
8.081919126773869}, {1.888686725813102, 1.5099240927631143,
3.7329598302209703}, {1.2323397849183406, 0.49180259441171614,
2.27770067617005}]
Bild dreikantsc-outlier-2.jpg mit überhaupt keiner Seitenfläche ohne
Kantenüberkreuzung.
Es muss also ein anderes Verfahren gesucht werden, um einen Polarpunkt zu finden. Dazu bietet es sich an, im Durchschnitt der 6 Oktanten zu suchen, von denen jeder den Spitzenpunkt, eine Kante und eine Seitenfläche mit dem Dreikant gemeinsam hat. (Rechtwinklige) Oktanten sind zu verwenden, weil vom Polarpunkt Lote auf die Seitenflächen zu fällen sind und die Kanten des Dreikant nicht jenseits des Spitzenpunkts (bei negativen Koordinaten) geschnitten werden dürfen.
Um einen geeigneten Punkt im Oktantendurchschnitt zu finden, wird die konische Optimierung auf der konvexen Hülle des Oktantendurchschnitts verwendet:
Clear[rightHand]
rightHand[v1_, v2_, v3_] := Block[{a = VectorAngle[Cross[v1, v2], v3]},
If[a > \[Pi]/2,
a = VectorAngle[Cross[v2, v1], v3];
If[a > \[Pi]/2,
Print["Numerical complanar. Fail."];
{v1, v2, v3},(* else *)
{v2, v1, v3}
], (* else *)
{v1, v2, v3}
]
] /; MatrixQ[{v1, v2, v3}] && Length[v1] == 3
Clear[dreiKant]
dreiKant[s_, k1_, k2_, k3_, bRegion_: False] :=
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}];
(* Polarpunkt p *)
p = Plus @@ ({{u1, u2, u3}, {s1, s2, s3}/2.} /. res);
g = If[bRegion,
{
{
{Green, Opacity[0.2], targetM, Yellow, Opacity[0.8],
Cuboid[{u1, u2, u3}, {u1 + s1, u2 + s2, u3 + s3}] /. res},
Polygon[{
{s, x1, x1 + n1[[3]], x2}, {s, x2, x2 + n2[[3]], x3}, {s, x3,
x3 + n3[[3]], x1}}],
{PointSize[0.03], Black, Point[s]},
{PointSize[0.03], Gray, Point[{x1, x2, x3}]},
{PointSize[0.03], Pink,
Point[{x1 + n1[[3]], x2 + n2[[3]], x3 + n3[[3]]}]}
},
Ticks -> Automatic, Axes -> True, AxesLabel -> {"X", "Y", "Z"}
}, (* else *)
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]];
bCommon =
If[Sign[((p - s).n1[[2]])/Norm[p - s]] !=
Sign[((x3 - s).n1[[2]])/Norm[x3 - s]]
||
Sign[((p - s).n2[[2]])/Norm[p - s]] !=
Sign[((x1 - s).n2[[2]])/Norm[x1 - s]]
||
Sign[((p - s).n3[[2]])/Norm[p - s]] !=
Sign[((x2 - s).n3[[2]])/Norm[x2 - s]]
(* --------- *)
||
Sign[((x3 + n3[[3]] - s).n1[[2]])/Norm[x3 + n3[[3]] - s]] !=
Sign[((x3 - s).n1[[2]])/Norm[x3 - s]]
||
Sign[((x3 + n3[[3]] - s).n2[[2]])/Norm[x3 + n3[[3]] - s]] !=
Sign[((x1 - s).n2[[2]])/Norm[x1 - s]]
(* --------- *)
||
Sign[((x1 + n1[[3]] - s).n2[[2]])/Norm[x1 + n1[[3]] - s]] !=
Sign[((x1 - s).n2[[2]])/Norm[x1 - s]]
||
Sign[((x1 + n1[[3]] - s).n3[[2]])/Norm[x1 + n1[[3]] - s]] !=
Sign[((x2 - s).n3[[2]])/Norm[x2 - s]]
(* --------- *)
||
Sign[((x2 + n2[[3]] - s).n3[[2]])/Norm[x2 + n2[[3]] - s]] !=
Sign[((x2 - s).n3[[2]])/Norm[x2 - s]]
||
Sign[((x2 + n2[[3]] - s).n1[[2]])/Norm[x2 + n2[[3]] - s]] !=
Sign[((x3 - s).n1[[2]])/Norm[x3 - s]],
If[
FileExistsQ[
FileNameJoin[{$TemporaryDirectory, "dreikant-outlier.txt"}]],
PutAppend[{s, k1, k2, k3},
FileNameJoin[{$TemporaryDirectory,
"dreikant-outlier.txt"}]], (* else *)
Put[{s, k1, k2, k3},
FileNameJoin[{$TemporaryDirectory, "dreikant-outlier.txt"}]]
];
False, (* else *)
True
];
{
{
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]]}
}],
{PointSize[0.03], Black, Point[s]},
{PointSize[0.03], Gray, Point[{x1, x2, x3}]},
{PointSize[0.03], Pink,
Point[{x1 + n1[[3]], x2 + n2[[3]], x3 + n3[[3]]}]},
{PointSize[0.03], Red, Point[p]}
}, Ticks -> Automatic, Axes -> True,
AxesLabel -> {"X", "Y", "Z"},
PlotLabel -> If[bCommon, "Common", "Outlier"]
}
];
Graphics3D @@ g
] /; MatrixQ[{s, k1, k2, k3}, NumericQ] &&
Dimensions[{s, k1, k2, k3}][[2]] ==
3 && (Alternatives @@ Join[s, k1, k2, k3]) \[Element] Reals &&
bRegion \[Element] Booleans
Mit dieser Konstruktion gelingt es zuverlässig, den Polarpunkt zu finden
und ein Dreikant mit seinem Polardreikant zu zeichnen, Bild dreikant-1.jpg.
Mit den besten Grüssen Udo.
dreikantsc-outlier-2.jpg
Description: JPEG image
dreikantsc-outlier-1.jpg
Description: JPEG image
dreikant-1.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
