Re: [Dmug] Infirmis proceduralis

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

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

fct-3-2.jpg
Description: JPEG image

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