# Delete elements from a list with consecutive elements in sublist

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.

• i mean in a loop it is pretty straightforward but I was hoping to avoid loops given the huge number of options in mathematica Feb 23, 2017 at 9:03
• DeleteCases[lst, {___, x_, x_, ___}] where lst is your target list.
– ciao
Feb 23, 2017 at 9:06
• @ciao Why not make an answer of it? The key is to explain in detail for newbies how {__, x, x_, ___} works. Feb 23, 2017 at 9:53
• so does {____,x_,x_,___} work for arrays of arbitrary length ?? Feb 23, 2017 at 10:11
• @AbhishekPal Yes it does. ___ is BlankNullSequence so this will work for a List of any length. Feb 23, 2017 at 10:33

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.

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

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


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

• @Mr.Wizard, of course! (Still on Version 9, I had thought about FreeQ[#,0]& /@.. first but settled on PossibleZeroQ. The operator form FreeQ is much cleaner.
– kglr
Feb 23, 2017 at 21:42
• Glad I could help! :-D Feb 23, 2017 at 21:52
• Caveat with Differences: {a, b, ∞, ∞} Feb 23, 2017 at 21:58

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

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


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