DMUG-Archiv 2019

Frühere   Chronologischer Index   Spätere
Vorherige   Thematischer Index   Nächste

Re: [Dmug] Infirmis proceduralis

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

Antworten:
Verweise:
Frühere   Chronologischer Index   Spätere
Vorherige   Thematischer Index   Nächste

DMUG DMUG-Archiv, http://www.mathematica.ch/archiv.html