Liebe Freundinnen und Freunde des WindingCount,man kann den WindingCount[] auf einer HilbertCurve[] ausführen, die man schliesst; alle Eckpunkte der HilbertCurve[] kommen als Paare von ganzen Zahlen und haben kreisförmige Umgebungen, die entweder zu 1/4 (90°) oder zu 3/4 (270°) zum Inneren der geschlossenen HilbertCurve[] gehören. WindingCount[] ermittelt auf den Eckpunkten -1 (bedeutet eine Umrundung im math. pos. Drehsinn (counterclockwise) <hm/>) oder 0, soweit kontrolliert (bis einschliesslich HilbertCurve[6]).
(* HilbertCurve[] comes in 2-tuples of Integers *) Clear[closedHilbertCurve, wiChiC]closedHilbertCurve[n_Integer?Positive] := Line[Join[#, {Last[#] - {0, 1}, First[#] - {0, 1}, First[#]}]] &[HilbertCurve[n][[1]]]
wiChiC[n_Integer?Positive] := Block[{r0, l0},
r0 = WindingCount[closedHilbertCurve[n], #] & /@
closedHilbertCurve[n][[1]];
l0 = Length[r0];Inner[Rule, Range[l0], r0, List] /. Rule[o_Integer, oo_Integer] -> Rule[{n, o}, oo]
]
das Bildchen
ArrayPlot[
SparseArray[Flatten[Table[wiChiC[oo], {oo, 6}], 1], Automatic, 8],
ColorRules -> {-1 -> Blue, 0 -> Green, 8 -> Gray, _ -> Red},
Frame -> True, FrameTicks -> Automatic,
FrameLabel -> {"HC[n]", "WindingCount"},
PlotLabel -> "Wolfram::WindingCount on Closed HilbertCurve"
]
ist recht lang und schmal, deshalb die linke Seite und das Ende der
Ergebnisse des WindingCount der fünften HilbertCurve über der sechsten.
Wie es scheint, sind die Ergebnisse von WindingCount von HilbertCurve[n]
zu HilbertCurve[n+1] komplementär (-1 -> 0 und 0 -> -1) in der gegebenen
Reihenfolge und solange die HilbertCurve mit dem kleineren Index
überhaupt Ecken hat, m.a.W. etwa
In[27]:= With[{r5 = WindingCount[closedHilbertCurve[5], #] & /@ closedHilbertCurve[5][[1]], r6 = WindingCount[closedHilbertCurve[6], #] & /@ closedHilbertCurve[6][[1]]},
Union[r5 + Take[r6, Length[r5]]]
]
Out[27]= {-1}
grüsse
Udo.
Am 19.10.2019 um 13:05 schrieb Susanne & Udo Krause via demug:
Liebe Freundinnen und Freunde des WindingCount,kürzlich hat Wolfram die Function of the Day = WindingCount wolfr.am/GTO6ehwk getwittert. Tut man dumm und definiert die FunktionenClear[crossPoint, lineCross] crossPoint[lp_List] :=Block[{p11 = lp[[1, 1]], p12 = lp[[1, 2]], p21 = lp[[2, 1]], p22 = lp[[2, 2]], x}, x = Quiet[Check[LinearSolve[Transpose[{p12 - p11, -(p22 - p21)}], p21 - p11], {}, {LinearSolve::nosol}]];If[Length[x] > 0 && 0 <= x[[1]] <= 1 && 0 <= x[[2]] <= 1, p11 + x[[1]] (p12 - p11), (* equals to p21 + x[[2]] (p22-p21) *) Missing[] ] ] /; Dimensions[lp] == {2, 2, 2}lineCross[ln_Line] := DeleteMissing[crossPoint /@ Subsets[Partition[ln[[1]], 2, 1], {2}]] /;ArrayQ[ln[[1]]] && Last[Dimensions[ln[[1]]]] == 2dann kann man zu der geschlossenen selbstdurchkreuzenden Line der Hilfe (https://reference.wolfram.com/language/ref/WindingCount.html)In[9]:= Clear[\[ScriptCapitalR]]\[ScriptCapitalR] = Line[{{0.35, 0.2}, {0.9, 0.75}, {0.1, 0.55}, {0.9, 0.35}, {0.42, 0.9}, {0.35, 0.2}}];alle Schnittpunkte bestimmen In[85]:= lineCross[\[ScriptCapitalR]]Out[85]= {{0.9, 0.75}, {0.58, 0.43}, {0.713592, 0.563592}, {0.35, 0.2}, {0.1, 0.55}, {0.613433, 0.678358}, {0.392308, 0.623077}, {0.9,0.35}, {0.378049, 0.480488}, {0.42, 0.9}} und nachschauen, dass die Punkte richtig liegen:In[88]:= Graphics[\[ScriptCapitalR], Epilog -> {Blue, PointSize[Medium ], Point[lineCross[\[ScriptCapitalR]]]}]Der WindingCount auf diesen Punkten sollte 0 sein, da von jedem Punkt Halbgeraden ins Unendliche gezogen werden können, die die geschlossene Line \[ScriptCapitalR] nicht schneiden, jedoch:In[89]:= WindingCount[\[ScriptCapitalR], #] & /@ lineCross[\[ScriptCapitalR]]Out[89]= {0, 2, 0, 0, 0, 0, 1, 0, 0, 0}In[90]:= WindingCount[Line[Rationalize /@ \[ScriptCapitalR][[1]]], #] & /@ (Rationalize /@ lineCross[\[ScriptCapitalR]])Out[90]= {0, 1, 0, 0, 1, 1, 2, 0, 1, 0}die Inkonsistenz besteht einerseits numerisch, dann aber auch in dem Sinne, dass wenigstens alle Punkte von \[ScriptCapitalR] denselben WindingCount auf \[ScriptCapitalR] haben sollten, ebenso wie alle Schnittpunkte von Strecken aus \[ScriptCapitalR]. Das ist nicht der Fall:In[96]:= Union[(Rationalize /@ \[ScriptCapitalR][[1]]) \[Intersection] (Rationalize /@ lineCross[\[ScriptCapitalR]])] ==Union[Rationalize /@ \[ScriptCapitalR][[1]]] Out[96]= TrueIn[97]:= WindingCount[Line[Rationalize /@ \[ScriptCapitalR][[1]]], #] & /@ (Rationalize /@ \[ScriptCapitalR][[1]])Out[97]= {0, 0, 1, 0, 0, 0}In[100]:= WindingCount[Line[Rationalize /@ \[ScriptCapitalR][[1]]], #] & /@ Complement[Rationalize /@ lineCross[\[ScriptCapitalR]],Rationalize /@ \[ScriptCapitalR][[1]]] Out[100]= {1, 2, 1, 1, 0}Bei Wolfram ist das CASE 4333745. Mathematica 12.0 mit Windows 64 Bit Funktionsupdate 1903.grüsse Udo. _______________________________________________ DMUG Deutschsprachiges Mathematica-Forum demug@XXXXXXX.ch http://www.mathematica.ch/mailman/listinfo/demug Archiv: http://www.mathematica.ch/archiv.html
windingCount-wiChiC-6-linkeSeite.jpg
Description: JPEG image
windingCount-wiChiC-6-Ende-hiC-5.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
