Re: [Dmug] Infirmis proceduralis

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

Hallo allerseits,


ordf[] wird effizient, wenn man die angesehene Ordnung als Argument 
übergibt und innert ordf[] einen Indexvergleich (Less[]) verwenden kann.

Clear[edgs]
edgs[n_] := With[{r = Range[n], p1 = RandomPermutation[n], p2 = 
RandomPermutation[n]},
  DeleteCases[Transpose[{PermutationReplace[r, p1], 
PermutationReplace[r, p2]}], {x_Integer, x_Integer}]
  ]


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]] == r[[-1, 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 && (Complement @@ Transpose[l]) === {} &&
   Length[Union[Flatten[l]]] == Length[l] && FreeQ[Dot[{1, -1}, 
Transpose[l]], 0]


chainIt[last_List?VectorQ, l_List?MatrixQ] := Block[{cIt = chainIt[l]},
   RotateRight[cIt, Length[l] - Position[cIt, last][[1, 1]]]
   ] /; MemberQ[l, last] && (Complement @@ Transpose[l]) === {} &&
   Length[Union[Flatten[l]]] == Length[l] && FreeQ[Dot[{1, -1}, 
Transpose[l]], 0]


Clear[ordf]

(* ordf is only efficient if the ordered list is an argument to it. That 
goes for rather short finite lists. *)
ordf[ordl_List?MatrixQ, l1_List?VectorQ, l2_List?VectorQ] :=
 Block[{idx1, idx2},
   idx1 = Position[ordl, l1];
   idx2 = Position[ordl, l2];
   If[idx1 === {} || idx2 === {},
    False, (* else *)
    idx1[[1, 1]] < idx2[[1, 1]]
    ]
   ] /; Cases[Partition[ordl, 2, 1, -1], #[[1, 2]] != #[[2, 1]] &] === 
{} && Dimensions[{l1, l2}] == {2, 2}


In[67]:= ed60 = edgs[60]

Out[67]= {{50, 58}, {24, 17}, {35, 15}, {55, 34}, {51, 36}, {42,
  8}, {5, 37}, {7, 26}, {15, 59}, {56, 27}, {54, 20}, {26, 9}, {3,
  31}, {9, 44}, {32, 14}, {40, 38}, {37, 52}, {36, 5}, {27, 46}, {58,
  23}, {11, 33}, {49, 54}, {48, 1}, {53, 39}, {12, 51}, {29, 22}, {57,
   2}, {59, 43}, {46, 21}, {45, 28}, {21, 53}, {60, 56}, {14,
  18}, {31, 29}, {38, 50}, {13, 60}, {44, 48}, {47, 12}, {22, 42}, {8,
   24}, {52, 55}, {10, 16}, {30, 57}, {20, 30}, {41, 49}, {28,
  47}, {39, 11}, {2, 45}, {33, 10}, {16, 7}, {34, 13}, {1, 32}, {23,
  25}, {25, 3}, {18, 40}, {17, 41}, {43, 35}}

In[75]:= ed60[[31]]

Out[75]= {21, 53}

In[77]:= chainIt[ed60[[31]], ed60] == SortBy[ed60, Identity, 
ordf[chainIt[ed60[[31]], ed60], #1, #2] &]

Out[77]= True


ein Fall, in dem der Vorteil der funktionalen Schreibweise wg. der 
Eigenheiten einer Ordnungsfunktion nicht ins Auge fällt. Man kann nun 
dieselben Bildchen fertigen, nur grösser;


With[{ed = ed60,
  edo = chainIt[ed60[[31]], ed60]},
 MatrixPlot[Outer[ordf[edo, #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[Last[edo]]
  ]
 ]


gibt ordg-21-51.jpg und


With[{ed = Transpose[ed60][[1]],
  edo = Sort[Transpose[ed60][[1]]]},
 MatrixPlot[Outer[Less, 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[Last[edo]]
  ]
 ]


gibt less-60.jpg, die Ordnungsfunktion Less[] auf einem gemischten 
Range[60]. Beide Matrizen sind miteinander äquivalent.


Grüsse

Udo.



Am 17.11.2019 um 14:21 schrieb Susanne & Udo Krause:
> 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]
>
> 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.

ordf-21-53.jpg
Description: JPEG image

less-60.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