Hallo Patrick,
die Paare definieren die Kanten einer konvexen Hülle von Punkten in der
Ebene, also noch einfacher.
Dann sollte mit
Clear[edges]
edges = {{2, 4}, {8, 2}, {5, 8}, {7, 5}, {9, 7}, {1, 9}, {4, 1}}
und
Clear[fct]
fct[l1_List, l2_List] := If[l1[[2]] == l2[[1]], True, False]
In[82]:= SortBy[edges, # &, fct]
Out[82]= {{2, 4}, {4, 1}, {1, 9}, {9, 7}, {8, 2}, {7, 5}, {5, 8}}
schlicht falsch sein, denn es steht geschrieben, dass das Element x vor
dem Element y eingeordnet wird, wenn fct[x,y] zu True oder 1 evaluiert,
jedoch
In[83]:= fct[{8, 2}, {7, 5}]
Out[83]= False
Im allgemeinen - also nicht bei konvexen Hüllen - kann es zu Unterzyklen
kommen, das zuständige chainIt[] ist
Clear[chainIt]
chainIt[l_List?MatrixQ] := l /; Length[l] == 1
chainIt[l_List?MatrixQ] := Block[{r = {l[[1]]}, l0 = Rest[l], x},
While[Length[l0] > 0,
x = Select[l0, #[[1]] == Last[r][[2]] &];
If[Length[x] == 0,
(* l has a subcycle *)
r = Join[r, chainIt[l0]];
l0 = {}, (* else *)
r = Join[r, x];
l0 = Complement[l0, x]
]
];
r
] /; Length[l] > 1 && Length[Complement @@ Transpose[l]] == 0 &&
Length[Union[Flatten[l]]] == Length[l] &&
FreeQ[Dot[{1, -1}, Transpose[l]], 0]
denn es sind auch Paare {x1,x1} auszuschliessen und mit
Clear[eds]
eds[n_] :=
Transpose[{PermutationReplace[Range[n], RandomPermutation[n]],
PermutationReplace[Range[n], RandomPermutation[n]]}]
und
In[79]:= e1 = eds[20]
Out[79]= {{12, 6}, {15, 9}, {13, 16}, {9, 19}, {8, 1}, {17, 3}, {14,
12}, {5, 20}, {18, 8}, {6, 7}, {1, 10}, {19, 18}, {4, 14}, {11,
15}, {2, 11}, {7, 2}, {20, 4}, {16, 13}, {3, 17}, {10, 5}}
gibt
In[80]:= chainIt[e1]
Out[80]= {{12, 6}, {6, 7}, {7, 2}, {2, 11}, {11, 15}, {15, 9}, {9,
19}, {19, 18}, {18, 8}, {8, 1}, {1, 10}, {10, 5}, {5, 20}, {20,
4}, {4, 14}, {14, 12}, {3, 17}, {17, 3}, {13, 16}, {16, 13}}
mit drei Unterzyklen. Das muss SortBy[] nicht können, zumindest nicht
mit dem angegebenen fct[]. Den Fall eines einzigen Zyklus sollte es
schaffen, oder?
Grüsse
Udo.
Am 10.11.2019 um 13:32 schrieb Patrick Scheibe:
Hey,
nehmen wir an, deine Paare definieren die Kanten in einem Graph
edges = {{2, 4}, {8, 2}, {5, 8}, {7, 5}, {9, 7}, {1, 9}, {4, 1}};
g = Graph[DirectedEdge @@@ edges]
dann sieht man dein chainIt[]-Problem ziemlich schnell aus einer
anderen Perspektive: Einen sogenannten Hamiltonkreis des Graphen g
finden.
FindHamiltonianCycle[g]
(*
{{DirectedEdge[2, 4],
DirectedEdge[4, 1],
DirectedEdge[1, 9],
DirectedEdge[9, 7],
DirectedEdge[7, 5],
DirectedEdge[5, 8],
DirectedEdge[8, 2]
}}
*)
Das Hamiltonkreis-Problem ist NP-vollständig. Ich glaube also nicht,
dass sich ein allgemeines chainIt[] mit Hilfe von SortBy implementieren
lässt.
Cheers
Patrick
On So, 2019-11-10 at 10:20 +0100, Susanne & Udo Krause via demug wrote:
Sali zusammen,
aus der Liste von Paaren edges
In[28]:= edges
Out[28]= {{2, 4}, {8, 2}, {5, 8}, {7, 5}, {9, 7}, {1, 9}, {4, 1}}
In[43]:= chainIt[edges]
Out[43]= {{2, 4}, {4, 1}, {1, 9}, {9, 7}, {7, 5}, {5, 8}, {8, 2}}
soll die verkettete List l[[n-1, 2]] = l[[n,1]] werden, wie im
Beispiel
zu sehen. Die Funktion chainIt[] ist prozedural
Clear[chainIt]
chainIt[l_List?ArrayQ] := l /; Length[l] == 1
chainIt[l_List?ArrayQ] := Block[{r = {l[[1]]}, l0 = Rest[l], x},
If[Length[Complement @@ Transpose[l]] != 0,
Print["Cannot chain these pairs: ", l];
Return[$Failed]
];
While[Length[l0] > 0,
x = Select[l0, #[[1]] == Last[r][[2]] &];
If[Length[x] > 1,
Print["Second element ", Last[r][[2]], " not unique in first
entries. Bye."];
Return[$Failed]
];
r = Join[r, x];
l0 = Complement[l0, x]
];
r
] /; Dimensions[l][[-1]] == 2 && Length[l] > 1
es sollte mit SortBy[] gehen, aber wie? Dieses Ergebnis ist
unverständlich:
In[60]:= Clear[fct]
fct[l1_List, l2_List] := If[l1[[2]] == l2[[1]], True, False]
SortBy[edges, # &, fct]
Out[60]= {{2, 4}, {4, 1}, {1, 9}, {9, 7}, {8, 2}, {7, 5}, {5, 8}}
{8,2} steht falsch drin ... es gehört an das Ende der Ergebnisliste.
Sieht jemand ein funktionales chainIt[] und mag es mitteilen?
grüsse
Udo.
_______________________________________________
DMUG Deutschsprachiges Mathematica-Forum demug@XXXXXXX.ch
http://www.mathematica.ch/mailman/listinfo/demug
Archiv: http://www.mathematica.ch/archiv.html
_______________________________________________
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