1
$\begingroup$

list[1] = {{1, 1, 0}, {1, 0, 1}, {0, 1, 1}, {-1, 1, 0}, {1, -1, 0}, {-1, -1, 0}, {-1, 0, 1}, {1, 0, -1}, {-1, 0, -1}, {0, -1, 1}, {0, 1, -1}, {0, -1, -1}}; list[2] = {{2, 0, 0}, {0, 2, 0}, {0, 0, 2}, {-2, 0, 0}, {0, -2, 0}, {0, 0, -2}}; @Ulrich Neumann gave algorithm https://mathematica.stackexchange.com/a/245764 which finds all combinations of these vectors summing to zero (duplication is allowed) where "a" vectors are selected from list[1] and "b" vectors from list[2].

Moreover, I have the following code which @Bob Hanlon gave:

Clear["Global`*"]

Format[a[n_]] := Subscript[a, n];
Format[b[n_]] := Subscript[b, n];

list[1] = {{1, 1, 0}, {1, 0, 1}, {0, 1, 1}, {-1, 1, 0}, {1, -1, 0}, {-1, -1, 
    0}, {-1, 0, 1}, {1, 0, -1}, {-1, 0, -1}, {0, -1, 1}, {0, 
    1, -1}, {0, -1, -1}};

list[2] = {{2, 0, 0}, {0, 2, 0}, {0, 0, 2}, {-2, 0, 0}, {0, -2, 0}, {0, 
    0, -2}};

Create a replacement Rule for each list element

