Dropping specific elements from list

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[#] =
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:

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.

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


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


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


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


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


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


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


• 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. Commented Jul 10, 2021 at 19:12
• @gunes, please see the update.
– kglr
Commented Jul 10, 2021 at 20:18
• 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. Commented Jul 10, 2021 at 21:50
• @gunes, does MapAt[DeleteDuplicatesBy[Sort], {All, 2}]@ delete1b[sol[3, 2], {{a[6], a[7], ___}}] give the desired result?
– kglr
Commented Jul 10, 2021 at 22:15
• @gunes, try composing delete2b with DeleteCases[{{__},{}}], i.e., use delete2c = DeleteCases[{{__},{}}]@*delete2b`
– kglr
Commented Jul 11, 2021 at 12:44