6
$\begingroup$

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?

$\endgroup$
2
  • 1
    $\begingroup$ Is the size of your example representative, or do you want to handle larger lists? $\endgroup$
    – Carl Woll
    Dec 19, 2021 at 17:36
  • $\begingroup$ I want to handle a larger list. The size of the list in this example is not representative. $\endgroup$
    – RedDevils
    Dec 19, 2021 at 18:02

6 Answers 6

7
$\begingroup$

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[
        MapThread[
            PadRight[ConstantArray[1, #1], Length[elems], 0, #2]&,
            {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]
]

Your example:

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.

$\endgroup$
7
$\begingroup$

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

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

1. SparseArray`MaximalBipartiteMatching

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

>     {{1, 2}, {3, 4}, {5, 6}, {7, 8}}

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], 
        List /@ SparseArray`MaximalBipartiteMatching[AdjacencyMatrix@el], 
        Apply[Rule]]] &;

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

2. FindIndependentEdgeSet

distinctreps = FindIndependentEdgeSet @ edgelist

enter image description here

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

enter image description here

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

$\endgroup$
5
$\begingroup$

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

Mathematica graphics

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!

$\endgroup$
0
4
$\begingroup$

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]}} *)
$\endgroup$
3
  • $\begingroup$ Thanks for noticing it. Yes, indeed there can be more results matching the criteria. I just need any one of them. $\endgroup$
    – RedDevils
    Dec 19, 2021 at 18:06
  • 2
    $\begingroup$ DuplicateFreeQ feels ignored ;) $\endgroup$
    – Ben Izd
    Dec 19, 2021 at 18:29
  • $\begingroup$ @BenIzd - Yes, DuplicateFreeQ is about twice as fast using RepeatedTiming $\endgroup$
    – Bob Hanlon
    Dec 19, 2021 at 18:41
4
$\begingroup$
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]
$\endgroup$
0
3
$\begingroup$

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]}
$\endgroup$
0

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.