How do I find the all valid pairings between two sets?

Question

I have a pretty hard problem to solve here, and I have no idea how to start. I have X kind of fruits and 5 colors (let's say Red, Green, Yellow, Blue and Purple). Each fruit can be available in several colors (but in at least 1). How can I find each combination, when I need exactly 1 fruit of each color but no fruit twice (so there will always be bought exaclty 5 fruits in exactly 5 different colors)?

For example:

1. Pears are available in [Red, Green, Yellow]
2. Apples are available in [Red, Green]
3. Plums are available in [Purple]
4. Grapes are available in [Red, Green, Purple]
5. Bananas are available in [Blue, Yellow]

Since bananas are the only fruit available in Blue, it's already sure, that bananas will be bought in Blue, and not in Yellow.

These would be the solution for this list:

1. Yellow Pear, Red Apple, Purple Plum, Green Grapes, Blue Banana
2. Yellow Pear, Green Apple, Purple Plum, Red Grapes, Blue Banana

No other combination is possible here. Is there any algorithm to do this with a dynamic list, which may also have more than 5 fruits?

I know, it's a pretty hard problem, but maybe someone has a simple solution for it.

Answer 1

You could do this small size problem with brute force:

fruit = {pear, apple, plum, grape, banana};
col = {{r, g, y}, {r, g}, {p}, {r, g, p}, {b, y}};
mp = MapThread[Thread[{#1, #2}] &, {fruit, col}]

where mp gives the candidate selections. Selecting and displaying solutions:

Row[Grid[#, Frame -> True] & /@ 
  Select[Tuples[mp], Sort[#[[All, 2]]] == {b, g, p, r, y} &]]

Answer 2

You could use LinearProgramming for this. Let the vector of fruits be:

fruits = {
    "Red Pear", "Green Pear", "Yellow Pear", "Red Apple", "Green Apple",
    "Purple Plum", "Red Grapes", "Green Grapes", "Purple Grapes",
    "Blue Bannas", "Yellow Banans"
};

Then,the constraint that there are at least 5 different fruits means that the following matrix must be positive:

{
{1,1,1,0,0,0,0,0,0,0,0},
{0,0,0,1,1,0,0,0,0,0,0},
{0,0,0,0,0,1,0,0,0,0,0},
{0,0,0,0,0,0,1,1,1,0,0},
{0,0,0,0,0,0,0,0,0,1,1}
}

The constraint that there are at least 5 colors means the following matrix must be positive:

{
{1,0,0,1,0,0,1,0,0,0,0},
{0,1,0,0,1,0,0,1,0,0,0},
{0,0,1,0,0,0,0,0,0,0,1},
{0,0,0,0,0,1,0,0,1,0,0},
{0,0,0,0,0,0,0,0,0,1,0}
}

The objective function will be:

{1,1,1,1,1,1,1,1,1,1,1}

meaning that the number of total fruit is to be minimized (it is possible one might need more than 5). Here is the LinearProgramming call that solves this:

lp = LinearProgramming[
    {1,1,1,1,1,1,1,1,1,1,1},
    {
    {1,1,1,0,0,0,0,0,0,0,0},
    {0,0,0,1,1,0,0,0,0,0,0},
    {0,0,0,0,0,1,0,0,0,0,0},
    {0,0,0,0,0,0,1,1,1,0,0},
    {0,0,0,0,0,0,0,0,0,1,1},
    {1,0,0,1,0,0,1,0,0,0,0},
    {0,1,0,0,1,0,0,1,0,0,0},
    {0,0,1,0,0,0,0,0,0,0,1},
    {0,0,0,0,0,1,0,0,1,0,0},
    {0,0,0,0,0,0,0,0,0,1,0}
    },
    {1,1,1,1,1,1,1,1,1,1},
    0,
    Integers
]

LinearProgramming::lpip: Warning: integer linear programming will use a machine-precision approximation of the inputs.

{0, 0, 1, 0, 1, 1, 1, 0, 0, 1, 0}

So, one answer is:

Pick[fruits, lp, 1]

{"Yellow Pear", "Green Apple", "Purple Plum", "Red Grapes", "Blue Bannas"}

Answer 3

An even shorter solution using ResourceFunction["BacktrackSearch"]:

fruits = <|
   pears -> {red, green, yellow},
   apples -> {red, green},
   plums -> {purple},
   grapes -> {red, green, purple},
   bananas -> {blue, yellow}|>;
AssociationThread[Keys[fruits], #] & /@
 ResourceFunction["BacktrackSearch"][Values[fruits], DuplicateFreeQ, 
  DuplicateFreeQ, All]

(** {
 <|pears -> yellow, apples -> red, plums -> purple, grapes -> green, bananas -> blue|>,
 <|pears -> yellow, apples -> green, plums -> purple, grapes -> red, bananas -> blue|>
} **)

Answer 4

Construct an edge list from given information and use FindIndependentEdgeSet:

fruits = {pear, apple, plum, grape, banana};

colors = {{Red, Green, Yellow}, {Red, Green}, {Purple}, {Red, Green, 
    Purple}, {Blue, Yellow}};

edges = Flatten @ MapThread[Thread @* UndirectedEdge, {fruits, colors}];

FindIndependentEdgeSet @ edges

Graph[edges, GraphLayout -> "BipartiteEmbedding",  VertexLabels -> Automatic]

To get all matchings, we can use this method by Szabolcs:

lg = LineGraph[edges];

edges[[#]] & /@ FindIndependentVertexSet[lg, 
     Length /@ FindIndependentVertexSet[lg], All]

Answer 5

fruit = {"Pear", "Apple", "Plum", "Grape", "Banana"};
col = {{Red, Green, Yellow}, {Red, Green}, {Purple}, {Red, Green, 
    Purple}, {Blue, Yellow}};

The information about fruit is sort of encoded in col where a restricted set of colors is available to choose from for each element in fruit.

Column /@ col

The permutations over this set will have a limited number of elements compared to a brute-force method that will give 5! or 120 choices.

{3 2 1 3 2, Times @@ Length /@ col}

{36, 36}

(interimX = Outer[List, Sequence @@ col] // Flatten[#, 4] &)
res = Select[interimX, DuplicateFreeQ]

Now threading this color information with fruit:

Thread[{#, fruit}] & /@ res // Column

Answer 6

Here's a way to do it as a Boolean SAT problem with FindInstance / SatisfiabilityInstances. The annoying SymbolName remapping stuff is because Mathematica does not like variables that are not a single symbol e.g x[y] when SAT solving, so I create x$y to get around this:

Remove["Global`*"];

onehot[list_List] := BooleanCountingFunction[{1}, Length@list] @@ list

(* relation: a fruit must have exactly 1 colour *) 
relation[fruit_, cols_List] := onehot[Thread[fruit[cols]]];

(* The relations *)
rels = {
   relation[pear, {red, green, yellow}],
   relation[apple, {red, green}],
   relation[plum, {purple}],
   relation[grape, {red, green, purple}],
   relation[banana, {blue, yellow}]
   };
sys = And @@ rels;
vars = BooleanVariables[sys];

(* Group by colours, and apply onehot constraint to each colour group i.e for all red things, only one fruit-red combination can be true *)
c = And @@ (onehot /@ GatherBy[vars, #[[1]] &]);

(* tedious variable name remapping because of FindInstance not liking compounded terms *)
varRemap = AssociationThread[vars, 
   Symbol[SymbolName[#[[0]]] <> "$" <> SymbolName[#[[1]]]] & /@ vars];
invRemap = KeyValueMap[#2 -> #1 &, varRemap];

(* State the final expression and solve when true *)
expr = (sys && c) /. varRemap;

(* sols = FindInstance[expr, BooleanVariables[expr], Booleans, 100]; *)

(* Show all the true assignments for each solution set, and put the variables back to their nice compound form *) 
With[{v = BooleanVariables[expr]},
  Pick[v, #] & /@ SatisfiabilityInstances[expr, v, All]] /. invRemap

(* finalform=BooleanConvert[c&&sys,"CNF"] *)

(** {{apple[green], banana[blue], grape[red], pear[yellow], plum[purple]},
     {apple[red], banana[blue], grape[green], pear[yellow], plum[purple]}} **)