# Choosing elements from a list of lists so that no elements are same

I want to construct a list having one element from each of the lists inside list1 below such that no element is chosen more than once.

list1 = {
{f[a]},
{f[b]},
{f[b], f[c]},
{f[b], f[c], f[d], f[e], f[g], f[h]}
};


The goal is to obtain:

ans = {f[a], f[b], f[c], f[d]};


The length of ans should be the same as the length of list1.

How I can obtain it in Mathematica?

• Is the size of your example representative, or do you want to handle larger lists? Commented Dec 19, 2021 at 17:36
• I want to handle a larger list. The size of the list in this example is not representative. Commented Dec 19, 2021 at 18:02

For larger lists, I think you can use LinearProgramming. Here's a function that does this.

pick[l:{__List}] := Module[{elems, lens, lefts, unique, m},
elems = Flatten @ l;
lens = Length /@ l;
lefts = Accumulate[Prepend[0] @ Most @ lens];
unique = DeleteDuplicates @ elems;
m = Join[
{lens, lefts}
],
Transpose[
UnitVector[Length[unique], #]& /@ ArrayComponents[elems]
]
];
lp = Quiet[
LinearProgramming[
ConstantArray[-1, Length[elems]],
m,
Table[{1, -1}, Length[m]],
0,
Integers
],
LinearProgramming::lpip
];
Pick[elems, lp, 1]
]


pick[list]


{f[a], f[b], f[c], f[h]}

I don't have time to explain how it works at the moment, but I will add some explanatory text later.

Construct a list of edges from the input list and use SparseArrayMaximalBipartiteMatching or FindIndependentEdgeSet to get a matching:

edgelist = Flatten[Thread[DirectedEdge[#, #], List, {2}] & /@ list1];


1. SparseArrayMaximalBipartiteMatching

matching = SparseArrayMaximalBipartiteMatching[AdjacencyMatrix @ edgelist] /.
{i_, j_} :> Rule @@ VertexList[edgelist][[{i, j}]]


Values @ matching

{f[a], f[b], f[c], f[d]}


Alternatively, define a function to get the result in a single step:

ClearAll[distinctReps1]
distinctReps1 = Module[{el = Flatten[Thread[DirectedEdge[#, #], List, {2}] & /@ #]},
# /. Extract[VertexList[el],
Apply[Rule]]] &;

distinctReps1[list1]

{f[a], f[b], f[c], f[d]}


2. FindIndependentEdgeSet

distinctreps = FindIndependentEdgeSet @ edgelist


Map[Last] @ distinctreps

{f[a], f[b], f[c], f[g]}

ClearAll[distinctReps2]
distinctReps2 = Module[{el = Flatten[Thread[DirectedEdge[#, #], List, {2}] & /@ #]},
# /. Rule @@@ FindIndependentEdgeSet@el] &;

distinctReps2[list1]

{f[a], f[b], f[c], f[g]}

graph = Graph[edgelist,
ImagePadding -> {{100, 50}, {5, 5}},
VertexLabels -> {v_ :> Placed["Name", If[Head[v] === List, Before, After]]},
PerformanceGoal -> "Quality",
GraphLayout -> "BipartiteEmbedding"];

HighlightGraph[graph,
Style[distinctreps, Directive[Opacity[.5], Red, AbsoluteThickness[5]]]]


Related Q/A: Nonrepetitive representation of a group of lists

The goal is to obtain ans = {f[a], f[b], f[c], f[d]};

I wrote this solution using somewhat Fortran style. I hope that is OK.

Clear["Global*"]
list1 = {{f[a]}, {f[b]}, {f[b], f[c]}, {f[b], f[c], f[d], f[e], f[g],f[h]}}
collection = {};
Do[Do[If[Not[MemberQ[collection, n]], AppendTo[collection, n];
Break[]], {n, m}], {m, list1}
];


If you prefer a more true Mathematica functional solution using @@/% ## :*& type notations then I am sure someone will post such solution soon. I could not find one quickly myself. When all else fails, there is a good old fashioned Loop!

There is more than one result that match the criteria.

list1 = {{f[a]}, {f[b]}, {f[b], f[c]},
{f[b], f[c], f[d], f[e], f[g], f[h]}};

Select[Tuples[list1], Length[Union[#]] == Length[list1] &]

(* {{f[a], f[b], f[c], f[d]}, {f[a], f[b], f[c], f[e]},
{f[a], f[b], f[c], f[g]}, {f[a], f[b], f[c], f[h]}} *)

• Thanks for noticing it. Yes, indeed there can be more results matching the criteria. I just need any one of them. Commented Dec 19, 2021 at 18:06
• DuplicateFreeQ feels ignored ;) Commented Dec 19, 2021 at 18:29
• @BenIzd - Yes, DuplicateFreeQ is about twice as fast using RepeatedTiming Commented Dec 19, 2021 at 18:41
list1 = {{f[a]}, {f[b]}, {f[b], f[c]}, {f[b], f[c], f[d], f[e], f[g], f[h]}};
helper[acc_, lst_] := Append[acc, RandomChoice@Complement[lst, acc]]
Fold[helper, {}, list1]


We may try to solve this by accumulating the result in a variable: res. We start with an empty res. We first look at the first sub-list and determine the first element that is not in res (it will be the first element). We then add this element to res. Then we inspect the next sub-list and do the same.

Here is the code for this:

list1 = {{f[a]}, {f[b]}, {f[b], f[c]}, {f[b], f[c], f[d], f[e], f[g],
f[h]}};
res = {};
AppendTo[res, (Select[#, Function[x, ! MemberQ[res, x]]][[1]])] & /@
list1;
res

{f[a], f[b], f[c], f[d]}
`