Delete from list

Question

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' ?

Answer 1

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

Answer 2

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:

PadLeft[Subsets[{b, c, d}], Automatic, a]
(* 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}}

Answer 3

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

Answer 4

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

(* adopting Wizard's approach *)
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}}*)

Answer 5

Here is an alternative way to do it..

lst = Sort /@ Permutations[{b, c, d}, 3] // DeleteDuplicates
PadLeft[#, 3, a] & /@ lst

Answer 6

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

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

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

Out[2]= {{a, a, a}, {a, a, b}, {a, a, c}, {a, a, d}, {a, b, c}, {a, b,
   d}, {a, c, d}, {b, c, d}}

Answer 7

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

Answer 8

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

Through[{Count[a], Count[b], Count[c], Count[d]}[#]] & /@ list // 
  Position[#, {_, 0 | 1, 0 | 1, 0 | 1}, 1, Heads -> False] & // 
 Extract[list, #] &

---

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

Answer 9

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

Using Fold

f[x_, y_] := Pick[x, LessThan[2] @* Count[y] /@ x]

Fold[f, list, {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}}