(repl[#] = 
    Thread[list[#] ->
      Array[{a, b}[[#]], Length[list[#]]]]) & /@ {1, 2}


sol[m_Integer?Positive, n_Integer?Positive] :=
 Module[{
   lista = Tuples[list[1], {m}],
   listb = Tuples[list[2], {n}]},
   Table[
   {li /. repl[2], Select[lista, Total[#] == -Total[li] &] /. repl[1]},
   {li, listb}]]

This code uses indexed variables and express the result of the code which @Ulrich Neumann gave in terms of indexed variables.

Let me explain my problem with an example. The above code, (when a=2 and b=2), sol[2, 2] gives the following result:  result when (when a=2 and b=2):

I want to reduce the above list. For example, if a[1] and a[6] is together in a result, then I just only this part to be eliminated. For instance, consider {{b_1,b_4},{{a_1,a_6},{a_2,a_9},{a_3,a_12},{a_4,a_5},{a_5,a_4},{a_6,a_1},{a_7,a_8},{a_8,a_7},{a_9,a_2},{a_10,a_11},{a_11,a_10},{a_12,a_3}}}

Here I just want {a_1,a_6}, and {a_6,a_1} to be dropped. So, after dropping, this part will be in the form: {{b_1,b_4},{{a_2,a_9},{a_3,a_12},{a_4,a_5},{a_5,a_4},{a_7,a_8},{a_8,a_7},{a_9,a_2},{a_10,a_11},{a_11,a_10},{a_12,a_3}}} I want the same procedure through entire list given in the picture.

Consider the same example. This time I want all entire line to be removed when b[1] and b[4] is together. So for example. {{b_1,b_4},{{a_1,a_6},{a_2,a_9},{a_3,a_12},{a_4,a_5},{a_5,a_4},{a_6,a_1},{a_7,a_8},{a_8,a_7},{a_9,a_2},{a_10,a_11},{a_11,a_10},{a_12,a_3}}} will be completely dropped. It is also same for : {{b_4,b_1},{{a_1,a_6},{a_2,a_9},{a_3,a_12},{a_4,a_5},{a_5,a_4},{a_6,a_1},{a_7,a_8},{a_8,a_7},{a_9,a_2},{a_10,a_11},{a_11,a_10},{a_12,a_3}}} How can we manage these? I also look at the same problem in more general: sol[a,b], where a and b are different than 2.

$\endgroup$

1 Answer 1

1
$\begingroup$

Update: An alternative version which may be easier to generalize:

ClearAll[delete1b, delete2b]

delete1b = MapAt[DeleteCases[Alternatives @@ 
  ({OrderlessPatternSequence @ ##} & @@@ #2)], #, {All, 2}] &;

delete2b = DeleteCases[{Alternatives @@
  ({OrderlessPatternSequence @ ##} & @@@ #2), {__}}] @ # &;

Examples:

delete1b[sol[2, 2],{{a[1], a[6]}}] == delete1@{a[1], a[6]}
True
delete1b[sol[2, 2], {{a[1], a[6]}, {a[3], a[12]}, {a[7], a[8]}}] == 
 delete1[Alternatives @@ {{a[1], a[6]}, {a[3], a[12]}, {a[7], a[8]}}]
True
delete2b[sol[2, 2], {{b[1], b[4]}}]== delete2@{b[1], b[4]}
True
delete2b[sol[2, 2], {{b[1], b[2]}, {b[1], b[4]}, {b[3], b[4]}, {b[3], 
    b[4]}, {b[4], b[5]}, {b[4], b[6]}}] == 
 delete2[Alternatives @@ {{b[1], b[2]}, {b[1], b[4]}, {b[3], 
     b[4]}, {b[3], b[4]}, {b[4], b[5]}, {b[4], b[6]}}]
True
sol[3, 2] // Take[#, {2}] &

enter image description here

delete1b[sol[3, 2], {{a[6], a[7], ___}}] // Take[#, {2}] &

enter image description here

delete1b[sol[3, 2], {{a[6], a[9], ___}}] // Take[#, {2}] &

enter image description here

Original answer:

ClearAll[delete1, delete2]

delete1 = MapAt[DeleteCases[_?(MatchQ[#]@*Sort)], sol[2, 2], {All, 2}] &;
delete2 = DeleteCases[_?(MatchQ[#]@*Sort@*First)] @ sol[2, 2] &;

Examples:

delete1 @ {a[1], a[6]} // Column

enter image description here

delete1[Alternatives @@ {{a[1], a[6]}, {a[3], a[12]}, {a[7], a[8]}}] // Column

enter image description here

delete2 @ {b[1], b[4]} // Column

enter image description here

delete2[Alternatives @@  {{b[1], b[2]}, {b[1], b[4]}, {b[3], b[4]}, 
  {b[3], b[4]}, {b[4], b[5]}, {b[4], b[6]}}] // Column

enter image description here

$\endgroup$
8
  • $\begingroup$ Thanks @kglr I want to ask how can we generalize your code. For example, let consider sol[a, b], where a =3 b=2. For instance I want to drop the results which contains a_6 and a_7, Sol[3,2] has one result: {{b_1,b_2},{{a_6,a_7,a_12},{a_6,a_9,a_10},{a_6,a_10,a_9},{a_6,a_12,a_7},{a_7,a_6,a_12},{a_7,a_12,a_6},{a_9,a_6,a_10},{a_9,a_10,a_6},{a_10,a_6,a_9},{a_10,a_9,a_6},{a_12,a_6,a_7},{a_12,a_7,a_6}}}. After dropping the list will be in form {{b_1,b_2},{a_6,a_9,a_10},{a_6,a_10,a_9},{a_9,a_6,a_10},{a_9,a_10,a_6},{a_10,a_6,a_9},{a_10,a_9,a_6}}}. Also same type generalization for delete2 command. $\endgroup$
    – gunes
    Jul 10, 2021 at 19:12
  • 1
    $\begingroup$ @gunes, please see the update. $\endgroup$
    – kglr
    Jul 10, 2021 at 20:18
  • $\begingroup$ Many thanks for the update @kglr I just want to ask one last thing. When we apply the code in the example delete1b[sol[3, 2], {{a[6], a[7], ___}}] // Take[#, {2}] & we have the result: {{{b_1,b_2},{{a_6,a_9,a_10},{a_6,a_10,a_9},{a_9,a_6,a_10},{a_9,a_10,a_6},{a_10,a_6,a_9},{a_10,a_9,a_6}}}} . In the final answer, we have lots of duplications: {a_6,a_9,a_10} and {a_6,a_10,a_9} give same result. How can ı we get rid of duplications at this final stage. I used DeleteDuplicates but not worked. $\endgroup$
    – gunes
    Jul 10, 2021 at 21:50
  • 1
    $\begingroup$ @gunes, does MapAt[DeleteDuplicatesBy[Sort], {All, 2}]@ delete1b[sol[3, 2], {{a[6], a[7], ___}}] give the desired result? $\endgroup$
    – kglr
    Jul 10, 2021 at 22:15
  • 1
    $\begingroup$ @gunes, try composing delete2b with DeleteCases[{{__},{}}], i.e., use delete2c = DeleteCases[{{__},{}}]@*delete2b $\endgroup$
    – kglr
    Jul 11, 2021 at 12:44

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.