Liebe Freundinnen und Freude der Piccirilloknotenverräumlichung,es mochte neulich so ausgesehen haben, als sei die Reihenfolge der Konturen (contourSequence) händisch erstellt worden. Das war in der Tat der Fall, aber unnötig:
Wenn man mit
Clear[corner2Contour]
(* Damit die Enden kurzer Konturen nicht dichter an den Flanken \
langer Konturen liegen als die Endpunkte langer Konturen an den \
entsprechenden Konturen, muss man mit den kurzen Konturen beginnen. \
Da die Kontouren ähnlich breit sind, kann der Fläacheninhalt die \
Länge stellvertreten. Die zugehörigen CornerPoints werden aus der \
Suchliste herausgenommen. *)
corner2Contour[chain_List] :=
Block[{l = chain \[Intersection] Range[2, Length[cts]], crs0, o,
dist, psm0, scale = 3., psm2, res = {}},
If[Length[l] == 0,
Print["chain does not contain any contour index."];
Return[$Failed]
];
(* start with the least area contours:
this will not work if the small contours are not in chain but \
their corners are in crs *)
l = First[
Transpose[
SortBy[Transpose[{l, Extract[cts, List /@ l]}],
RegionMeasure[Last[#]] &]]];
crs0 = crs;
For[o = 1, o <= Length[l], ++o,
dist = RegionDistance[Region[cts[[l[[o]]]]], #] & /@ crs0;
(* data research: possibly only one corner to the contour *)
psm0 =
Union[Flatten[
Position[dist, #] & /@
TakeSmallest[dist,
Switch[Mean[TakeSmallest[dist, 2]] > scale Min[dist], True,
1, False, 2]]]];
If[Length[psm0] > 2,
(* data research: more than 2 points may have these distances *)
Print["o = ", o,
"| l\[LeftDoubleBracket]o\[RightDoubleBracket] = ", l[[o]],
"| psm0 = ", psm0, "| crs0 = ", crs0];
Break[],(* else *)
psm2 = Flatten[Position[crs, crs0[[#]]] & /@ psm0];
If[Length[psm0] < 2,
crs0 = Drop[crs0, psm0], (* else *)
crs0 = Drop[crs0, Join[psm0, {-(Subtract @@ psm0)}]]
];
res = Join[res, {{l[[o]], psm2}}];
If[Length[crs0] == 0 \[And] o < Length[l],
Print["No more corner points left."];
res = Join[res, {{l[[o + 1 ;;]], {Missing[], Missing[]}}}];
Break[]
]
]
];
res
] /; Head[pk1] == Image \[And] ! FreeQ[cts, Line] \[And]
MatrixQ[crs]
die Zugehörigkeit der Eckpunkte zu den Konturen festgestellt hat
In[27]:= corner2Contour[Range[2, Length[cts]]]
Out[27]= {{55, {100}}, {54, {33}}, {50, {25, 31}}, {23, {60,
71}}, {53, {8, 22}}, {28, {45, 55}}, {35, {87, 93}}, {51, {63,
66}}, {25, {78, 79}}, {46, {70, 90}}, {52, {59, 69}}, {44, {38,
52}}, {43, {75, 91}}, {49, {9, 23}}, {33, {27, 28}}, {36, {12,
26}}, {27, {1, 3}}, {56, {53, 98}}, {32, {19, 34}}, {38, {48,
50}}, {12, {62, 97}}, {18, {20, 74}}, {9, {88, 99}}, {13, {104,
106}}, {14, {92, 102}}, {40, {13, 49}}, {11, {101, 103}}, {19, {14,
43}}, {20, {76, 77}}, {45, {10, 82}}, {48, {37, 39}}, {16, {44,
64}}, {30, {24, 94}}, {4, {5, 61}}, {26, {21, 84}}, {3, {40,
83}}, {5, {7, 17}}, {6, {2, 30}}, {10, {68, 81}}, {42, {15,
85}}, {41, {18, 54}}, {47, {57, 105}}, {8, {6, 80}}, {39, {11,
107}}, {29, {32, 58}}, {2, {4, 35}}, {31, {46, 72}}, {34, {56,
89}}, {22, {36, 67}}, {15, {41, 73}}, {37, {65, 86}}, {7, {16,
47}}, {17, {29, 96}}, {24, {42, 95}}, {21, {51, 108}}}
In[28]:= % == contourCorners
Out[28]= True
kann FindShortestPath[] die contourSequence wie auch die
contourDirections ermitteln (und man entledigt sich der Funktion
cornerSequence), sofern die Abstandsfunktion sinnvoll gewählt wird:
Clear[dist, sep, pes] dist[e1_List?VectorQ,e2_List?VectorQ] := (1 - KroneckerDelta[e1[[1]], e2[[1]]]) EuclideanDistance[crs[[e1[[2]]]], crs[[e2[[2]]]]]
sep[x_List] := {x[[1]], #} & /@ x[[2]]
pes[x_List] := {x[[1, 1]], {x[[1, 2]]}} /; Length[Flatten[x]] == 2
pes[x_List] := {#[[1, 1]], #[[2]]} &[Transpose[x]] /; Length[Flatten[x]]
== 4
In[34]:= Clear[inp]
inp = Flatten [sep /@ contourCorners, 1];
In[36]:= Clear[rp]
rp = FindShortestTour[inp, DistanceFunction -> dist]
Out[37]= {1717.94, {1, 94, 93, 10, 9, 55, 56, 83, 84, 51, 52, 66, 65,
48, 47, 101, 102, 25, 26, 87, 88, 5, 6, 41, 42, 62, 61, 39, 40, 72,
71, 46, 45, 89, 90, 11, 12, 98, 97, 70, 69, 44, 43, 74, 73, 76, 75,
53, 54, 15, 16, 92, 91, 20, 19, 77, 78, 49, 50, 64, 63, 105, 106, 2,
14, 13, 60, 59, 100, 99, 27, 28, 32, 31, 103, 104, 24, 23, 58, 57,
18, 17, 21, 22, 96, 95, 35, 36, 29, 30, 85, 86, 82, 81, 4, 3, 7, 8,
33, 34, 108, 107, 68, 67, 38, 37, 79, 80, 1}}
In[38]:= (* contourSequence *)
DeleteDuplicates[First[Transpose[inp[[Last[rp]]]]]]
Out[38]= {55, 34, 28, 20, 8, 11, 4, 14, 7, 49, 29, 23, 18, 16, 12, 5, \
13, 2, 35, 15, 3, 9, 6, 10, 19, 25, 31, 52, 42, 40, 30, 24, 54, 51, \
48, 37, 33, 27, 17, 43, 45, 46, 44, 22, 32, 36, 39, 47, 50, 53, 56, \
21, 26, 38, 41}
In[39]:= (* contourDirections *)
pes /@ GatherBy[ Most[inp[[Last[rp]]]], First]
Out[39]= {{55, {100}}, {34, {89, 56}}, {28, {55, 45}}, {20, {76,
77}}, {8, {6, 80}}, {11, {101, 103}}, {4, {61, 5}}, {14, {102,
92}}, {7, {16, 47}}, {49, {9, 23}}, {29, {32, 58}}, {23, {60,
71}}, {18, {20, 74}}, {16, {64, 44}}, {12, {62, 97}}, {5, {17,
7}}, {13, {106, 104}}, {2, {4, 35}}, {35, {87, 93}}, {15, {73,
41}}, {3, {83, 40}}, {9, {99, 88}}, {6, {30, 2}}, {10, {81,
68}}, {19, {14, 43}}, {25, {78, 79}}, {31, {72, 46}}, {52, {69,
59}}, {42, {15, 85}}, {40, {13, 49}}, {30, {94, 24}}, {24, {42,
95}}, {54, {33}}, {51, {66, 63}}, {48, {39, 37}}, {37, {86,
65}}, {33, {27, 28}}, {27, {3, 1}}, {17, {29, 96}}, {43, {91,
75}}, {45, {82, 10}}, {46, {90, 70}}, {44, {38, 52}}, {22, {67,
36}}, {32, {19, 34}}, {36, {12, 26}}, {39, {11, 107}}, {47, {105,
57}}, {50, {31, 25}}, {53, {8, 22}}, {56, {53, 98}}, {21, {108,
51}}, {26, {84, 21}}, {38, {50, 48}}, {41, {18, 54}}}
diesmal beginnt der Weg durch den Piccirilloknoten mit einer anderen
Kontur und in der entgegengesetzten Richtung, was bei einem Knoten keine
Rolle spielt.
Einzig die Liste contourBehindSeq muss weiterhin händisch erstellt werden. Mit den besten Grüssen Udo. Am 31.12.2020 um 16:28 schrieb Susanne & Udo Krause via demug:
und hier wäre schliesslich und zu guter Letzt das Bildchen in 3D ... als JPG ist's klein genug.Am 31.12.2020 um 16:11 schrieb Susanne & Udo Krause:Liebe Freundinnen und Freunde der Festtage,der Piccirilloknoten wird der Einfachheit halber in 2 D aufgezeichnet, wie im Bildchen piccirillo-knot.png. Man kann ihn aber aus diesem Bild ohne grossen Aufwand in 3D heben: piccirillo-knot-3-D.png (wird nachgeschickt wg. der Grössenbeschränkung), die nötigen Funktionen sind in piccirillo-knot-1.nb.Die Mathematikerin hat in ihrer Arbeit 'The Conway Knot is not Slice' das neckische Gebandel an der Oberkante nicht gezeichnet, da es offensichtlich leer läuft.Etwas Kosmetik wäre angebracht und könnte angebracht werden beim Übergang auf die hintere Zeichenebene.Mit den besten Grüssen Udo._______________________________________________ DMUG Deutschsprachiges Mathematica-Forum demug@XXXXXXX.ch http://www.mathematica.ch/mailman/listinfo/demug Archiv: http://www.mathematica.ch/archiv.html
piccirillo-knot-1.nb
Description: application/vnd.wolfram.nb
_______________________________________________ DMUG Deutschsprachiges Mathematica-Forum demug@XXXXXXX.ch http://www.mathematica.ch/mailman/listinfo/demug Archiv: http://www.mathematica.ch/archiv.html
