# How to divide a list into several single loops

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}}*)


## 2 Answers

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}}

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}} *)

• I am sure this could be simpler! Commented Aug 6, 2020 at 1:40