4
$\begingroup$

Because of some problems, I need to divide the permutation represented by a list into several single loop lists.

For example, for list {4, 3, 2, 1, 7, 6, 5}, it can be divided into two single loops {4, 3, 2, 1} and { 7, 6, 5}, where {4, 3, 2, 1} and { 7, 6, 5} are continuous single loops (the single cycle in the positive direction and the single cycle in the opposite direction all meet the requirements).

PermutationCycles[{4, 3, 2, 1, 7, 6, 5}]

But the results of the above code do not meet the requirements, what should I do to achieve this requirement delicately?

Other examples for testing:

{3, 2, 1, 7, 6, 4, 5}
(*{{3,2,1},{7,6},{4,5}}*)
$\endgroup$

2 Answers 2

5
$\begingroup$
ClearAll[consecutiveRuns]

rule = a : {__} /; MatchQ[{1 ..} | {-1 ..}] @ Differences[a] :> a;

consecutiveRuns = SequenceSplit[#, rule] &;

Examples:

consecutiveRuns @ {4, 3, 2, 1, 7, 6, 5}
{{4, 3, 2, 1}, {7, 6, 5}}
consecutiveRuns @ {3, 2, 1, 7, 6, 4, 5}
{{3, 2, 1}, {7, 6}, {4, 5}}

For the example in flinty's answer:

consecutiveRuns @ {1, 2, 3, 4, 5, 2, 3, 0, 2, 1, 3, 1, 2, 3, 4, 3, 2, 1}
{{1, 2, 3, 4, 5}, {2, 3}, {0}, {2, 1}, {3}, {1, 2, 3, 4}, {3, 2, 1}}
$\endgroup$
3
$\begingroup$
updownruns[list_] := 
 Module[{s1 = Split[list, Abs[#1 - #2] == 1 &]}, 
  Reap[Do[If[SameQ @@ Differences[s], Sow[s], 
      Sow /@ TakeDrop[s, 1 + Length[First@Split@Differences@s]]
      ], {s, s1}]][[2, 1]]]

This handles cases like this:

updownruns[{3, 2, 1, 7, 6, 4, 5}]
(* result: {{3, 2, 1}, {7, 6}, {4, 5}} *)

But also cases like this:

updownruns[{1, 2, 3, 4, 5, 2, 3, 0, 2, 1, 3, 1, 2, 3, 4, 3, 2, 1}]
(* result {{1, 2, 3, 4, 5}, {2, 3}, {0}, {2, 1}, {3}, {1, 2, 3, 4}, {3, 2, 1}} *)
$\endgroup$
1
  • $\begingroup$ I am sure this could be simpler! $\endgroup$
    – flinty
    Commented Aug 6, 2020 at 1:40

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.