How to match a cyclically repeating sequence?

Question

I have run across several times recently where I must match a sequence that is cyclically repeating. For example, with the sequence,

Sequence[a, b, c]

how would I write a pattern that matched against

a
a, b
a, b, c
a, b, c, a

etc., but not any of the surrounding elements?

For a two element sequence comprising the entire list, this is straightforward, if a bit verbose:

MatchQ[#, {a | PatternSequence[a, b] .., a | PatternSequence[]}] & /@ 
 {{a}, {a, b}, {a, b, a}, {a, b, a, b, a, b, a}}
(* {True, True, True, True} *)

But, this does not work when the sequence is part of a bigger list, e.g.

Cases[
 {q, r, a, b, a, b, a, s, e, f, a}, 
 x : PatternSequence[a|(PatternSequence[a, b] ..), a | PatternSequence[]] :> {x}, 
 Infinity
]
(* {{a}, {a}, {a}, {a}} *)

Even reversing the initial element to (PatternSequence[a, b] ..)|a returns the same thing.

So, my questions are:

1. How can I write the pattern so it extracts parts of larger lists that may contain other elements?

2. How can I generalize the pattern to match against larger cyclically repeating sequences?

Answer 1

A very interesting question. I thought of a much plainer approach than the other responders but it proves to perform quite well. I simply PadRight the reference sequence to match the length of the test sequence.

Update: limited extension to patterns within ref and timings updated for version 10.1.0.

Functions

cycQ[ref_][test_] := test ~MatchQ~ PadRight[ref, Length @ test, ref]

cycpat[f_, r___] := p : PatternSequence[f, ___] /; cycQ[{f, r}][{p}] // Identity

cycQ tests one sequence against another:

cycQ[{1, 2, 3}] /@ {{}, {1}, {1, 2, 3}, {1, 2, 3, 1}, {2, 3}}

{True, True, True, True, False}

cycpat is the pattern-building function:

cycpat[1, 2, 3]

p$ : PatternSequence[1, ___] /; cycQ[{1, 2, 3}][{p$}]

Sample applications

Sample data:

SeedRandom[1]
test = RandomInteger[{1, 3}, 20]

{2, 1, 2, 2, 1, 1, 1, 2, 1, 1, 1, 1, 3, 1, 2, 3, 1, 1, 2, 2}

Finding the single longest sequence in the list:

test /. {___, x : Longest @ cycpat[1, 2, 3], ___} :> {x}

{1, 2, 3, 1}

Finding all sequence fragments in a list, length 2 or greater:

ReplaceList[test, {___, x : cycpat[1, 2, 3] /; Length[{x}] > 1, ___} :> {x}]

{{1, 2}, {1, 2}, {1, 2}, {1, 2, 3}, {1, 2, 3, 1}, {1, 2}}

Performance

rm -rf's cyclicPatternMatchQ, while certainly interesting, isn't fast enough to be widely applicable:

SeedRandom[1]
a = RandomInteger[{1, 5}, 300];

a /. {___, x : Longest@cycpat[1, 2, 3, 4, 5], ___} :> {x} // Timing

a /. {___, Longest@m__, ___} /; 
    cyclicPatternMatchQ[{1, 2, 3, 4, 5}][{m}] :> {m}      // Timing

{0.145, {1, 2, 3, 4}}

{6.16204, {1, 2, 3, 4}}

belisarius's form function is much faster but still not as fast as cycpat:

form[w_List] := (* Note I removed the x and y patterns *)
 PatternSequence[Longest@Repeated[PatternSequence @@ w, {0, Infinity}], 
  Alternatives @@ 
    Table[Longest@Repeated[PatternSequence @@ w[[;; i]], {0, 1}], {i, Length[w], 1, -1}]]

SeedRandom[10]
big = RandomInteger[{1, 5}, 1200];

big /. {___, q : Longest @ cycpat[1, 2, 3, 4, 5], ___} :> {q}  // Timing
big /. {___, q : Longest @ form @ {1, 2, 3, 4, 5}, ___} :> {q} // Timing

{6.18, {1, 2, 3, 4, 5, 1}}

{10.80, {1, 2, 3, 4, 5, 1}}

It is worth noting however that (use of) form slows down semi-proportionately to the length of the sequence it is given, while cycpat does not:

big /. {___, q : Longest[cycpat @@ Range[50]], ___} :> {q} // Timing
big /. {___, q : Longest @ form @ Range[50], ___} :> {q}   // Timing

{6.282, {1, 2, 3, 4, 5}}

{63.586, {1, 2, 3, 4, 5}}

cycpat still seems rather slow for a list of only 1200 elements but I was unable to improve its performance. Possibly a form of memoization would speed the highly repetitive application of cycQ without unacceptable memory consumption.

Answer 2

Here is a reasonable first implementation of a cyclical pattern matcher that behaves as described in the question. It takes an input cyclic list (single cycle) and a list that is to be tested:

ClearAll@cyclicPatternMatchQ
cyclicPatternMatchQ[cycList_][testList_] := MatchQ[cycList, 
    testList /. {Shortest[h___], (PatternSequence @@ cycList) ... , 
        Shortest[t___]} :> {h, t, ___}]

Here is a sample test case with results:

{#, cyclicPatternMatchQ[{a, b, c}]@#} & /@ {{a}, {a, b}, {a, b, 
    c}, {a, b, c, a}, {a, b, c, a, b}, {x, y, z, p, q}, {d, a, b, c, 
    d}, {a, b, c, d, a}, {a, b, d, c}} // Grid

You can combine this with regular patterns to match cyclical patterns inside another list:

{d, a, b, c, a, e, f} /. 
    {h___, Longest@m__, t___} /; cyclicPatternMatchQ[{a, b, c}][{m}] :> {h, t}
(* {d, e, f} *)

Answer 3

findCyclicMatches[u_List, cycle_List] := Module[{form, x, y},
  form[w_List] := 
   PatternSequence[
    x : Longest@Repeated[PatternSequence @@ w, {0, Infinity}], 
    y : Alternatives @@ 
      Table[Longest@Repeated[PatternSequence @@ w[[;; i]], {0, 1}], {i, Length[w], 1, -1}]];

  Last@Reap@ NestWhileList[First@Cases[{#}, {r___, Longest@form@cycle, s___} :>
                                                    (Sow@{x, y}; {r, "Separator", s})] &, 
     u, 
    (Length@Last@{##} <= Length[{##}[[-2]]]) &, 2]
  ]
u = {a, b, c, kk, a, b, c, k, a, b, c, a, b, k, a, b, c, a};
findCyclicMatches[u, {a, b, c}]

(*
 {{{a, b, c, a, b}, {a, b, c, a}, {a, b, c}, {a, b, c}, {}}}
*)