Liebe Freundinnen und Freunde des Neuen Jahres,
------------------------------------------------------------------------
(* Zwei Mittelpunkte und 2 Radien: diese beiden Kreise begrenzen \
einen Tube[]. *)
Clear[maxCondition, minCondition, tubeBetweenCircles]
maxCondition[p1_List, r1_?NumericQ, p2_List, r2_?NumericQ] :=
Max[r1, r2] > EuclideanDistance[p1, p2] + Min[r1, r2]
minCondition[p1_List, r1_?NumericQ, p2_List, r2_?NumericQ] :=
Min[r1, r2] > EuclideanDistance[p1, p2]
tubeBetweenCircles::radiiMax =
"Circle[`1`,`2`] and Circle[`3`,`4`] violate the max condition.";
tubeBetweenCircles::radiiMin =
"Circle[`1`,`2`] and Circle[`3`,`4`] violate the min condition.";
tubeBetweenCircles[p1_List,
r1_?NumericQ (* circle 1 *),
p2_List,
r2_?NumericQ (* circle 2*),
pt_Integer (* number of circle approximation points *),
cs_Integer (* color schema *)
] := Block[{okQ = True, p3 = (p1 + p2)/2.,
r3 = (r1 + r2)/2., \[Phi]},
If[Not[maxCondition[p1, r1, p2, r2]],
Message[tubeBetweenCircles::radiiMax, p1, r1, p2, r2];
okQ = False
];
If[Not[minCondition[p1, r1, p2, r2]],
Message[tubeBetweenCircles::radiiMin, p1, r1, p2, r2];
okQ = False
];
\[Phi] = If[Chop[EuclideanDistance[p1, p2]] == 0,
.0, (* else *)
If[r1 < r2,(*
start the tube at the position with the smallest radius *)
ArcTan @@ (p1 - p2), (* else *)
ArcTan @@ (p2 - p1)
]
];
If[okQ,
{CapForm[None], JoinForm["Miter"], Specularity[White, 83],
RandomChoice[ColorData[cs, "ColorList"]],
Tube[
BSplineCurve[
Transpose[
Join[Transpose[
CirclePoints[p3, {r3, \[Phi]}, pt]], {ConstantArray[0.,
pt]}]], SplineClosed -> True],
Table[(Max[r1, r2] - Min[r1, r2] -
Cos[x - \[Phi]] EuclideanDistance[p1, p2])/
2., {x, \[Phi], \[Phi] + 2 \[Pi], 2 \[Pi]/(pt - 1)}]
]
}, (* else *)
Missing[]
]
] /; MatrixQ[{p1, p2}] \[And]
Dimensions[{p1, p2}] == {2, 2} \[And] Positive[r1] \[And]
Positive[r2] \[And] pt > 2
(* unpacking helper *)
tubeBetweenCircles[l1_List, l2_List, xp_Integer, xc_Integer] :=
tubeBetweenCircles[l1[[1]], l1[[2]], l2[[1]], l2[[2]], xp, xc]
Clear[blowedCircles]
blowedCircles::radii = "All radii negative. Bye.";
blowedCircles::data = "Data: `1`";
blowedCircles[deg_Integer(* degree *),
n_Integer (* number of midpoints and biggest radius *),
\[Delta]_Real (* defect *),
pt_Integer (* number of circle approximation points *),
cs_Integer(* colorSchema *)] :=
Block[{x, pts , mids, r0 = n, rds, fontSz = 120, midrd},
pts = N[
Join[{{0, 0}},
ReIm /@ (List @@ (Reduce[x^deg == 1, x][[All, 2]]))]];
mids = RandomChoice[pts, n];
rds = FoldList[(#1 - dist[#2] - \[Delta]) &, r0,
Partition[mids, 2, 1]];
midrd = Select[MapThread[List, {mids, rds}], (#[[2]] > .0) &];
If[Length[midrd] < 1,
Message[blowedCircles::radii];
Return[$Failed]
];
Message[blowedCircles::data, midrd];
Graphics3D[
DeleteMissing[
Apply[tubeBetweenCircles[##, pt, cs] &, Partition[midrd, 2, 1], 1]
],
ViewPoint -> Above,
Boxed -> False,
Background -> Black,
(* ClipPlanes->InfinitePlane[{{0,0,0},{1,0,0},{0,-1,0}}], *)
Epilog -> {Inset[Style["0", fontSz, Yellow], Scaled[{.9, .9}],
Automatic, Automatic, {Automatic, {1, 1}}],
Inset[Style["2", fontSz, Yellow], Scaled[{.9, .1}], Automatic,
Automatic, {Automatic, {-1, 1}}],
Inset[Style["2", fontSz, Yellow], Scaled[{.1, .1}], Automatic,
Automatic, {1, -1}],
Inset[Style["2", fontSz, Yellow], Scaled[{.1, .9}], Automatic,
Automatic, {Automatic, {-1, 1}}]}
]
] /; deg > 1 \[And] n > 0 \[And] \[Delta] > 1/10^3 \[And]
1 <= cs <= 4 24 \[And] pt > 2
------------------------------------------------------------------------
Off[blowedCircles::data]
blowedCircles[3, 11, .93, 19, 35]
------------------------------------------------------------------------
gibt Bildchen wie dieses
hny-2022-1
grüsse
Udo.
P.S.: Spruch des Jahres: Lieber sentimental als dekremental & Viel Spass
mit Mathematica 13.0.0.0
_______________________________________________
DMUG Deutschsprachiges Mathematica-Forum 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