Delete elements from a list with consecutive elements in sublist

Question

I do not know if this is question has already been asked but I did see some posts on deleting duplicate elements but I am unable to understand completely. So forgive me if this turns out to be duplicate.

I have a list of the form {{a,b,a,b},{b,a,b,a},{a,a,b,b},{b,b,a,a},{a,b,b,a},{b,a,a,b}}. I need to eliminate sublist which have same consecutive elements.

Example I should eliminate {a,a,b,b}, {b,b,a,a}, {a,b,b,a} and {b,a,a,b} and thus end up with only alternating as and bs.

Any suggestions will be appreciated. Thanks in advance.

Answer 1

As ciao commented you can use the pattern {___, x_, x_, ___}. This works because x_ is a named pattern and therefore within a pattern expression any match must match every other pattern with the same name. One could also use {___, Repeated[x_, {2}], ___} for the same reason.

dat = 
  {{a, b, a, b}, {b, a, b, a}, {a, a, b, b}, {b, b, a, a}, {a, b, b, a}, {b, a, a, b}};

dat // DeleteCases[{___, x_, x_, ___}]

dat /. {___, x_, x_, ___} -> Sequence[]

dat // Cases[Except[{___, x_, x_, ___}]]

dat // DeleteCases[{___, Repeated[x_, {2}], ___}]

{{a, b, a, b}, {b, a, b, a}}     (* same output for each *)

Above I use the new-in-v10 operator forms of Cases and DeleteCases.

Reference: Pattern, Blank, BlankNullSequence, Repeated, Except

Other posts I could find where the uniqueness of named patterns is used or mentioned:

• Pattern to match a non-empty list of non-empty lists
• How to Derive Tuples Without Replacement
• Classifying poker hands by pattern matching
• Using MatchQ (or other means) to parse an expression using sums of COS or SIN correctly
• How to get complement of a pattern
• Making a flag with six vertical stripes

---

Because I always like to see another way to accomplish the same task here is a method without any patterns. I use Throw and Catch to exist Fold early.

test[a_] := Catch[Fold[If[# === #2, Throw[False], #2] &, a]; True]

Select[dat, test]

{{a, b, a, b}, {b, a, b, a}}

Answer 2

Also

lst = {{a, b, a, b}, {b, a, b, a}, {a, a, b, b}, {b, b, a, a}, {a, b, b, a}, {b, a, a, b}};

Pick[#, PossibleZeroQ /@ Times @@@ Differences /@ #, False] & @ lst
Pick[#, FreeQ[0|0.] /@ Differences /@ #] & @ lst  (*thanks: Mr.W *)
Pick[#, SequenceCount[#, {Repeated[x_, {2, Infinity}]}]==0&/@#]& @ lst

all give

{{a, b, a, b}, {b, a, b, a}}

Answer 3

With V 13.1 came DeleteAdjacentDuplicates

list = {{a, b, a, b}, {b, a, b, a}, {a, a, b, b}, {b, b, a, a}, {a, b, b, a}, {b, a, a, b}};

Select[DeleteAdjacentDuplicates /@ list, Length[#] == 4 &]

{{a, b, a, b}, {b, a, b, a}}

Answer 4

Another way using Select and ConsecutiveQ:

ConsecutiveQ = Most[#] == Rest[#] - 1 &; (*By Kuba*)

lst = {{a, b, a, b}, {b, a, b, a}, {a, a, b, b}, {b, b, a, a}, {a, b, b, a}, {b, a, a, b}};

Select[lst, AllTrue[Partition[Ordering[#], 2], Not@*ConsecutiveQ] &]

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

Or using SubsetCases:

f = SubsetCases[#, {{___, x__, x__, ___}} :> 
    If[Length@{x, x} != Last@Dimensions@#, Nothing, {x, x}]] &;

f@lst

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

Answer 5

Using Split:

Clear["Global`*"];
lst = {{a, b, a, b}, {b, a, b, a}, {a, a, b, b}, {b, b, a, a}, {a, b, 
    b, a}, {b, a, a, b}};

Pick[lst, 
 lst // Map[Split[#, SameQ] &] // Map[Length, #, {2}] & // 
  Map[ContainsOnly[{1}]]
 ]

Using SequenceReplace:

SequenceReplace[lst, {{___, a_, a_, ___} } :> Nothing]

---

Result

{{a, b, a, b}, {b, a, b, a}}