[Dmug] WindingCount inconsistent v12.0

[Susanne & Udo Krause via demug <demug@XXXXXXX.ch>]

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 Funktionen

Clear[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]]]] == 2


dann 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]= True

In[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