DMUG-Archiv 2019

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

Re: [Dmug] Infirmis proceduralis

Moin moin,


fct[] wollte ein letztes Element festlegen, ist jedoch nicht transitiv und ermöglicht es SortBy[] daher, die junk-in-junk-out-Verfahrensweise an den Tag zu legen, was SortBy[] auch tut.


(* okay with chainIt[], but it is procedural. Go with SortBy[edges, \
Identity, fct], but make fct an ordering function. fct is an ordering \
function ordf if and only if elements Subscript[e, i ]which are not \
the direct predecessor of an element Subscript[e, j ]get True if \
there is a chain of True-values from Subscript[e, i] to Subscript[e, \
j]. *)
Clear[fct, ordf, zuf]
fct[x_Integer, l1_List, l2_List] :=
 If[(l1[[2]] == l2[[1]]) && (l1[[2]] != x), True, False]
ordf[x_Integer, ed_List?MatrixQ, l1_List, l2_List] :=
 Block[{bRes = False, l3 },
  If[(l1[[2]] == l2[[1]]) && (l1[[2]] != x),
   bRes = True,(* else "*)
   If[l1[[2]] != x,
    l3 = Select[ed, #[[1]] == l1[[2]] &][[1]];
    While[l3 != l2 && Length[l3] > 0,
     If[(l3[[2]] == l2[[1]]) && (l3[[2]] != x),
      bRes = True;
      Break[], (* else *)
      If[l3[[2]] == x,
       Break[], (* else *)
       l3 = Select[ed, #[[1]] == l3[[2]] &][[1]]
       ]
      ]
     ]
    ]
   ];
  bRes
  ]
zuf[x_Integer, l1_List, l2_List] :=
 If[(l1[[2]] != x) && RandomInteger[{0, 1}] == 1, True, False]


Beim Ergebnis von chainIt[edges]

In[8]:= (* goal: sort so that r[[n-1,2]\[Equal]r[[n,1]] *)
chainIt[edges]

Out[8]= {{2, 4}, {4, 1}, {1, 9}, {9, 7}, {7, 5}, {5, 8}, {8, 2}}


ist edges[[2,2]] das letzte Element:


In[123]:= ordf[edges[[2, 2]], edges, {7, 5}, {5, 8}]

Out[123]= True

In[124]:= ordf[edges[[2, 2]], edges, {1, 9}, {5, 8}]

Out[124]= True

In[162]:= fct[edges[[2, 2]], {7, 5}, {5, 8}]

Out[162]= True

In[125]:= fct[edges[[2, 2]], {1, 9}, {5, 8}]

Out[125]= False


fct[] ist nicht transitiv, ordf[] ist transitiv. Man sieht es in der Veranschaulichung fct-3-2.jpg


With[{ed = edges,
  pt = {3, 2}},
 MatrixPlot[Outer[fct[Part[ed, Sequence @@ pt], #1, #2] &, ed, ed, 1],
  ColorRules -> {False -> Pink, True -> Green},
  Frame -> True, Mesh -> True,
  FrameTicks -> {Transpose[{Range[Length[ed]], ed}],
    Transpose[{Range[Length[ed]], ed}]},
  FrameLabel -> {{None, "#2"}, {None, "#1"}},
  PlotLabel -> "Last = " <> ToString[Part[ed, Sequence @@ First[pt]]]
  ]
 ]

fct gibt nur bei direkten Vorgängern True. Die andere Veranschaulichung ist ordf-3-2.jpg

With[{ed = edges,
  pt = {3, 2}},
 MatrixPlot[
  Outer[ordf[Part[ed, Sequence @@ pt], ed, #1, #2] &, ed, ed, 1],
  ColorRules -> {False -> Pink, True -> Green},
  Frame -> True, Mesh -> True,
  FrameTicks -> {Transpose[{Range[Length[ed]], ed}],
    Transpose[{Range[Length[ed]], ed}]},
  FrameLabel -> {{None, "#2"}, {None, "#1"}},
  PlotLabel -> "Last = " <> ToString[Part[ed, Sequence @@ First[pt]]]
  ]
 ]

Das Element mit der durchgängig pinken Zeile (edges[[3,2]]={5,8}) ist das letzte Element, es darf vor keinem anderen Element stehen. Dagegen das Element mit einer durchgängig pinken Spalte ({8,2}) ist das erste Element: kein Element darf vor ihm stehen. Folglich muss die Zeile des Elements {8,2} bis auf den Diagonalwert grüne Kästchen enthalten, da {8,2} vor allen anderen Elementen stehen darf. Und die Spalte des letzten Elements {5,8} muss ebenso bis auf den Diagonalwert grüne Kästchen zeigen, da alle anderen Element vor {5,8} stehen dürfen.


Auf einer zufälligen Funktion zuf[] gibt SortBy[] immer noch etwas aus, das vom Input abweicht - Vorsicht (junk-in-junk-out):


In[160]:= SortBy[edges, Identity, zuf[edges[[3, 2]], #1, #2] &]

Out[160]= {{2, 4}, {8, 2}, {9, 7}, {7, 5}, {1, 9}, {4, 1}, {5, 8}}


die richtige Antwort wäre, edges auszugeben, aber irgendein Test war True ...


Fazit: mit einer Ordnungsrelation funktioniert SortBy[m, Identity, ordf], jedoch ist das prozedurale Vorgehen (ohne Vorauswahl eines letzten Elements) wesentlich effizienter, da es das Ergebnis direkt herstellt, solange man nicht bei ordf[] eine bessere Idee hat als die hier verwendete.



Grüsse

Udo.


Am 16.11.2019 um 09:47 schrieb Susanne & Udo Krause via demug:
Guten Morgen allertseits,

beim Wunschoutput auf edges, das topologisch einen Rand darstellt,

Clear[edges]
edges = {{2, 4}, {8, 2}, {5, 8}, {7, 5}, {9, 7}, {1, 9}, {4, 1}}


In[91]:= (* goal: sort so that r[[n-1,2]\[Equal]r[[n,1]] *)
chainIt[edges]

Out[91]= {{2, 4}, {4, 1}, {1, 9}, {9, 7}, {7, 5}, {5, 8}, {8, 2}}


stellt man mit der zunächst angewendeten Funktion fct0

(* okay with chainIt[], but it is procedural. Go with SortBy[], but make fct an ordering function *)
Clear[fct0, fct]
fct0[l1_List, l2_List] := If[l1[[2]] == l2[[1]], True, False]
fct[x_Integer, l1_List, l2_List] :=  If[(l1[[2]] == l2[[1]]) && (l1[[2]] != x), True, False]


fest, das fct0 keine Ordnungsrelation ist:

In[98]:= fct0[{2, 4}, {8, 2}]

Out[98]= False

{8,2} hat Anrecht, vor {2,4} eingeordnet zu werden. Und das ganze ordnet sich unendlich lange im Zyklus herum: es gibt kein letztes Element.


Deshalb verwendet man das geänderte fct[], welches ein letztes Element festsetzt


In[114]:= SortBy[edges, Identity, fct[edges[[-1, 2]], #1, #2] &]

Out[114]= {{5, 8}, {8, 2}, {2, 4}, {4, 1}, {1, 9}, {9, 7}, {7, 5}}


an der Stelle erwartete man {4,1} als letztes Element. Oder auch


In[115]:= SortBy[edges, Identity, fct[edges[[1, 2]], #1, #2] &]

Out[115]= {{4, 1}, {1, 9}, {9, 7}, {7, 5}, {5, 8}, {8, 2}, {2, 4}}


hier ist {2,4} als letztes Element angegeben.


Aber nun  ---- trara ---- in seiner unendlichen Weisheit funktioniert SortBy[] auf dieser Berandung auch ohne all das


In[116]:= SortBy[edges, Identity, fct0]

Out[116]= {{5, 8}, {8, 2}, {2, 4}, {4, 1}, {1, 9}, {9, 7}, {7, 5}}


wenn man Identity nutzt!



In[117]:= (* Identity not used *)
SortBy[edges, # &, fct0]

Out[117]= {{2, 4}, {4, 1}, {1, 9}, {9, 7}, {8, 2}, {7, 5}, {5, 8}}


Grüsse

Udo.




Am 10.11.2019 um 18:44 schrieb Susanne & Udo Krause via demug:
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 Deutschsprachiges Mathematica-Forum demug@XXXXXXX.ch
http://www.mathematica.ch/mailman/listinfo/demug
Archiv: http://www.mathematica.ch/archiv.html

Attachment: fct-3-2.jpg
Description: JPEG image

Attachment: ordf-3-2.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
Antworten:
Verweise:
Frühere   Chronologischer Index   Spätere
Vorherige   Thematischer Index   Nächste

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