# How to remove sublists with two consecutive identical digits?

Given a number 444123. The permutations of its digits are, for example,

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


I want to remove any permutations with consecutively repeated 4. So the filtered sublist must become

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


as {4,4,4,3,2,1} that contains 4,4,4 and {4,1,2,4,4,3} that contains 4,4 are removed.

# Attempt

DeleteCases[Permutations[IntegerDigits@444123], 4..]


But it produces unfiltered output.

DeleteCases[{___, 4, 4, ___}]@Permutations[IntegerDigits@444123]

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

• Thank you very much. Is it possible to use ..? Commented Sep 1, 2020 at 19:17
• @WissenMachtFrei, you can use DeleteCases[{___, 4, 4 .. , ___}] or DeleteCases[{___, Repeated[4, {2, Infinity}], ___}]
– kglr
Commented Sep 1, 2020 at 19:20

We can also fill the gap of 1,2,3 by using 4.( here we replace 1,2,3 by a,b,c and replace 4 by x)

original = Permutations[{a, b, c}]
gapPositions = Subsets[{{1}, {2}, {3}, {4}}, {3}]
Flatten[Outer[Insert[#1, x, #2] &, original, gapPositions, 1], 1]


{{x, a, x, b, x, c}, {x, a, x, b, c, x}, {x, a, b, x, c, x}, {a, x, b,
x, c, x}, {x, a, x, c, x, b}, {x, a, x, c, b, x}, {x, a, c, x, b,
x}, {a, x, c, x, b, x}, {x, b, x, a, x, c}, {x, b, x, a, c, x}, {x,
b, a, x, c, x}, {b, x, a, x, c, x}, {x, b, x, c, x, a}, {x, b, x, c,
a, x}, {x, b, c, x, a, x}, {b, x, c, x, a, x}, {x, c, x, a, x,
b}, {x, c, x, a, b, x}, {x, c, a, x, b, x}, {c, x, a, x, b, x}, {x,
c, x, b, x, a}, {x, c, x, b, a, x}, {x, c, b, x, a, x}, {c, x, b, x,
a, x}}


Using Sequence.. functionality:

plist = Permutations@IntegerDigits@444123;

Extract[plist,
SequenceCases[#, {4, 4}] & /@ plist  // Position[#, {}] &]

Pick[plist, SequenceCount[#, {4, 4}] & /@ plist, 0]

SequenceReplace[#, {4, 4} :> Nothing] & /@ plist //
Select[Length@# == 6 &]


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

First of all, Repeated matches one or more. Then you want to match lists, so

DeleteCases[Permutations[IntegerDigits@444123], {___, 4, 4 .., ___}]

Permutations[IntegerDigits@444123]//Pick[#,Length@Split[#,#1==#2==4&]&/@#,6]&


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

Using ReplaceAll

list = Permutations @ IntegerDigits @ 444123;

list /. {___, 4, 4, ___} :> Nothing


gives

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


Using Pick:

list = Permutations[IntegerDigits@444123];

Pick[#, AllTrue[SplitBy[#, Repeated], DuplicateFreeQ[#] &] & /@ #] &@list

(*{{4, 1, 4, 2, 4, 3}, {4, 1, 4, 2, 3, 4}, {4, 1, 4, 3, 4, 2},
{4, 1, 4, 3, 2, 4}, {4, 1, 2, 4, 3, 4}, {4, 1, 3, 4, 2, 4},
{4, 2, 4, 1, 4, 3}, {4, 2, 4, 1, 3, 4}, {4, 2, 4, 3, 4, 1},
{4, 2, 4, 3, 1, 4}, {4, 2, 1, 4, 3, 4}, {4, 2, 3, 4, 1, 4},
{4, 3, 4, 1, 4, 2}, {4, 3, 4, 1, 2, 4}, {4, 3, 4, 2, 4, 1},
{4, 3, 4, 2, 1, 4}, {4, 3, 1, 4, 2, 4}, {4, 3, 2, 4, 1, 4},
{1, 4, 2, 4, 3, 4}, {1, 4, 3, 4, 2, 4}, {2, 4, 1, 4, 3, 4},
{2, 4, 3, 4, 1, 4}, {3, 4, 1, 4, 2, 4}, {3, 4, 2, 4, 1, 4}}*)


Another option, although slow, is to use Select and SequenceCases:

Select[list, SequenceCases[#, {___, a_, a_, ___}] == {} &]

(*{{4, 1, 4, 2, 4, 3}, {4, 1, 4, 2, 3, 4}, {4, 1, 4, 3, 4, 2},
{4, 1, 4, 3, 2, 4}, {4, 1, 2, 4, 3, 4}, {4, 1, 3, 4, 2, 4},
{4, 2, 4, 1, 4, 3}, {4, 2, 4, 1, 3, 4}, {4, 2, 4, 3, 4, 1},
{4, 2, 4, 3, 1, 4}, {4, 2, 1, 4, 3, 4}, {4, 2, 3, 4, 1, 4},
{4, 3, 4, 1, 4, 2}, {4, 3, 4, 1, 2, 4}, {4, 3, 4, 2, 4, 1},
{4, 3, 4, 2, 1, 4}, {4, 3, 1, 4, 2, 4}, {4, 3, 2, 4, 1, 4},
{1, 4, 2, 4, 3, 4}, {1, 4, 3, 4, 2, 4}, {2, 4, 1, 4, 3, 4},
{2, 4, 3, 4, 1, 4}, {3, 4, 1, 4, 2, 4}, {3, 4, 2, 4, 1, 4}}*)