Dropping specific elements from list

Question

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:

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.

Answer 1

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

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

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