4
$\begingroup$

I would like to write a function or module to generate $n$-letter words, where $n$ is some positive integer, with the restriction that certain letters in the alphabet under consideration should not simultaneously appear in any such word.

For my concrete case, I need to build $4$-letter words using the alphabet $\{a_1,a_2,a_3,a_4,a_5,a_6\}$, with the restriction that there should be no word where $a_1$ and $a_5$ appear together.

To this end, I first tried the following:

generateWords[n_Integer?Positive] := 
 Module[{tuples, result}, 
  tuples = Tuples[{a1, a2, a3, a4, a5, a6}, n];
  result = DeleteCases[tuples, Alternatives @@ Permutations[{a1, a5}, {2}]];
  result]

But this obviously has the issue that the words with a sub-word constructed from the subset $\{a_2,a_3,a_4,a_6\}$ sandwiched between any given $a_1$-$a_5$ pair are not filtered. To address this issue, I tried the following next:

generateWords[n_Integer?Positive] := 
 Module[{tuples, result, constraint}, 
  tuples = Tuples[{a1, a2, a3, a4, a5, a6}, n];
  constraint = Flatten[Permutations[{a1, a5}, {1, n}] /. {x__, y__} -> {x, __} ~~ {y}];
  result = DeleteCases[tuples, Alternatives @@ constraint];
  result]

However, this does not work at all. I know that the pattern checker in constraint is not working correctly, but I don't know a smart and short way to correct the same. I really do not want to explicitly check for simultaneous appearance of $a_1$ and $a_5$ using iterations and conditional statements.

Thanks for any help!

$\endgroup$

4 Answers 4

4
$\begingroup$

Usually in such cases, Mathematica offers a variety of different solutions.

OrderlessPatternSequence

DeleteCases[tuples, {OrderlessPatternSequence[a1, ___, a5, ___]}]

MemberQ

Select[tuples, Not[MemberQ[#, a1] && MemberQ[#, a2]] &]

SelectTuples is more memory-efficient for larger $n$:

ResourceFunction["SelectTuples"][{a1, a2, a3, a4, a5, a6}, n, 
 Not[MemberQ[#, a1] && MemberQ[#, a2]] &]
$\endgroup$
4
$\begingroup$

Using Select with ContainsAll

Select[tuples, Not @* ContainsAll[{a1, a5}]]
$\endgroup$
1
  • 1
    $\begingroup$ Thanks a lot! I like this simple result. I eventually found a way to address my issue, but at the cost of adding one more constraint: constraint1 = { ___, a1, ___, a5, ___}; constraint2 = { ___, a5, ___, a1, ___}; result = DeleteCases[tuples, constraint1 | constraint2]; But I have accepted the other reply as the answer to this question because of SelectTuples, which has a better memory-behavior at large-n values. $\endgroup$
    – abstract
    Commented May 4 at 8:48
4
$\begingroup$

For something different using PolynomialMod

abet = Array[a, 6];
tup = Tuples[abet, 4];
f[u_] := 
 PolynomialMod[Times @@ (u /. {a[1] -> x, a[5] -> y}), x  y] === 0
res = False /. GroupBy[tup, f -> Row];
(* some samples *)
Column[res[[1 ;; 10]]]
Column[res[[-10 ;; -1]]]
(* all tuples  *)
Length[res]
(* restricted length *)
Length[tup]
(* Comparing with @eldo result *)
Select[tup, Not@*ContainsAll[{a[1], a[5]}]] // Length

enter image description here

$\endgroup$
4
$\begingroup$

Instead of generating too many tuples and deleting the false ones, simply only create correct tuples.

The constriction "a1 and a5 may not appear in he same word" can be interpreted as: "construct allwords without a5 and add all words where a1 is replaced by a5":

All words without a5:

al = {a1, a2, a3, a4, a6};
words= Tuples[al, {4}];

Then add the words with a5:

words = Join[words, Select[words, MemberQ[#, a1] &] /. a1 -> a5];
Length[words]

994
$\endgroup$
5
  • $\begingroup$ Yes, this is nice. Btw, words//DeleteDuplicates needs to be there. $\endgroup$
    – abstract
    Commented May 4 at 9:37
  • $\begingroup$ There should not be any duplicates. $\endgroup$ Commented May 4 at 11:18
  • $\begingroup$ There are duplicates in words, you can check that Length@Union@words == 994. The duplicates are those words that did not have a1 in the first set of tuples, those only built from a{2,3,4,6}. $\endgroup$
    – evanb
    Commented May 4 at 15:59
  • $\begingroup$ O.k. you are right, it is an oversight from me. $\endgroup$ Commented May 4 at 16:09
  • $\begingroup$ I fixed it above. $\endgroup$ Commented May 4 at 16:17

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.