3
$\begingroup$

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.

$\endgroup$

7 Answers 7

7
$\begingroup$
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}}
$\endgroup$
2
  • $\begingroup$ Thank you very much. Is it possible to use ..? $\endgroup$ Commented Sep 1, 2020 at 19:17
  • $\begingroup$ @WissenMachtFrei, you can use DeleteCases[{___, 4, 4 .. , ___}] or DeleteCases[{___, Repeated[4, {2, Infinity}], ___}] $\endgroup$
    – kglr
    Commented Sep 1, 2020 at 19:20
6
$\begingroup$

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}}
$\endgroup$
5
$\begingroup$

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

$\endgroup$
4
$\begingroup$

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

DeleteCases[Permutations[IntegerDigits@444123], {___, 4, 4 .., ___}]
$\endgroup$
4
$\begingroup$
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}}

$\endgroup$
4
$\begingroup$

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}}
$\endgroup$
4
$\begingroup$

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}}*)
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.