Delete from list

I have this command that prints all combination without repetition:

Grid[DeleteDuplicates[Map[Sort, Tuples[{a, b, c, d}, 3]]]]

As a matter of fact the output is:

a   a   a
a   a   b
a   a   c
a   a   d
a   b   b
a   b   c
a   b   d
a   c   c
a   c   d
a   d   d
b   b   b
b   b   c
b   b   d
b   c   c
b   c   d
b   d   d
c   c   c
c   c   d
c   d   d
d   d   d

How can I delete the vectors wich have two o more 'b','c','d' ?

• If you want to construct all orderless lists of length 3 from {a,b,c,d}, where any of b,c,d appear maximum once, there can be a simpler solution. E. g. Map[PadLeft[#, 3, a]&, Subsets[{b, c, d}]] Apr 22 '17 at 11:04
• Just for fun: DeleteDuplicates@Subsets[Join[ConstantArray[a, 3], {b, c, d}], {3}] == Select[Permutations[Join[ConstantArray[a, 3], {b, c, d}], {3}], OrderedQ] == Map[PadLeft[#, 3, a] &, Subsets[{b, c, d}]] Apr 22 '17 at 18:59

How can I delete the vectors wich have two or more 'b','c','d' ?

(lst = DeleteDuplicates[Map[Sort, Tuples[{a, b, c, d}, 3]]]) // Grid Create the pattern to delete

tst=Flatten[Permutations[{#,#,_},{3}]&/@{b,c,d},1] Delete them. I do not know now how to map/reset DeleteCases, so used a Do

Do[lst= DeleteCases[lst,tst[[n]]],{n,1,Length@tst}]
lst // Grid Here is a fairly clean approach. By naming the pattern b | c | d (| is the short form of Alternatives) we force a match for the same letter each time.

m = DeleteDuplicates[Map[Sort, Tuples[{a, b, c, d}, 3]]];

m2 = DeleteCases[m, {___, x : b|c|d, x_, ___}]

m2 // Grid

$\begin{array}{ccc} a & a & a \\ a & a & b \\ a & a & c \\ a & a & d \\ a & b & c \\ a & b & d \\ a & c & d \\ b & c & d \\ \end{array}$

• @Wizard +1 for the nice approach. I adapted yours for the OrderlessPatternSequence Apr 22 '17 at 13:45
Pick[lst, Max[Function[{x}, Count[#, x]] /@ {b, c, d}] <= 1 & /@ lst] // Grid Update: A variation on @Shadowray's suggestion to construct the desired list directly:

(* or PadLeft[Subsets[{b, c, d}]] /. 0 -> a *)

{{a, a, a}, {a, a, b}, {a, a, c}, {a, a, d}, {a, b, c}, {a, b, d}, {a, c, d},{b, c, d}}

Update 2: Also

DeleteDuplicates@Subsets[{a, a, a, b, c, d}, {3}]

{{a, a, a}, {a, a, b}, {a, a, c}, {a, a, d}, {a, b, c}, {a, b, d}, {a, c, d},{b, c, d}}

• +1 for the automatic creation of the list Apr 22 '17 at 13:44
m = DeleteDuplicates[Map[Sort, Tuples[{a, b, c, d}, 3]]];

DeleteCases[m, {Alternatives@@Function[x, OrderlessPatternSequence[_, x, x],
Listable], {b, c, d}]}]

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

DeleteCases[m, {OrderlessPatternSequence[x : b | c | d, x_, _] }]
(*{{a, a, a}, {a, a, b}, {a, a, c}, {a, a, d}, {a, b, c}, {a, b, d}, {a,c,d}, {b, c, d}}*)

Here is an alternative way to do it..

lst = Sort /@ Permutations[{b, c, d}, 3] // DeleteDuplicates
PadLeft[#, 3, a] & /@ lst
• I realize my solution is similar to @shadowray but his solution is more clean than mine.. Apr 22 '17 at 14:00

And yet another method. Delete the a's from each sublist, and then check to see if Union will remove anything else:

In:= list = DeleteDuplicates[Map[Sort, Tuples[{a, b, c, d}, 3]]];

In:= Select[list,
Length[Union[DeleteCases[#, a]]] == Length[DeleteCases[#, a]] &]

Out= {{a, a, a}, {a, a, b}, {a, a, c}, {a, a, d}, {a, b, c}, {a, b,
d}, {a, c, d}, {b, c, d}}

In:

MapThread[Join, {Subsets[{a, a, a}] // Reverse, Subsets[{b, c, d}]}]

Out:

{{a, a, a}, {a, a, b}, {a, a, c}, {a, a, d}, {a, b, c}, {a, b, d}, {a,
c, d}, {b, c, d}}