Skip to main content
some additional explanations
Source Link
polfosol
  • 952
  • 6
  • 21

I did a benchmark to compare my own (improved) method with the ones proposed by kglr and Carl Woll. My initial thought was to treat this problem in a procedural, old-fashioned way. Here is the code:

Edited later: Using some simple tricks, I managed to double-up the speed. These lines are from the last edition:

ClearAll["Global`*"];
merge = Which[AnyTrue[#,Which[# Length@#== <{} 2|| &]#2 == {}, #0,
    #[[1, -1]]Last@# == #[[2, 1]]#2[[1]], {#[[1]]~Join~Rest@#[[2]], {}, #~Join~Rest@#2},
    #[[1, 1]]#[[1]] == #[[2, -1]]Last@#2, {{}, #[[2]]~Join~Rest@#[[1]]#2~Join~Rest@#},
    True, #]0] &;

pathsFind[li_List] := Module[{a = li, q},
   Do[
   Do[a[[ Do[If[ListQ[q = merge @@ a[[{i, j}]] =]]], merge@a[[a[[{i, j}]] = q],
     {j, 2, Length@a}, {i, 1, j - 1}];
    If[FreeQ[a, {}], Break[], a = a~DeleteCases~{}],
    Length@a];
  a] a];

Nothing fancy. It just loops through the elements multiple times until all paths are found. This code compares allPaths by kglr, findPaths by Carl Woll and pathsFind:

Module[{li, p, rand},
 li = DeleteCases[{a_, a_}]@DeleteDuplicatesBy[Sort]@RandomInteger[1000, {500, 2}];
 First /@ {
   RepeatedTiming[p = findPaths@li;],
   {Length@p},
   RepeatedTiming[p = allPaths@li;],
   {Length@p},
   RepeatedTiming[p = pathsFind@li;],
   {Length@p}
   }]

The result is {0.417195298115, 372362, 0.01315870115792, 372362, 10.68831907272, 346332}. Obviously, allPaths is faster by some ordersan order of magnitude. But it seems both faster methods are not so accurate and miss some paths along the way, since the number of groups in the last method is less than the other two. Regarding kglr's comment, I still think lower number of groups means higher accuracy and can't understand what is wrong with my code aside from being slow.

By the way, thanks toI appreciate all the efforts and nice ideas and efforts proposed here., but I think I shouldit's better to stick to my own method for now.

I did a benchmark to compare my own (improved) method with the ones proposed by kglr and Carl Woll. My initial thought was to treat this problem in a procedural, old-fashioned way. Here is the code:

ClearAll["Global`*"];
merge = Which[AnyTrue[#, Length@# < 2 &], #,
    #[[1, -1]] == #[[2, 1]], {#[[1]]~Join~Rest@#[[2]], {}},
    #[[1, 1]] == #[[2, -1]], {{}, #[[2]]~Join~Rest@#[[1]]},
    True, #] &;

pathsFind[li_List] := Module[{a = li},
  Do[
   Do[a[[{i, j}]] = merge@a[[{i, j}]], {j, 2, Length@a}, {i, 1, j - 1}];
   If[FreeQ[a, {}], Break[], a = a~DeleteCases~{}],
   Length@a];
  a]

Nothing fancy. It just loops through the elements multiple times until all paths are found. This code compares allPaths by kglr, findPaths by Carl Woll and pathsFind:

Module[{li, p, rand},
 li = DeleteCases[{a_, a_}]@DeleteDuplicatesBy[Sort]@RandomInteger[1000, {500, 2}];
 First /@ {
   RepeatedTiming[p = findPaths@li;],
   {Length@p},
   RepeatedTiming[p = allPaths@li;],
   {Length@p},
   RepeatedTiming[p = pathsFind@li;],
   {Length@p}
   }]

The result is {0.417195, 372, 0.0131587, 372, 1.68831, 346}. Obviously, allPaths is faster by some orders of magnitude. But it seems both faster methods are not so accurate and miss some paths along the way, since the number of groups in the last method is less than the other two.

By the way, thanks to all the nice ideas and efforts proposed here. I think I should better stick to my method for now.

I did a benchmark to compare my own (improved) method with the ones proposed by kglr and Carl Woll. My initial thought was to treat this problem in a procedural, old-fashioned way. Here is the code:

Edited later: Using some simple tricks, I managed to double-up the speed. These lines are from the last edition:

ClearAll["Global`*"];
merge = Which[# == {} || #2 == {}, 0,
    Last@# == #2[[1]], {{}, #~Join~Rest@#2},
    #[[1]] == Last@#2, {{}, #2~Join~Rest@#},
    True, 0] &;

pathsFind[li_List] := Module[{a = li, q},
   Do[
    Do[If[ListQ[q = merge @@ a[[{i, j}]]], a[[{i, j}]] = q],
     {j, 2, Length@a}, {i, 1, j - 1}];
    If[FreeQ[a, {}], Break[], a = a~DeleteCases~{}],
    Length@a];
   a];

Nothing fancy. It just loops through the elements multiple times until all paths are found. This code compares allPaths by kglr, findPaths by Carl Woll and pathsFind:

Module[{li, p, rand},
 li = DeleteCases[{a_, a_}]@DeleteDuplicatesBy[Sort]@RandomInteger[1000, {500, 2}];
 First /@ {
   RepeatedTiming[p = findPaths@li;],
   {Length@p},
   RepeatedTiming[p = allPaths@li;],
   {Length@p},
   RepeatedTiming[p = pathsFind@li;],
   {Length@p}
   }]

The result is {0.298115, 362, 0.0115792, 362, 0.907272, 332}. Obviously, allPaths is faster by an order of magnitude. But it seems both faster methods are not so accurate and miss some paths along the way, since the number of groups in the last method is less than the other two. Regarding kglr's comment, I still think lower number of groups means higher accuracy and can't understand what is wrong with my code aside from being slow.

By the way, I appreciate all the efforts and nice ideas proposed here, but I think it's better to stick to my own method for now.

Source Link
polfosol
  • 952
  • 6
  • 21

I did a benchmark to compare my own (improved) method with the ones proposed by kglr and Carl Woll. My initial thought was to treat this problem in a procedural, old-fashioned way. Here is the code:

ClearAll["Global`*"];
merge = Which[AnyTrue[#, Length@# < 2 &], #,
    #[[1, -1]] == #[[2, 1]], {#[[1]]~Join~Rest@#[[2]], {}},
    #[[1, 1]] == #[[2, -1]], {{}, #[[2]]~Join~Rest@#[[1]]},
    True, #] &;

pathsFind[li_List] := Module[{a = li},
  Do[
   Do[a[[{i, j}]] = merge@a[[{i, j}]], {j, 2, Length@a}, {i, 1, j - 1}];
   If[FreeQ[a, {}], Break[], a = a~DeleteCases~{}],
   Length@a];
  a]

Nothing fancy. It just loops through the elements multiple times until all paths are found. This code compares allPaths by kglr, findPaths by Carl Woll and pathsFind:

Module[{li, p, rand},
 li = DeleteCases[{a_, a_}]@DeleteDuplicatesBy[Sort]@RandomInteger[1000, {500, 2}];
 First /@ {
   RepeatedTiming[p = findPaths@li;],
   {Length@p},
   RepeatedTiming[p = allPaths@li;],
   {Length@p},
   RepeatedTiming[p = pathsFind@li;],
   {Length@p}
   }]

The result is {0.417195, 372, 0.0131587, 372, 1.68831, 346}. Obviously, allPaths is faster by some orders of magnitude. But it seems both faster methods are not so accurate and miss some paths along the way, since the number of groups in the last method is less than the other two.

By the way, thanks to all the nice ideas and efforts proposed here. I think I should better stick to my method for now.