Como remover sublistas com 2 dígitos idênticos consecutivos?

Sep 02 2020

Dado um número 444123. As permutações de seus dígitos são, por exemplo,

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

Eu quero remover quaisquer permutações com 2 (ou mais) repetidos 4 dígitos. Para o exemplo acima, a sublista esquerda deve ser

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

Tentar

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

Mas produz saída não filtrada.

Respostas

3 kglr Sep 02 2020 at 02:16
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}}
4 cvgmt Sep 02 2020 at 09:08

Também podemos preencher a lacuna de 1,2,3 usando 4.(aqui substituímos 1,2,3 por a,b,c e 4 por 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}}
3 Natas Sep 02 2020 at 02:17

Em primeiro lugar, Repeatedcorresponde a um ou mais. Então você quer combinar listas, então

DeleteCases[Permutations[IntegerDigits@444123], {___, 4, 4 .., ___}]
1 user1066 Sep 02 2020 at 23:14
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}}