9
$\begingroup$

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

Improve this question
$\endgroup$
1
  • 2
    $\begingroup$ 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}]] $\endgroup$
    – Ray Shadow
    Commented Apr 22, 2017 at 11:04

9 Answers 9

Reset to default
8
$\begingroup$

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

Mathematica graphics

Create the pattern to delete

 tst=Flatten[Permutations[{#,#,_},{3}]&/@{b,c,d},1]

Mathematica graphics

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

Mathematica graphics

Improve this answer
$\endgroup$
0
6
$\begingroup$ 
Pick[lst, Max[Function[{x}, Count[#, x]] /@ {b, c, d}] <= 1 & /@ lst] // Grid

Mathematica graphics

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

Improve this answer
$\endgroup$
1
  • $\begingroup$ +1 for the automatic creation of the list $\endgroup$
    – Ali Hashmi
    Commented Apr 22, 2017 at 13:44
5
$\begingroup$

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

Improve this answer
$\endgroup$
1
  • $\begingroup$ @Wizard +1 for the nice approach. I adapted yours for the OrderlessPatternSequence $\endgroup$
    – Ali Hashmi
    Commented Apr 22, 2017 at 13:45
4
$\begingroup$ 
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}}*)
Improve this answer
$\endgroup$
2
$\begingroup$

Here is an alternative way to do it..

lst = Sort /@ Permutations[{b, c, d}, 3] // DeleteDuplicates
PadLeft[#, 3, a] & /@ lst
Improve this answer
$\endgroup$
1
  • $\begingroup$ I realize my solution is similar to @shadowray but his solution is more clean than mine.. $\endgroup$
    – OkkesDulgerci
    Commented Apr 22, 2017 at 14:00
2
$\begingroup$

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}}
Improve this answer
$\endgroup$
1
$\begingroup$

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}}
Improve this answer
$\endgroup$
1
$\begingroup$ 
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}}

Improve this answer
$\endgroup$
0
$\begingroup$ 
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}}

Improve this answer
$\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.